Tcl Library Source Code

Changes On Branch DEVELOPMENT
Login

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

Changes In Branch DEVELOPMENT Excluding Merge-Ins

This is equivalent to a diff from 6de50f2a99 to 7bbd314d4f

2005-05-24
19:19
* do.tcl: Updates to use Tcl 8.5 [return] and [catch] extensions * control.man: when availble to overcome LIMITATIONS. * do.test (do-2.3): Update to accept newer error message format. (do-2.2): Error message refer to called command name. Closed-Leaf check-in: 7bbd314d4f user: dgp tags: DEVELOPMENT
15:08
* wait-for-any.tcl: New command: control::waitForAny. * wait-for-any.test: * tclIndex: * control.tcl: Bump to version 0.2 * pkgIndex.tcl: * do.test (do-2.3): Update to accept newer error message format. check-in: c04715cd00 user: dgp tags: DEVELOPMENT
2003-04-21
23:53
Created a DEVELOPMENT branch for critcl extended package. check-in: 6292fcaaf2 user: patthoyts tags: trunk
23:00
formatting fix merged from HEAD check-in: 63eb6bab9e user: dgp tags: DEVELOPMENT
20:16
* uuencode.test: Added code to suppress output from the log package during the test. * 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. check-in: 6de50f2a99 user: andreas_kupries tags: trunk
20:11
statistics.test needs tcltest 2.1, not 1.2 check-in: 784d277425 user: dgp tags: trunk

Deleted ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
2003-04-21  Andreas Kupries  <[email protected]>

	* devdoc/indexing.txt:
	* installer.tcl: Extended [gen_main_index] to include the header
	  of Don's generated package index. This makes the final chosen
	  master index a combination of [i7/ad] and [i4/sd] as the
	  fallback position.

	* installer.tcl: Made sure that all [file copy] operations use
	  -force. Fix for #719616.

2003-04-19  Andreas Kupries  <[email protected]>

	* installer.tcl: Bug fix, the modules calendar, control, and math
	  have a "tclIndex" file which has to be installed too. Also
	  changed usage of 'tcl_pkgPath', as this variable does not exist
	  on windows.

2003-04-17  Andreas Kupries  <[email protected]>

	* configure.in: Switched over from the original build system
	* configure:    to one where configure/Makefile are optional
	* Makefile.in:  and delegating all real work to 'sak.tcl'.
	* INSTALL.txt:  Updated documentation, reduced configure macros.
	* aclocal.m4:
	* sak.tcl:
	* devdoc/releaseguide.html:

2003-04-17  Andreas Kupries  <[email protected]>

	* installer.tcl: Bug fixes in non-gui mode, added option to force
	  cmdline mode.
	
	* sak.tcl: Added command to invoke the testsuite(s).

	* installer.tcl: Added GUI.

	* main.tcl: New file, entrypoint for *kit, *pack, redirects to
	  'installer.tcl'.

	* sak.tcl: Helper tool for tcllib development (Generate
	  distribution, various forms of documentation, check the bundle
	  of packages for problems.

	* Makefile.in: Added des to the list of modules. (That is the good
	  thing which came out of the erroneous commit, we found this
	  error.)

	* mkIndex.tcl: Reverting accidential commit of this file. The
	  committed state works with a changed Makefile, but not with the
	  current one.

2003-04-16  Andreas Kupries  <[email protected]>

	* installer.tcl: Added 'des' to list. Reworked according to
	  feedback from Don.

	* tcllib_version.tcl: Added, for sharing with other scripts.

	* modules/stats/pkgIndex: Now throwing an error when trying to
	  load 'stats'.

	* modules/struct/ChangeLog: Typo correction.

2003-04-15  Andreas Kupries  <[email protected]>

	* installer.tcl: Added 'md4' to installer.tcl

2003-04-15  Pat Thoyts  <[email protected]>

	* modules/md4: New module md4 created: MD4 hash algorithm.

2003-04-15  Andreas Kupries  <[email protected]>

	* installer.tcl: EXPERIMENTAL. New installer for tcllib. Currently
	  only cmdline based. Use -help to get help.

2003-04-13  Andreas Kupries  <[email protected]>

	* Makefile.in (check-doc-markup): Fixed setting for DOC_FLAGS. The
	  option '-visualwarn' does not exist anymore. Replaced by the
	  option '-deprecated'. Thanks to Larry Virden for reporting the
	  problem.

2003-04-11  Andreas Kupries  <[email protected]>

	* install.tcl: Changed to notify the user if the directory to
	  install is not a source distribution but a CVS snapshot. Right
	  now a direct installation of a CVS snapshot is not possible.

	* Fixed bug #614591 throughout. Numerous modules updated. Also
	  first round of getting version number consistents, and updated
	  for a 1.4 release of the whole.

2003-04-09  Andreas Kupries  <[email protected]>

	* New module: devtools. Internal use only for now. Does not
	  contain true packages.

2003-04-01  Andreas Kupries  <[email protected]>

	* Makefile.in (MODULES): Added the soundex module.

2003-03-28  Andreas Kupries  <[email protected]>

	* README: Updated information about acceptable documentation
	  formats, i.e. added doctools, made it the most prefered
	  format. This fixes the [Bug #685270], reported by Larry Virden
	  <[email protected]>.

2003-03-24  Andreas Kupries  <[email protected]>

	* README: Updated to refer to the SF website for Tcllib. Thanks to
	  Larry Virden <[email protected]> for the report and
	  fix. [Bug #707607].

2003-03-17  Pat Thoyts  <[email protected]>

	* modules/ntp: New module ntp created for time related network
	protocol stuff. Added RFC868 (TIME) protocol client and example.

2003-03-13  Andreas Kupries  <[email protected]>

	* Makefile.in (install-libraries): Extended special code for
	  doctools to install the new idx and toc engines.

2003-02-11  Pat Thoyts  <[email protected]>

	* modules/des: 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.

2003-01-18  Andreas Kupries  <[email protected]>

	* More doctools changes: Command [strong] is deprecated now. Added
	  the command [copyright]. Went through all manpages to eliminate
	  [strong]. Partial setting of copyright information, where known.

2003-01-13  Andreas Kupries  <[email protected]>

	* mkInstallScripts.tcl: 
	* Makefile.in (install-libraries): Added module specific
	  installation code.

	  doctools: Install message catalogs and predefined formatting
	  engines.

	  textutil: Install hyphenation files.

	* Module doctools rewritten to make it a true package +
	  application, instead of a pure application module. This means
	  that this module now truly installs some functionality useable
	  by other applications and packages.

2003-01-03  Pat Thoyts <[email protected]>

	* smtpd: enhanced error handling for FR #655611
	  Handle some ESMTP options.
	
2002-11-24  Gerald Lester <[email protected]>

	* html: Fixed bug #643337 (changes made though 2002-12-2)
	
2002-11-24  Gerald Lester <[email protected]>

	* html: Fixed bug #596000
	
2002-10-16  Andreas Kupries  <[email protected]>

	* struct (graph): Implemented FR 603924

2002-10-14  Andreas Kupries  <[email protected]>
	
	* pop3: Fixed bug #620062.

2002-10-09  Andreas Kupries  <[email protected]>

	* Makefile.in (install-libraries): Added code to skip directories
	  without .tcl files. Some shells do not like a for with nothing
	  to iterate over.

2002-10-08  Pat Thoyts <[email protected]>

        * smtpd: implemented feature request #531531 to use MIME tokens

2002-09-25  Jeff Hobbs  <[email protected]>

	* Makefile.in: better DESTDIR/libdir support (steffen)

2002-09-14  Andreas Kupries  <[email protected]>
	
	* mime: New field_decode, extended testsuite.

2002-09-04  Andreas Kupries  <[email protected]>

	* all.tcl (tcltest::tooManyMessage): Additional command to create
	  different error messages for 8.3 and 8.4. Used in the testsuite
	  of pop3.

2002-08-30  Andreas Kupries  <[email protected]>

	* cmdline:
	* counter:
	* dns:
	* ftpd:
	* html:
	* ncgi:
	* examples/ftp: Cleaned up nits ('info exist' --> 'info exists').

2002-08-21  Andreas Kupries  <[email protected]>

	* examples/ftp: Fixed problem in ftpdemo.tcl.

2002-08-19  Andreas Kupries  <[email protected]>

	* nntp: Updated documentation, see Tcllib SF #597102.

	* Makefile.in (install-doc): Fixed problem noted by Elchonon
	  Edelson. Code to inline man.macros appended to existing
	  files. Multiple execution of 'make install-doc' thus extended
	  the manpages of tcllib with multiples of their original
	  content. Not anymore.

2002-08-16  Andreas Kupries  <[email protected]>

	* exif: Applied patch #582828. Partially applied #530970.

2002-08-15  Andreas Kupries  <[email protected]>

	* Makefile.in (DOC_EXP): Use the tclsh found during configuration
	  to run mpexpand. This ensures that mpexpand does not pick
	  something from the path on its own, possibly something too old
	  to understand TCLLIBPATH. Problem noted by Elchonon Edelson
	  <[email protected]>.

	* mime: Accepted SF Tcllib FR #595240. This entails the donation
	  of the personal mail filter mbot, as written and used by
	  Marshall T. Rose, as an example of the usage of the mime and
	  smtp packages.

	* mime (smtp): Followup to patch SF #557520/2 (See 2002-07-25).

2002-08-09  Andreas Kupries  <[email protected]>
	
	* Makefile.in (install-doc): Changed $$(basename) to
	  `basename`. Portability problem. Works for Linux for example,
	  but not everywhere else. See 2002-08-06 for the change which
	  introduced this.

2002-08-08  Andreas Kupries  <[email protected]>

	* htmlparse: Fixed SF bug #579853.

2002-08-06  Andreas Kupries  <[email protected]>

	* Makefile.in (dist): Fixed SF Bug #567079, reported by Don Porter
	  <[email protected]>. No infinite recursion anymore for
	  srcdir == builddir.

	* ftp: Fixed SF Bug #582668.

	* comm: Fixed SF Bug #589225.

	* Makefile.in (install-doc): Restored the code inlining the
	  man.macros file into the generated nroff manpages. Got somehow
	  deleted. Was still in the 'dist' target. Thanks to Reinhard Max
	  <[email protected]> for noticing this.

	* struct (pool): Fixed bug SF #585093.
	* struct (tree): Fixed bug SF #587533.

2002-07-25  Andreas Kupries  <[email protected]>

	* mime:        Applied SF patch #585455.
	* mime (smtp): Applied patch SF #557520/2.

2002-07-08  Andreas Kupries  <[email protected]>

	* struct (tree): Fixed SF bug #578460.

	* doctools: Fixed bug #578465.

2002-07-02  Don Porter <[email protected]>

	* all.tcl: Corrected name of tcltest hook procedure

2002-06-24  Andreas Kupries  <[email protected]>

	* csv: Fixed SF bug #565051.

	* mime: Fixed SF bug #548832.

2002-06-17  Andreas Kupries  <[email protected]>

	* Applied patch for bug #567428. Bug reported by Larry Virden
	  <[email protected]>, patch by him too. Correction of
	  spelling mistakes in the documentation of various modules +
	  correction of comment placements which interfere with solaris
	  conventions for nroff output.

2002-06-10  Andreas Kupries  <[email protected]>

	* Released and tagged tcllib 1.3.0. ========================

2002-06-07  Andreas Kupries  <[email protected]>

	* dns: Fixed SF bug #564670.

2002-06-05  Andreas Kupries  <[email protected]>

	* all.tcl: Updated to use a default value for -modules if that
	  option is not present.

	* install.tcl: New file, alternate installer for unix and
	  windows. Execute with any tclsh and tcllib 1.3 is installed in
	  the parent directory of the tcl script library
	  directory. Courtesy Gerald Lester
	  <[email protected]>.

	* Makefile.in (install-doc): Changed to use the doctools generated
	  nroff and html files instead of the manually written .n files.

	* configure.in (MINOR_VERSION): Updated to version 1.3

	* Makefile.in (doc): Removed tmml-doc from default set of
	  documentation.
	
	* Makefile.in (dist, install): New target 'gen-main-index'
	  encapsulates the generation of the package index for
	  tcllib. This target is used by both the direct installation
	  (install) and during the generation of a source distribution
	  (dist).

	* mkIndex.tcl: Rewritten to make use of 'pkg_mkIndex' to get the
	  list of all packages in tcllib. Added a message which deprecates
	  [package require tcllib] if it is used.

2002-06-03  Andreas Kupries  <[email protected]>

	* math (calculus): Fixed SF Tcllib Bug #553773.

	* ftpd:
	* html:
	* htmlparse:
	* base64:
	* uuencode: Updated version information.

2002-05-29  Andreas Kupries  <[email protected]>

	* mime: Fixed SF Tcllib Bug #561416

2002-05-27  Andreas Kupries  <[email protected]>

	* base64: Fixed SF Tcllib Bug #548354.

2002-05-21  Andreas Kupries  <[email protected]>

	* doctools: Fixed bug #556509.
	* fileutil: Fixed bug #556504.

2002-05-15  Andreas Kupries  <[email protected]>

	* pop3d: Fixed bug #532216. All parts of pop3d now have a
	  testsuite.

2002-05-14  Andreas Kupries  <[email protected]>

	* pop3d: Added testsuites for user database and simple mailbox
	  storage.

	* fileutil: SF Bug #462015 closed. Proosed change rejected, added
	  new commands to perform the desired operation instead.

2002-05-09  Andreas Kupries  <[email protected]>

	* doctools: Fixed bug #534334 (actually more a FR).

	* examples/csv/csvdiff: Applied patch associated with tcllib SF
	  bug #551133. Bug reported by <[email protected]>,
	  patch by <[email protected]>.

	  Accepted FR #551127 and added code implementing the feature.

2002-05-08  Andreas Kupries  <[email protected]>

	* struct (tree): Accepted FR #552972.

	* mime: Fixed bugs #539952, #553784.

2002-05-08  Don Porter <[email protected]>

	* all.tcl: Show full stack trace when an error occurs sourcing
	a test file.

2002-04-24  Andreas Kupries  <[email protected]>

	* cmdline: Accepted patch #540313

	* examples/ftp/hpupdate.tcl: Accepted patch #548221 by Larry
	  Virden <[email protected]>.
	  Fixed bug #548224 (Touch).

	* base64: Fixed bug #548112.

2002-04-23  Andreas Kupries  <[email protected]>

	* doctools: Fixed bug #527025.

	* smtp (mime): Fixed bug #547336.

2002-04-16  Andreas Kupries  <[email protected]>

	* Makefile.in (dist): Ensured that the deprecated module 'stats'
	  is not distributed anymore. Use 'counter' instead.
	  (*-force): Enforced generation of documentation, for developers.

2002-04-10  Andreas Kupries  <[email protected]>

	* Makefile.in (MODULES): Added irc module.

2002-04-04  Andreas Kupries  <[email protected]>

	* mime: Fixed bug #533025.

2002-04-01  Andreas Kupries  <[email protected]>

	* Makefile.in (doc_generate): Added 'touch' command to prevent
	  multiple execution of target.

	* struct (matrix): Fixed bug #532791.

	* doctools: Fixed SF Bug #535382.

2002-03-25  Andreas Kupries  <[email protected]>

	* doctools: Implemented FR #530059 and FR #527029.

	* Fixed minor formatting errors in several existing doctools
	  manpages.

	* struct (matrix): Fixed bug #532783.

2002-03-19  Andreas Kupries  <[email protected]>

	* ftpd: Fixed SF Bug #531799.

	* New module:  pop3d. A POP3 server.
	* Makefile.in: Added pop3d.

2002-03-15  Andreas Kupries  <[email protected]>

	* math: Update of calculus. #528434

	* report, struct (matrix): Fixed bug #530207.

2002-03-14  Andreas Kupries  <[email protected]>

	* textutil (expander): Fixed SF Bug #530056.

2002-03-13  Andreas Kupries  <[email protected]>

	* doctools: Fixed bug #528390.

2002-03-09  Andreas Kupries  <[email protected]>

	* struct (matrix): Accepted FR #524430 (-nocase).

	* doctools: FR #527716 accepted. Bug #527025 partially fixed.

2002-03-07  Andreas Kupries  <[email protected]>  

	* Makefile.in (doc_generate): Added "TCLLIBPATH=$(srcdir)/modules"
	  in front of the mpexpand invocation so that it is forced to use
	  the "expander" package inside of the distribution. This fixes
	  Tcllib Bug #525007 reported by Don Porter
	  <[email protected]>.

2002-03-02  Pat Thoyts  <[email protected]>

	* New module: dns
	* Makefile.in: updated for new module

2002-02-27  Andreas Kupries  <[email protected]>  

	* doctools: Done FR #517599. FR #520269.

	* mime: Fixed bug #519623.

	* Makefile.in (install-doc): Changed code determining the files to
	  install to handle missing files better (use 'ls', suppress error
	  messages).

2002-02-18  Andreas Kupries  <[email protected]>  

	* exif: New module. FR 517066 accepted.

2002-02-14  Andreas Kupries  <[email protected]>

	* Makefile.in (statcheck, frink, procheck): Added developer
	  targets to invoke two static code checkers.

	* Ran frink over the package and corrected several minor problems.

2002-02-12  Andreas Kupries  <[email protected]>

	* Makefile.in: Added target for generation of documentation in
	  various formats from .man pages

2002-02-01  Andreas Kupries  <[email protected]>

	* mime: Applied patch 511692.

2002-01-21  Andreas Kupries  <[email protected]>

	* Makefile.in (dist): Brought archive names and contents more in
	  sync with earlier releases. This comes from work on release 1.2.

2002-01-18  Andreas Kupries  <[email protected]>
	
	* Bumped version to 1.2, new release. Summary of changes here. See
	  the individual Changelogs to see the detailed changes in each
	  module.

	  New modules: calendar, crc, doctools, irc, smtpd, and stooop.

	  calendar:	Version is	0.1
	  crc:		Version is	1.0
	  doctools:	Version is	1.0
	  irc:		Version is	0.1
	  smtpd:	Version is	1.0
	  stooop:	Version is	4.3

	  Changed modules: base64, comm, control, csv, fileutil, ftp,
	  html, math, mime, ncgi, nntp, pop3, struct, textutil, and uri.

	  base64:	Version stays @	2.2, but got new subpackage.
	  comm:		Version up to	3.7.1
	  control:	Version up to	0.2
	  csv:		Version up to	0.2
	  fileutil:	Version up to	1.3
	  ftp:		Version up to	2.3
	  html:		Version up to	1.2
	  math:		Version up to	1.2
	  mime:		Version up to	1.3.1
	  ncgi:		Version up to	1.2.1
	  nntp:		Version up to	0.2
	  pop3:		Version up to	1.5.1
	  struct:	Version up to	1.2
	  textutil:	Version up to	0.4
	  uri:		Version up to	1.1

2002-01-18  Andreas Kupries  <[email protected]>

	* Makefile.in (dist): Fixed bug #495976.

2002-01-17  Pat Thoyts  <[email protected]>

	* crc module: added sum manual page
	* base64 module: added uuencode manual page

2002-01-17  Andreas Kupries  <[email protected]>

	* examples/csv/csvdiff: New example for csv module. FR #485717.

	* mime: Fixed bug #499242.

2002-01-16  Andreas Kupries  <[email protected]>

	* mime: Implemented FR #503336
 	* ftp:  Fixed bug #503471.
	* nntp: Fixed bug #502250

2002-01-16  Pat Thoyts  <[email protected]>

	* base64 module: added uuencode package
	* crc module: added sum and cksum packages.

2002-01-11  Pat Thoyts  <[email protected]>

	* mkInstallScripts.tcl:
	* Makefile.in: Added crc and smtpd modules to the installation files.
	
2002-01-11  Kevin Kenny  <[email protected]>

	* mkInstallScripts.tcl: Changed the installation process for
	Windows to avoid the unimplemented [file permissions] in favor of
	[file attributes].
	
2002-01-11  Kevin Kenny  <[email protected]>

	* New module: calendar.
	
2002-01-11  Pat Thoyts  <[email protected]>

	* New module: crc. From patch #501339

2002-01-11  Andreas Kupries  <[email protected]>

	* Makefile.in (install-doc): Fixed bug #500655. Using the code
	  from the tcl "Makefile.in" as template equivalent code for
	  tcllib was created and added to the file "Makefile.in". The
	  modified makefile now includes the contents of "man.macros" into
	  every installed manpage.

	* html: Applied patch #484117.

2001-12-14  Andreas Kupries  <[email protected]>

	* New module: doctools. FR #492234.

2001-12-13  Andreas Kupries  <[email protected]>

	* texturil: Applied patch #492156.

2001-12-11  Andreas Kupries  <[email protected]>

	* pop3:     Bugfix for item #490151.

	* textutil: Bugfix for item #476988.

2001-12-10  Andreas Kupries  <[email protected]>

	* textutil: Update from William, 'evalcmd' callback.

2001-12-06  Andreas Kupries  <[email protected]>

	* fileutil: Bugfix for item #486572.

2001-11-28  Reinhard Max  <[email protected]>

	* split.tcl: Speed improvement.

2001-11-23  Andreas Kupries  <[email protected]>

	* struct.matrix: Implemented FR #481022.

2001-11-19  Andreas Kupries  <[email protected]>

	* irc: Added IRC example to examples section. Patch #481479.

	* struct/graph: Applied patch #483125
	
	* smtpd: Example consolidation: Moved the smtpd example to
	  'examples' directory.

	* ftp: Implemented FR #481161.

	* ftpd: Added example ftp server used for testing the
	  functionality of FR #481161.

2001-11-17  Pat Thoyts  <[email protected]>

	* smtpd: New module.

2001-11-16  Andreas Kupries  <[email protected]>

	* csv: Applied patch #482570.

	* comm: Fixed bug #480227.

	* ftp, uri: Implemented FR #476804.

	* ftp: Applied patch #428053.

2001-11-12  Andreas Kupries  <[email protected]>

	* irc: New module. Internet protocol handling. Internet Relay Chat
	  (IRC). Author David N. Welton <[email protected]>.

	* examples/nntp: Moved example applications out of the nntp module
	  into the example space.

	* examples/ftpd: Moved example applications out of the ftpd module
	  into the example space.

	* examples/ftp: Moved example applications out of the ftp module
	  into the example space.

	* csv: Implemented FR #481023.

	* textutil: Added 'expander' code by William H. Duquette
	  <[email protected]>. Added option -strictlength to
	  adjust. Code by Dan Kuchler <[email protected]>.

2001-11-09  Joe English  <[email protected]>

	* comm: Replaced nroff macro trickery in comm.n manpage.

2001-11-07  Andreas Kupries  <[email protected]>

	* mime: Fixed bug #479174.

	* mkInstallScripts.tcl: Added code to install tclIndex files.

	* Makefile.in (install-libraries, dist): Added commands to copy
	  'tclIndex' files into installation and distribution. This fixes
	  the remainder of #475846.
	  (dist): Fixed error in generation of tar/zip files too.

2001-11-07  Andreas Kupries  <[email protected]>

	* examples/ftp/ftpvalid: New example, using ftp and uri
	  modules. Validation of ftp urls.

	* fileutil: Accepted Patch #477805.
	* ftp:      Accepted Patch #478478.

2001-11-07  Reinhard Max  <[email protected]>

	* control: added implementation for a 'do ... while/until' loop.

2001-11-04  Andreas Kupries  <[email protected]>

	* ftp: Fixed bug #476729.

2001-11-01  Andreas Kupries  <[email protected]>

	* mime: Fixed bugs #477088, #472009.

2001-10-21  Andreas Kupries  <[email protected]>

	* uri: Accepted patch #470211.

2001-10-20  Andreas Kupries  <[email protected]>

	* ncgi: Fixed bug #464560.
	* ftp:  Fixed bug #466746.

2001-10-17  Andreas Kupries  <[email protected]>

	* ------------------ Tcllib 1.1 released ------------------

	* tcllib moved to version 1.1
	
	* cmdline:	Version up to 1.1.1
	* ftp:		Version up to 2.2.1
	* html:		Version up to 1.1.1
	* md5:		Version up to 1.4.1
	* mime/smtp:	Version up to 1.3
	* ncgi:		Version up to 1.2
	* pop3:		Version up to 1.5
	* report:	Version up to 0.2
	* sha1:		Version up to 1.0.1
	* struct:	Version up to 1.1.1
	* textutil:	Version up to 0.3

2001-10-14  Jeff Hobbs  <[email protected]>

	* csv.tcl: moved to v0.2

2001-09-24   Joe English  <[email protected]>

	* modules/ftpd/ftpd.tcl: fix improperly-formatted multi-line 
	  replies.  See SF tracker ID #424797

2001-08-24   Andreas Kupries  <[email protected]>

	* Makefile.in (check): Added target to report modules without
	  testsuites and/or manpages.

2001-08-22  Andreas Kupries <[email protected]>

	* examples/nntp: Added new example application 'postnews'. This is
	  an example how to use the 'nntp'-client library provided by
	  tcllib.

	* Makefile.in (MODULES):  Added package 'comm'.

2001-08-21  Don Porter <[email protected]>

	* Makefile.in (MODULES):  Added package 'control'.

2001-08-20  Andreas Kupries  <[email protected]>

	* Makefile.in (mandir, libdir): Applied patch [447141] by Reinhard
	  Max <[email protected]> to virtualize mandir and libdir
	  via ${INSTALL_ROOT}.

	* all.tcl: Added ::tcltest::getErrorMessage in preparation of
	  fixing [440051], [440049] and [440046] reported by Larry Virden
	  <[email protected]>.

2001-07-17  Andreas Kupries <[email protected]>

	* Bumped version to 1.0

2001-07-10  Andreas Kupries <[email protected]>

	* Frink 2.2 run, fixed dubious code.

2001-07-06  Andreas Kupries <[email protected]>

	* Fixed #438748, corrections of various misspellings in manpages
	  accross all modules. 

2001-06-21  Andreas Kupries <[email protected]>

	* Ran frink and procheck over all modules and fixed the reported
	  problems. As far as they actually were problems.

2001-06-21  Andreas Kupries <[email protected]>

	* Makefile.in (MODULES): Added module 'sha1'. This is another
	  message digest like 'md5'.

2001-05-01  Andreas Kupries <[email protected]>

	* Makefile.in (MODULES):  Added module 'report'.

	* all.tcl: Added code to propagate "::tcltest::testDirectory" into
	  the slave actually doing the tests. This tripped some of the
	  tests for the new CSV module as they use some external files and
	  were thus unable to find them correctly without this setting.

	* Makefile.in (MODULES): Added module 'csv'.

	* Added directory 'examples' for future sample applications of
	  tcllib and some example applications too.

2001-04-24  Andreas Kupries <[email protected]>

	* Makefile.in: Added module 'md5'.

2001-03-26  Andreas Kupries <[email protected]>

	* Makefile.in (install-libraries):  [Bug #404917]
	  Added 'smtp' explictly to the list of modules for the full
	  package index. It is part of the 'mime' directory and thus not
	  automatically found / part of the list.

2001-03-26  Andreas Kupries <[email protected]>

	* Makefile.in: Added module 'htmlparse'.

2001-03-21  Andreas Kupries <[email protected]>

	* Makefile.in: Added module 'log'.

2001-03-20  Andreas Kupries <[email protected]>

	* all.tcl: [Bug #410100, Patch #410105]
	  Squashed a subtle bug with package management for the
	  tests. Changes: all.tcl now adds the module path to the
	  auto_path (the tested modules did it themselves before) and also
	  moved the setting of the auto_path in the slave before the first
	  'package require'. Why ? Assume the old code, an installed
	  fileutil 1.0 and a new fileutil 1.1 under development. The
	  initialization of the tests scans the package directories and
	  finds fileutil 1.0. The module then adds itself to the auto_path
	  and then requires fileutil (without version). Now fileutil 1.0
	  is found by the pkg management, it is acceptable according to
	  the rules of require and thus used. The new version is not
	  considered at all, as changing the auto_path does *not* enforce
	  a rescan of package directories. It is possible to solve the
	  problem by having the modules require themselves and request a
	  specific version (1.1 in this case). But this would mean that in
	  each module we have (at least) one more file containing the
	  version number (all test files!) and we have to maintain this
	  for every module. The change here however solves the problem
	  without touching the modules at all.

2000-11-02  Brent Welch <[email protected]>

	* configure.in: Bumped version number to 0.8

2000-11-01  Dan Kuchler <[email protected]>

	* Makefile.in: Added javascript package to tcllib.

2000-10-27  Dan Kuchler <[email protected]>

	* Makefile.in: Added ftpd package to tcllib.

2000-10-04  Brent Welch <[email protected]>

	* Makefile.in: Nuked stats in favor of counter.

2000-09-19  Brent Welch <[email protected]>

	* Makefile.in: 
	Added the stats module.
	* configure.in: 
	Increased version number to 0.7
	* modules/stats/stats.tcl:
	* modules/stats/stats.n:
	* modules/stats/stats.test:
	* modules/stats/pkgIndex.tcl:
	Initial version of the stats package.

2000-08-23  Brent Welch <[email protected]>

	* Makefile.in: fixed typo

2000-08-22  Brent Welch <[email protected]>

	* configure.in: Bumped patchlevel to 0.6.1
	* Makefile.in: Ignore errors when installing documentation,
	which only partly exists. You'll still see the error messages
	but it doesn't stop the install.
	Applied tcllib-0-6-1 tag

2000-07-19  Brent Welch <[email protected]>

	* configure.in: Bumped patchlevel to 0.6
	applied tcllib-0-6 tag

2000-06-15  Dan Kuchler	 <[email protected]>

	* Makefile.in: Added nntp client package.
	* modules/nntp: Added nntp client package to tcllib.

2000-06-13  Eric Melski	 <[email protected]>

	* Makefile.in: Added uri package.
	* modules/uri: Added uri package from Steve Ball, Andreas Kupries.

2000-06-09  Brent Welch <[email protected]>

	* configure.in: Bumped patchlevel to 0.5
	applied tcllib-0-5 tag

2000-06-02  Eric Melski	 <[email protected]>

	* Makefile.in: Added ftp package.
	* modules/ftp: Added ftp package from Steffen Traeger to tcllib.

2000-04-28  Sandeep Tamhankar <[email protected]>

	* mkInstallScripts.tcl: Fixed a bug in the UNIX shell script where
	it was checking if TCLINSTALL was non-null, but it was using ==,
	which isn't legal in /bin/sh.  I found this out the hard way while
	trying to install tcllib0.4 in the default location
	(/usr/local/lib/tcllib0.4) and because of this bug, it ended up
	installing in /lib/tcllib0.4.
	
2000-04-26  Brent Welch <[email protected]>

	* configure.in: Bumped patchlevel to 0.4
	* Makefile.in: Fixed dist target to deal with missing manual
	pages and test files.
	* mkInstallScripts.tcl: Made install directory a parameter to
	the unix install.sh script

2000-04-25  Eric Melski	 <[email protected]>

	* Makefile.in: Tweaked dist target to include README and
	license.terms in distributions.

2000-04-17  Brent Welch	 <[email protected]>

	* modules/html: Added html generation module

2000-04-10  Brent Welch	 <[email protected]>

	* Makefile.in: restored ncgi module

2000-04-07  Eric Melski	 <[email protected]>

	* configure: 
	* configure.in: Upped version to 0.3.

2000-03-29  Eric Melski	 <[email protected]>

	* mkIndex.tcl: Added missing "== -1" to [lsearch] for package dir
	in generated pkgIndex.tcl.

2000-03-28  Eric Melski	 <[email protected]>

	* Makefile.in: Added $(srcdir)/ prefix to mkIndex.tcl call in the
	install-libraries target, so that it would find the mkIndex.tcl
	script when run outside of the source tree.  Same for man.macros
	in the install-doc target, so it would find the file.

2000-03-27  Eric Melski	 <[email protected]>

	* Makefile.in: Added dist target for building distribution.

	* configure.in: Removed mkIndex.tcl from AC_OUTPUT call.

	* mkInstallScripts.tcl: First cut at script for autogenerating
	simple INSTALL.BAT and install.sh files for tcllib distributions.

	* mkIndex.tcl: 
	* mkIndex.tcl.in: Replace mkIndex.tcl.in with mkIndex.tcl, which
	now takes more args to specify values.

2000-03-09  Eric Melski	 <[email protected]>

	* Makefile.in: Added ncgi module, commented out until tests are done.

2000-03-09  Eric Melski	 <[email protected]>

	* Makefile.in: Updated test target to call out to all.tcl.

	* all.tcl: First checkin of all.tcl, the magic that hides behind
	"make test".

2000-03-08  Eric Melski	 <[email protected]>

	* Makefile.in: Commented out cgi module until it's ready for use.
	Added checks for bogus module names in install-libraries, but
	they're not foolproof.

2000-03-07  Brent Welch <[email protected]>

	* modules/cgi: Preliminary version of a CGI module.  Still needs
	some cookie functions, test suite, and docs...
	
2000-03-07  Eric Melski <[email protected]>

	* modules/math: math library

	* Makefile.in: added math library to list of modules

2000-03-07  Scott Stanton  <[email protected]>

	* configure.in: 
	* configure: 
	* aclocal.m4:
	* Makefile.in: Changed to use shared config subdirectory.  Also
	fixed problem on Windows builds where it would fail to identify
	the tclsh executable to use.  Simplified configure.in to minimum
	number of macros.

2000-03-06  Eric Melski	 <[email protected]>

	* man.macros: Moved from individual modules to toplevel tcllib
	dir, so that it is not repeated hundreds of times.
	
	* Makefile.in:
	* mkIndex.tcl.in: Added version number to installed tcllib dir.

	* license.terms: Adapted license from Tcl.
	
	* README: Added more information about file layout in module dirs.

2000-03-06  Scott Redman  <[email protected]>

	* Makefile.in:	added pop3 module.

2000-03-02  Eric Melski	 <[email protected]>

	* mkIndex.tcl.in: Instead of probing install dir for modules,
	changed to take module list on command line, so that users can
	change what goes into the pkgIndex.tcl from the Makefile.
	
	* Makefile.in: additional work on module list and pkgIndex.tcl
	generation.  Now changing the module list changes what is
	installed and what is put in the pkgIndex.tcl.

2000-03-02  Eric Melski	 <[email protected]>

	* Makefile.in: Work on install-libraries, install-doc; removed
	references to compiled bits.

	* mkIndex.tcl.in: Tweaked the generated pkgIndex.tcl to only
	append the dirname if it doesn't already exist in the auto_path,
	and to use \[file dirname \[info script\]\] instead of [pwd].

	* configure:
	* configure.in: Removed checks for compiler, and all stuff related
	to compiling/linking (this is a tcl only extension).

	* tcl.m4: new tcl.m4 from sample extension.

2000-03-01  Eric Melski	 <[email protected]>

	* Makefile.in: Added fileutil, cmdline, mime, base64 modules.

2000-02-24  Eric Melski	 <[email protected]>

	* Makefile.in, et al: Preliminary Makefile and configure script, and
	supporting files
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted INSTALL.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
How to install Tcllib
=====================

Introduction
------------

The tcllib distribution, whether a snapshot directly from CVS, or
officially released, offers a single method for installing tcllib,
based on Tcl itself.

This is based on the assumption that for tcllib to be of use Tcl has
to be present, and therefore can be used.

This single method however can be used in a variety of ways.

0	For an unwrapped (= directory) distribution or CVS snapshot

	a.	either call the application 'installer.tcl' directly,
	b	or use

			% configure ; make install

		The latter is provided for people which are used to
		this method and more comfortable with it. In end this
		boils down into a call of 'installer.tcl' too.

1.	A starpack distribution (window-only) is a self-extracting
	installer which internally uses the aforementioned installer.

2.	A starkit distribution is very much like a starpack, but
	required an external interpreyter to run. This can be any tcl
	interpreter which has all the packages to support starkits
	(tclvfs, memchan, trf).

3.	A distribution in a tarball has to be unpacked first, then any
	of the methods described in (0) can be used.


Usage of the installer
----------------------

The installer selects automatically either a gui based mode, or a
command line based mode. If the package Tk is present and can be
loaded, then the GUI mode is entered, else the system falls back to
the command line.

Note that it is possible to specify options on the command line even
if the installer ultimatively selects a gui mode. In that case the
hardwired defaults and the options determine the data presented to the
user for editing.

Command line help can be asked for by using the option -help when
running the installer (3) or the distribution itself in the case of
(1) or (2).

The installer will select a number of defaults for the locations of
packages, examples, and documentation, and also the format of the
documentation. The user can overide these defaults in the GUI, or by
specifying additional options.

The defaults depend on the platform detected (unix/windows) and the
executable used to run the installer. In the case of a starpack
distribution (1) this means that _no defaults_ are possible for the
various locations as the executable is part of the distribution and
has no knowledge of its environment.

In all other cases the intepreter executable is outside of the
distribution, which means that its location can be used to determine
sensible defaults.

Notes
-----

The installer will overwrite an existing installation of tcllib 1.4
without asking back after the initial confirmation is given. And if
the user chooses the same directory as for tcllib 1.3 the installer
will overwrite that too.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































Deleted Makefile.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
# Makefile.in --
#
#	This file is a Makefile for the tcllib standard tcl library. If this
#	is "Makefile.in" then it is a template for a Makefile;  to generate 
#	the actual Makefile, run "./configure", which is a configuration script
#	generated by the "autoconf" program (constructs like "@foo@" will get
#	replaced in the actual Makefile.
#
# Copyright (c) 1999-2000 Ajuba Solutions
# Copyright (c) 2001      ActiveState Tool Corp.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: Makefile.in,v 1.90 2003/04/18 02:57:46 andreas_kupries Exp $

#========================================================================
# Nothing of the variables below this line need to be changed.  Please
# check the TARGETS section below to make sure the make targets are
# correct.
#========================================================================

SHELL		= @SHELL@

srcdir		= @srcdir@
top_srcdir	= @top_srcdir@
prefix		= @prefix@
exec_prefix	= @exec_prefix@
libdir		= @libdir@
mandir		= @mandir@

DESTDIR		=
pkglibdir	= $(libdir)/@PACKAGE@@VERSION@
top_builddir	= .

PACKAGE = @PACKAGE@
VERSION = @VERSION@
CYGPATH = @CYGPATH@

TCLSH_PROG = @TCLSH_PROG@

CONFIG_CLEAN_FILES =

#========================================================================
# Start of user-definable TARGETS section
#========================================================================

all:
install: install-libraries install-doc
doc:     html-doc nroff-doc

install-libraries:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \
		-pkg-path   $(DESTDIR)$(pkglibdir) \
		-no-examples -no-html -no-nroff \
		-no-wait -no-gui

install-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/installer.tcl` \
		-nroff-path $(DESTDIR)$(mandir)/mann \
		-no-examples -no-pkgs -no-html \
		-no-wait -no-gui

test:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test

depend:
dist:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` gendist

clean:
	rm -rf doc *-doc

distclean: clean
	-rm -f Makefile $(CONFIG_CLEAN_FILES)
	-rm -f config.cache config.log stamp-h stamp-h[0-9]*
	-rm -f config.status

Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
	cd $(top_builddir) \
	  && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status

uninstall-binaries:


html-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` html
nroff-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` nroff
tmml-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` tmml
wiki-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` wiki
latex-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` ps
list-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` list

check:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` validate

sak-help:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` help


.PHONY: all binaries clean depend distclean doc install installdirs libraries test

# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































Deleted README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
RCS: @(#) $Id: README,v 1.6 2003/04/17 22:54:04 andreas_kupries Exp $

Welcome to the tcllib, the Tcl Standard Library.  This package is
intended to be a collection of Tcl packages that provide utility
functions useful to a large collection of Tcl programmers.

The home web site for this code is http://tcllib.sourceforge.net/ .
At this web site, you will find mailing lists, web forums, databases
for bug reports and feature requests, the CVS repository (browsable on
the web, or read-only accessible via CVS ), and more.

The structure of the tcllib source hierarchy is:

tcllib
 +- modules
     +- <module1>
     +- <module2>
     +- ...


The install hierarchy is:

.../lib/tcllib
        +- <module1>
        +- <module2>
        +- ...

There are some base requirements that a module must meet before it
will be added to tcllib:

* the module must be a proper Tcl package
* the module must use a namespace for its commands and variables
* the name of the package must be the same as the name of the
  namespace
* the module must reside in a subdirectory of the modules directory in
  the source hierarchy, and that subdirectory must have the same name
  as the package and namespace
* the module must be released under the BSD License, the terms of
  which can be found in the toplevel tcllib source directory in the file
  license.terms
* the module should have both documentation ([*]) and a test suite
  (in the form of a group of *.test files in the module directory).

  [*] Possible forms: doctools, TMML/XML, nroff (man), or HTML.
      The first format is the most prefered as it can be processed with
      tools provided by tcllib itself (See module doctools). The first
      two are prefered in general as they are semantic markup and thus
      easier to convert into other formats.

* the module must have either documentation or a test suite.  It can
  not have neither.
* the module should adhere to Tcl coding standards

When adding a module to tcllib, be sure to add it to the Makefile.in
so it will be installed.  Add a line like:

MYNEWMODULE=mynewmodule

to the list of modules at the top of the Makefile.in, and then add
$(MYNEWMODULE) to the definition of the MODULES variable.  This will
allow users to choose which modules to install by commenting or
uncommenting lines in the Makefile.

Each module source directory should have no subdirectories (other than
the CVS directory), and should contain the following files:

* source code		*.tcl
* package index		pkgIndex.tcl
* tests			*.test
* documentation		*.man, *.n, *.xml

If you do not follow this directory structure, the tcllib Makefile
will fail to locate the files from the new module.


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































Deleted STATUS.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
tcllib STATUS:
$Id: STATUS,v 1.2 2002/12/17 01:47:26 davidw Exp $

Release:
-------

Next release?

To be done before release?

Open Issues:
-----------

Problems outlined here (bgerror):
https://sourceforge.net/mailarchive/forum.php?thread_id=1288113&forum_id=6718

	Bugs/feature requests need filing.

	Several solutions offered - we need to pick one.

"Feature requests" for packages doing their own output.

Feature requests for packages using too much regexp/regsub.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Deleted aclocal.m4.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
# tcl.m4 --
#
#	This file provides a set of autoconf macros to help TEA-enable
#	a Tcl extension.
#
# Copyright (c) 1999-2000 Ajuba Solutions.
# All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#------------------------------------------------------------------------
# SC_SIMPLE_EXEEXT
#	Select the executable extension based on the host type.  This
#	is a lightweight replacement for AC_EXEEXT that doesn't require
#	a compiler.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		EXEEXT
#------------------------------------------------------------------------

AC_DEFUN(SC_SIMPLE_EXEEXT, [
    AC_MSG_CHECKING(executable extension based on host type)

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    EXEEXT=".exe"
	;;
	*)
	    EXEEXT=""
	;;
    esac

    AC_MSG_RESULT(${EXEEXT})
    AC_SUBST(EXEEXT)
])

#------------------------------------------------------------------------
# SC_PROG_TCLSH
#	Locate a tclsh shell in the following directories:
#		${exec_prefix}/bin
#		${prefix}/bin
#		${TCL_BIN_DIR}
#		${TCL_BIN_DIR}/../bin
#		${PATH}
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN(SC_PROG_TCLSH, [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [
	search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/tclsh[[8-9]]*${EXEEXT} 2> /dev/null` \
		    `ls -r $dir/tclsh*${EXEEXT} 2> /dev/null` ; do
		if test x"$ac_cv_path_tclsh" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_tclsh=$j
			break
		    fi
		fi
	    done
	done
    ])

    if test -f "$ac_cv_path_tclsh" ; then
	TCLSH_PROG=$ac_cv_path_tclsh
	AC_MSG_RESULT($TCLSH_PROG)
    else
	AC_MSG_ERROR(No tclsh found in PATH:  $search_path)
    fi
    AC_SUBST(TCLSH_PROG)
])
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































Deleted all.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
# all.tcl --
#
# This file contains a top-level script to run all of the Tcl
# tests.  Execute it by invoking "tclsh all.test" in this directory.
#
# To test a subset of the modules, invoke it by 'tclsh all.test -modules "<module list>"'
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
# 
# RCS: @(#) $Id: all.tcl,v 1.12 2003/03/29 02:01:23 patthoyts Exp $

set old_auto_path $auto_path

if {[lsearch [namespace children] ::tcltest] == -1} {
    namespace eval ::tcltest {}
    proc ::tcltest::processCmdLineArgsAddFlagsHook {} {
	return [list -modules]
    }
    proc ::tcltest::processCmdLineArgsHook {argv} {
	array set foo $argv
	catch {set ::modules $foo(-modules)}
    }
    proc ::tcltest::cleanupTestsHook {{c {}}} {
	if { [string equal $c ""] } {
	    return
	}
	# Get total/pass/skip/fail counts
	array set foo [$c eval {array get ::tcltest::numTests}]
	foreach index [list "Total" "Passed" "Skipped" "Failed"] {
	    incr ::tcltest::numTests($index) $foo($index)
	}
	incr ::tcltest::numTestFiles

	# Append the list of failFiles if necessary
	set f [$c eval {
	    set ff $::tcltest::failFiles
	    if {($::tcltest::currentFailure) && \
		    ([lsearch -exact $ff $testFileName] == -1)} {
		set res [file join $::tcllibModule $testFileName]
	    } else {
		set res ""
	    }
	    set res
	}] ; # {}
	if { ![string equal $f ""] } {
	    lappend ::tcltest::failFiles $f
	}

	# Get the "skipped because" information
	unset foo
	array set foo [$c eval {array get ::tcltest::skippedBecause}]
	foreach constraint [array names foo] {
	    if { ![info exists ::tcltest::skippedBecause($constraint)] } {
		set ::tcltest::skippedBecause($constraint) $foo($constraint)
	    } else {
		incr ::tcltest::skippedBecause($constraint) $foo($constraint)
	    }
	}

	# Clean out the state in the slave
	$c eval {
	    foreach index [list "Total" "Passed" "Skipped" "Failed"] {
		set ::tcltest::numTests($index) 0
	    }
	    set ::tcltest::failFiles {}
	    foreach constraint [array names ::tcltest::skippedBecause] {
		unset ::tcltest::skippedBecause($constraint)
	    }
	}
    }

    package require tcltest
    namespace import ::tcltest::*
}

set ::tcltest::testSingleFile false
set ::tcltest::testsDirectory [file dirname [info script]]
set root $::tcltest::testsDirectory

# We need to ensure that the testsDirectory is absolute
::tcltest::normalizePath ::tcltest::testsDirectory

puts stdout "tcllib tests"
puts stdout "Tests running in working dir:  $::tcltest::testsDirectory"
if {[llength $::tcltest::skip] > 0} {
    puts stdout "Skipping tests that match:  $::tcltest::skip"
}
if {[llength $::tcltest::match] > 0} {
    puts stdout "Only running tests that match:  $::tcltest::match"
}

if {[llength $::tcltest::skipFiles] > 0} {
    puts stdout "Skipping test files that match:  $::tcltest::skipFiles"
}
if {[llength $::tcltest::matchFiles] > 0} {
    puts stdout "Only sourcing test files that match:  $::tcltest::matchFiles"
}

set timeCmd {clock format [clock seconds]}
puts stdout "Tests began at [eval $timeCmd]"


set auto_path $old_auto_path
set auto_path [linsert $auto_path 0 [file join $root modules]]
set old_apath $auto_path

##
## Take default action if the modules are not specified
##

if {![info exists modules]} then {
    foreach module [glob [file join $root modules]/*/*.test] {
	set tmp([lindex [file split $module] end-1]) 1
    }
    set modules [array names tmp]
    unset tmp
}

foreach module $modules {
    set ::tcltest::testsDirectory [file join $root modules $module]

    if { ![file isdirectory $::tcltest::testsDirectory] } {
	puts stdout "unknown module $module"
    }

    set auto_path $old_apath
    set auto_path [linsert $auto_path 0 $::tcltest::testsDirectory]

    # foreach module, make a slave interp and source that module's tests into
    # the slave.  This isolates the test suites from one another.
    puts stdout "Module:\t[file tail $module]"
    set c [interp create]
    interp alias $c pSet {} set
    # import the auto_path from the parent interp, so "package require" works
    $c eval {
	set ::argv0 [pSet ::argv0]
	set ::tcllibModule [pSet module]
	set auto_path [pSet auto_path]
	package require tcltest
	namespace import ::tcltest::*
	set ::tcltest::testSingleFile false
	set ::tcltest::testsDirectory [pSet ::tcltest::testsDirectory]
	#set ::tcltest::verbose ps

	# Add a function to construct a proper error message for
	# 'wrong#args' situations. The format of the messages changed
	# for 8.4

	proc ::tcltest::getErrorMessage {functionName argList missingIndex} {
	    # if oldstyle errors:
	    if { [info tclversion] < 8.4 } {
		set msg "no value given for parameter "
		append msg "\"[lindex $argList $missingIndex]\" to "
		append msg "\"$functionName\""
	    } else {
		set msg "wrong # args: should be \"$functionName $argList\""
	    }
	    return $msg
	}

	proc ::tcltest::tooManyMessage {functionName argList} {
	    # if oldstyle errors:
	    if { [info tclversion] < 8.4 } {
		set msg "called \"$functionName\" with too many arguments"
	    } else {
		set msg "wrong # args: should be \"$functionName $argList\""
	    }
	    return $msg
	}
    }
    interp alias $c ::tcltest::cleanupTestsHook {} \
	    ::tcltest::cleanupTestsHook $c
    # source each of the specified tests
    foreach file [lsort [::tcltest::getMatchingFiles]] {
	set tail [file tail $file]
	puts stdout [string map [list "$root/" ""] $file]
	$c eval {
	    if {[catch {source [pSet file]} msg]} {
		puts stdout $errorInfo
	    }
	}
    }
    interp delete $c
    puts stdout ""
}

# cleanup
puts stdout "\nTests ended at [eval $timeCmd]"
::tcltest::cleanupTests 1
# FRINK: nocheck
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































Deleted config/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
2001-03-15    Karl Lehenbauer <[email protected]>

	* installFile.tcl: Added updating of the modification time of
	  the target file whether we overwrote it or decided that it
	  hadn't changed.  This was necessary for us to be able to
	  determine whether or not a module install touched the file.

2001-03-08    Karl Lehenbauer <[email protected]>

	* installFile.tcl: Added support for converting new-style (1.1+) 
	  Cygnus drive paths to Tcl-style.

2001-01-15    <[email protected]>

        * tcl.m4: Added FreeBSD clause.

2001-01-03    <[email protected]>

        * tcl.m4: Fixed typo in SC_LIB_SPEC where it is checking
	for exec-prefix.

2000-12-01    <[email protected]>

        * tcl.m4: Concatenated most of the Ajuba acsite.m4 file
	so we don't need to modify the autoconf installation.
	* config.guess:
	* config.sub:
	* installFile.tcl:
	Added files from the itcl config subdirectory,
	which should go away.

2000-7-29    <[email protected]>

        * Fixed the use of TCL_SRC_DIR and TK_SRC_DIR within TCL_PRIVATE_INCLUDES
	and TK_PRIVATE_INCLUDES to match their recent change from $(srcdir)
	to $(srcdir)/..
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































Deleted config/config.guess.

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

# Written by Per Bothner <[email protected]>.
# The master version of this file is at the FSF in /home/gd/gnu/lib.
#
# This script attempts to guess a canonical system name similar to
# config.sub.  If it succeeds, it prints the system name on stdout, and
# exits with 0.  Otherwise, it exits with 1.
#
# The plan is that this can be called by configure scripts if you
# don't specify an explicit system type (host/target name).
#
# Only a few systems have been added to this list; please add others
# (but try to keep the structure clean).
#

# This is needed to find uname on a Pyramid OSx when run in the BSD universe.
# ([email protected] 8/24/94.)
if (test -f /.attbin/uname) >/dev/null 2>&1 ; then
	PATH=$PATH:/.attbin ; export PATH
fi

UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown
UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown

trap 'rm -f dummy.c dummy.o dummy; exit 1' 1 2 15

# Note: order is significant - the case branches are not exclusive.

case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in
    alpha:OSF1:V*:*)
	# After 1.2, OSF1 uses "V1.3" for uname -r.
	echo alpha-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^V//'`
	exit 0 ;;
    alpha:OSF1:*:*)
	# 1.2 uses "1.2" for uname -r.
	echo alpha-dec-osf${UNAME_RELEASE}
        exit 0 ;;
    arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*)
	echo arm-acorn-riscix${UNAME_RELEASE}
	exit 0;;
    Pyramid*:OSx*:*:*)
	if test "`(/bin/universe) 2>/dev/null`" = att ; then
		echo pyramid-pyramid-sysv3
	else
		echo pyramid-pyramid-bsd
	fi
	exit 0 ;;
    i86pc:SunOS:5.*:*)
	echo i486-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
	exit 0 ;;
    sun4*:SunOS:5.*:*)
	echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
	exit 0 ;;
    sun4*:SunOS:6*:*)
	# According to config.sub, this is the proper way to canonicalize
	# SunOS6.  Hard to guess exactly what SunOS6 will be like, but
	# it's likely to be more like Solaris than SunOS4.
	echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'`
	exit 0 ;;
    sun4*:SunOS:*:*)
	# Japanese Language versions have a version number like `4.1.3-JL'.
	echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
	exit 0 ;;
    sun3*:SunOS:*:*)
	echo m68k-sun-sunos${UNAME_RELEASE}
	exit 0 ;;
    tp_s2*:SunOS:*:*)
	# Tadpole Sparcbook 2 running a modified 4.1.3
	echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'`
	exit 0 ;;
    RISC*:ULTRIX:*:*)
	echo mips-dec-ultrix${UNAME_RELEASE}
	exit 0 ;;
    VAX*:ULTRIX*:*:*)
	echo vax-dec-ultrix${UNAME_RELEASE}
	exit 0 ;;
    mips:*:5*:RISCos)
	echo mips-mips-riscos${UNAME_RELEASE}
	exit 0 ;;
    m88k:CX/UX:7*:*)
	echo m88k-harris-cxux7
	exit 0 ;;
    m88k:*:4*:R4*)
	echo m88k-motorola-sysv4
	exit 0 ;;
    m88k:*:3*:R3*)
	echo m88k-motorola-sysv3
	exit 0 ;;
    AViiON:dgux:*:*)
	if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx \
	     -o ${TARGET_BINARY_INTERFACE}x = x ] ; then
		echo m88k-dg-dgux${UNAME_RELEASE}
	else
		echo m88k-dg-dguxbcs${UNAME_RELEASE}
	fi
 	exit 0 ;;
    M88*:DolphinOS:*:*)	# DolphinOS (SVR3)
	echo m88k-dolphin-sysv3
	exit 0 ;;
    M88*:*:R3*:*)
	# Delta 88k system running SVR3
	echo m88k-motorola-sysv3
	exit 0 ;;
    XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3)
	echo m88k-tektronix-sysv3
	exit 0 ;;
    Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD)
	echo m68k-tektronix-bsd
	exit 0 ;;
    *:IRIX:*:*)
	echo mips-sgi-irix${UNAME_RELEASE}
	exit 0 ;;
    i[34]86:AIX:*:*)
	echo i386-ibm-aix
	exit 0 ;;
    *:AIX:2:3)
	if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then
		sed 's/^		//' << EOF >dummy.c
		#include <sys/systemcfg.h>

		main()
			{
			if (!__power_pc())
				exit(1);
			puts("powerpc-ibm-aix3.2.5");
			exit(0);
			}
EOF
		${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0
		rm -f dummy.c dummy
		echo rs6000-ibm-aix3.2.5
	elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then
		echo rs6000-ibm-aix3.2.4
	else
		echo rs6000-ibm-aix3.2
	fi
	exit 0 ;;
    *:AIX:*:4)
	if /usr/sbin/lsattr -EHl proc0 | grep POWER >/dev/null 2>&1; then
		IBM_ARCH=rs6000
	else
		IBM_ARCH=powerpc
	fi
	if grep bos410 /usr/include/stdio.h >/dev/null 2>&1; then
		IBM_REV=4.1
	elif grep bos411 /usr/include/stdio.h >/dev/null 2>&1; then
		IBM_REV=4.1.1
	else
		IBM_REV=4.${UNAME_RELEASE}
	fi
	echo ${IBM_ARCH}-ibm-aix${IBM_REV}
	exit 0 ;;
    *:AIX:*:*)
	echo rs6000-ibm-aix
	exit 0 ;;
    *:BOSX:*:*)
	echo rs6000-bull-bosx
	exit 0 ;;
    DPX/2?00:B.O.S.:*:*)
	echo m68k-bull-sysv3
	exit 0 ;;
    9000/[34]??:4.3bsd:1.*:*)
	echo m68k-hp-bsd
	exit 0 ;;
    hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*)
	echo m68k-hp-bsd4.4
	exit 0 ;;
    9000/[3478]??:HP-UX:*:*)
	case "${UNAME_MACHINE}" in
	    9000/31? )            HP_ARCH=m68000 ;;
	    9000/[34]?? )         HP_ARCH=m68k ;;
	    9000/7?? | 9000/8?7 ) HP_ARCH=hppa1.1 ;;
	    9000/8?? )            HP_ARCH=hppa1.0 ;;
	esac
	HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'`
	echo ${HP_ARCH}-hp-hpux${HPUX_REV}
	exit 0 ;;
    3050*:HI-UX:*:*)
	sed 's/^	//' << EOF >dummy.c
	#include <unistd.h>
	int
	main ()
	{
	  long cpu = sysconf (_SC_CPU_VERSION);
	  /* The order matters, because CPU_IS_HP_MC68K erroneously returns
	     true for CPU_PA_RISC1_0.  CPU_IS_PA_RISC returns correct
	     results, however.  */
	  if (CPU_IS_PA_RISC (cpu))
	    {
	      switch (cpu)
		{
		  case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break;
		  case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break;
		  case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break;
		  default: puts ("hppa-hitachi-hiuxwe2"); break;
		}
	    }
	  else if (CPU_IS_HP_MC68K (cpu))
	    puts ("m68k-hitachi-hiuxwe2");
	  else puts ("unknown-hitachi-hiuxwe2");
	  exit (0);
	}
EOF
	${CC-cc} dummy.c -o dummy && ./dummy && rm dummy.c dummy && exit 0
	rm -f dummy.c dummy
	echo unknown-hitachi-hiuxwe2
	exit 0 ;;
    9000/7??:4.3bsd:*:* | 9000/8?7:4.3bsd:*:* )
	echo hppa1.1-hp-bsd
	exit 0 ;;
    9000/8??:4.3bsd:*:*)
	echo hppa1.0-hp-bsd
	exit 0 ;;
    hp7??:OSF1:*:* | hp8?7:OSF1:*:* )
	echo hppa1.1-hp-osf
	exit 0 ;;
    hp8??:OSF1:*:*)
	echo hppa1.0-hp-osf
	exit 0 ;;
    C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*)
	echo c1-convex-bsd
        exit 0 ;;
    C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*)
	if getsysinfo -f scalar_acc
	then echo c32-convex-bsd
	else echo c2-convex-bsd
	fi
        exit 0 ;;
    C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*)
	echo c34-convex-bsd
        exit 0 ;;
    C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*)
	echo c38-convex-bsd
        exit 0 ;;
    C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*)
	echo c4-convex-bsd
        exit 0 ;;
    CRAY*X-MP:UNICOS:*:*)
	echo xmp-cray-unicos
        exit 0 ;;
    CRAY*Y-MP:UNICOS:*:*)
	echo ymp-cray-unicos
        exit 0 ;;
    CRAY-2:UNICOS:*:*)
	echo cray2-cray-unicos
        exit 0 ;;
    hp3[0-9][05]:NetBSD:*:*)
	echo m68k-hp-netbsd${UNAME_RELEASE}
	exit 0 ;;
    i[34]86:BSD/386:*:*)
	echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
	exit 0 ;;
    i[34]86:BSD/OS:*:*)
	echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE}
	exit 0 ;;
    *:FreeBSD:*:*)
	echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`
	exit 0 ;;
    *:NetBSD:*:*)
	echo ${UNAME_MACHINE}-unknown-netbsd`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'`
	exit 0 ;;
    *:GNU:*:*)
	echo `echo ${UNAME_MACHINE}|sed -e 's,/.*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'`
	exit 0 ;;
    *:Linux:*:*)
	echo ${UNAME_MACHINE}-unknown-linux
	exit 0 ;;
# ptx 4.0 does uname -s correctly, with DYNIX/ptx in there.  earlier versions
# are messed up and put the nodename in both sysname and nodename.
    i[34]86:DYNIX/ptx:4*:*)
	echo i386-sequent-sysv4
	exit 0 ;;
    i[34]86:*:4.*:* | i[34]86:SYSTEM_V:4.*:*)
	if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then
		echo ${UNAME_MACHINE}-univel-sysv${UNAME_RELEASE}
	else
		echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}
	fi
	exit 0 ;;
    i[34]86:*:3.2:*)
	if /bin/uname -X 2>/dev/null >/dev/null ; then
		UNAME_REL=`(/bin/uname -X|egrep Release|sed -e 's/.*= //')`
		(/bin/uname -X|egrep i80486 >/dev/null) && UNAME_MACHINE=i486
		echo ${UNAME_MACHINE}-unknown-sco$UNAME_REL
	elif test -f /usr/options/cb.name; then
		UNAME_REL=`sed -n 's/.*Version //p' </usr/options/cb.name`
		echo ${UNAME_MACHINE}-unknown-isc$UNAME_REL
	else
		echo ${UNAME_MACHINE}-unknown-sysv32
	fi
	exit 0 ;;
    Intel:Mach:3*:*)
	echo i386-unknown-mach3
	exit 0 ;;
    i860:*:4.*:*) # i860-SVR4
	if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then
	  echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4
	else # Add other i860-SVR4 vendors below as they are discovered.
	  echo i860-unknown-sysv${UNAME_RELEASE}  # Unknown i860-SVR4
	fi
	exit 0 ;;
    mini*:CTIX:SYS*5:*)
	# "miniframe"
	echo m68010-convergent-sysv
	exit 0 ;;
    M680[234]0:*:R3V[567]*:*)
	test -r /sysV68 && echo 'm68k-motorola-sysv' && exit 0 ;;
    3[34]??:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0)
        uname -p 2>/dev/null | grep 86 >/dev/null \
          && echo i486-ncr-sysv4.3 && exit 0 ;;
    3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*)
        uname -p 2>/dev/null | grep 86 >/dev/null \
          && echo i486-ncr-sysv4 && exit 0 ;;
    m680[234]0:LynxOS:2.2*:*)
	echo m68k-lynx-lynxos${UNAME_RELEASE}
	exit 0 ;;
    PowerPC:LynxOS:2.2*:*)
	echo powerpc-lynx-lynxos${UNAME_RELEASE}
	exit 0 ;;
    mc68030:UNIX_System_V:4.*:*)
	echo m68k-atari-sysv4
	exit 0 ;;
    i[34]86:LynxOS:2.2*:*)
	echo i386-lynx-lynxos${UNAME_RELEASE}
	exit 0 ;;
    TSUNAMI:LynxOS:2.2*:*)
	echo sparc-lynx-lynxos${UNAME_RELEASE}
	exit 0 ;;
    rs6000:LynxOS:2.2*:*)
	echo rs6000-lynx-lynxos${UNAME_RELEASE}
	exit 0 ;;
    RM*:SINIX-*:*:*)
	echo mips-sni-sysv4
	exit 0 ;;
    *:SINIX-*:*:*)
	if uname -p 2>/dev/null >/dev/null ; then
		UNAME_MACHINE=`(uname -p) 2>/dev/null`
		echo ${UNAME_MACHINE}-sni-sysv4
	else
		echo ns32k-sni-sysv
	fi
	exit 0 ;;
esac

#echo '(No uname command or uname output not recognized.)' 1>&2
#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2

cat >dummy.c <<EOF
main ()
{
#if defined (sony)
#if defined (MIPSEB)
  /* BFD wants "bsd" instead of "newsos".  Perhaps BFD should be changed,
     I don't know....  */
  printf ("mips-sony-bsd\n"); exit (0);
#else
  printf ("m68k-sony-newsos\n"); exit (0);
#endif
#endif

#if defined (__arm) && defined (__acorn) && defined (__unix)
  printf ("arm-acorn-riscix"); exit (0);
#endif

#if defined (hp300) && !defined (hpux)
  printf ("m68k-hp-bsd\n"); exit (0);
#endif

#if defined (NeXT)
#if !defined (__ARCHITECTURE__)
#define __ARCHITECTURE__ "m68k"
#endif
  int version;
  version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`;
  printf ("%s-next-nextstep%s\n", __ARCHITECTURE__,  version==2 ? "2" : "3");
  exit (0);
#endif

#if defined (MULTIMAX) || defined (n16)
#if defined (UMAXV)
  printf ("ns32k-encore-sysv\n"); exit (0);
#else
#if defined (CMU)
  printf ("ns32k-encore-mach\n"); exit (0);
#else
  printf ("ns32k-encore-bsd\n"); exit (0);
#endif
#endif
#endif

#if defined (__386BSD__)
  printf ("i386-unknown-bsd\n"); exit (0);
#endif

#if defined (sequent)
#if defined (i386)
  printf ("i386-sequent-dynix\n"); exit (0);
#endif
#if defined (ns32000)
  printf ("ns32k-sequent-dynix\n"); exit (0);
#endif
#endif

#if defined (_SEQUENT_)
  printf ("i386-sequent-ptx\n"); exit (0);
#endif

#if defined (vax)
#if !defined (ultrix)
  printf ("vax-dec-bsd\n"); exit (0);
#else
  printf ("vax-dec-ultrix\n"); exit (0);
#endif
#endif

#if defined (alliant) && defined (i860)
  printf ("i860-alliant-bsd\n"); exit (0);
#endif

  exit (1);
}
EOF

${CC-cc} dummy.c -o dummy 2>/dev/null && ./dummy && rm dummy.c dummy && exit 0
rm -f dummy.c dummy

# Apollos put the system type in the environment.

test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit 0; }

# Convex versions that predate uname can use getsysinfo(1)

if [ -x /usr/convex/getsysinfo ]
then
    case `getsysinfo -f cpu_type` in
    c1*)
	echo c1-convex-bsd
	exit 0 ;;
    c2*)
	if getsysinfo -f scalar_acc
	then echo c32-convex-bsd
	else echo c2-convex-bsd
	fi
	exit 0 ;;
    c34*)
	echo c34-convex-bsd
	exit 0 ;;
    c38*)
	echo c38-convex-bsd
	exit 0 ;;
    c4*)
	echo c4-convex-bsd
	exit 0 ;;
    esac
fi

#echo '(Unable to guess system type)' 1>&2

exit 1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted config/config.sub.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
#!/bin/sh
# Configuration validation subroutine script, version 1.1.
#   Copyright (C) 1991, 1992, 1993, 1994 Free Software Foundation, Inc.
# This file is (in principle) common to ALL GNU software.
# The presence of a machine in this file suggests that SOME GNU software
# can handle that machine.  It does not imply ALL GNU software can. 
#
# This file 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 of the License, 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., 675 Mass Ave, Cambridge, MA 02139, USA.

# As a special exception to the GNU General Public License, if you
# distribute this file as part of a program that contains a
# configuration script generated by Autoconf, you may include it under
# the same distribution terms that you use for the rest of that program.

# Configuration subroutine to validate and canonicalize a configuration type.
# Supply the specified configuration type as an argument.
# If it is invalid, we print an error message on stderr and exit with code 1.
# Otherwise, we print the canonical config type on stdout and succeed.

# This file is supposed to be the same for all GNU packages
# and recognize all the CPU types, system types and aliases
# that are meaningful with *any* GNU software.
# Each package is responsible for reporting which valid configurations
# it does not support.  The user should be able to distinguish
# a failure to support a valid configuration from a meaningless
# configuration.

# The goal of this file is to map all the various variations of a given
# machine specification into a single specification in the form:
#	CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM
# It is wrong to echo any other type of specification.

# First pass through any local machine types.
case $1 in
	*local*)
		echo $1
		exit 0
		;;
	*)
	;;
esac

# Separate what the user gave into CPU-COMPANY and OS (if any).
basic_machine=`echo $1 | sed 's/-[^-]*$//'`
if [ $basic_machine != $1 ]
then os=`echo $1 | sed 's/.*-/-/'`
else os=; fi

### Let's recognize common machines as not being operating systems so
### that things like config.sub decstation-3100 work.  We also
### recognize some manufacturers as not being operating systems, so we
### can provide default operating systems below.
case $os in
	-sun*os*)
		# Prevent following clause from handling this invalid input.
		;;
	-dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \
	-att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \
	-unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \
	-convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\
	-c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \
	-harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp )
		os=
		basic_machine=$1
		;;
	-hiux*)
		os=-hiuxwe2
		;;
	-sco4)
		os=-sco3.2v4
		basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
		;;
	-sco3.2.[4-9]*)
		os=`echo $os | sed -e 's/sco3.2./sco3.2v/'`
		basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
		;;
	-sco3.2v[4-9]*)
		# Don't forget version if it is 3.2v4 or newer.
		basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
		;;
	-sco*)
		os=-sco3.2v2
		basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
		;;
	-isc)
		os=-isc2.2
		basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
		;;
	-clix*)
		basic_machine=clipper-intergraph
		;;
	-isc*)
		basic_machine=`echo $1 | sed -e 's/86-.*/86-unknown/'`
		;;
	-lynx)
		os=-lynxos
		;;
	-ptx*)
		basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'`
		;;
	-windowsnt*)
		os=`echo $os | sed -e 's/windowsnt/winnt/'`
		;;
esac

# Decode aliases for certain CPU-COMPANY combinations.
case $basic_machine in
	# Recognize the basic CPU types without company name.
	# Some are omitted here because they have special meanings below.
	tahoe | i[345]86 | i860 | m68k | m68000 | m88k | ns32k | arm | pyramid \
		| tron | a29k | 580 | i960 | h8300 | hppa1.0 | hppa1.1 \
		| alpha | we32k | ns16k | clipper | sparclite | i370 | sh \
		| powerpc | sparc64 | 1750a | dsp16xx | mips64 | mipsel \
		| pdp11 | mips64el | mips64orion | mips64orionel )
		basic_machine=$basic_machine-unknown
		;;
	# Object if more than one company name word.
	*-*-*)
		echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
		exit 1
		;;
	# Recognize the basic CPU types with company name.
	vax-* | tahoe-* | i[345]86-* | i860-* | m68k-* | m68000-* | m88k-* \
	      | sparc-* | ns32k-* | fx80-* | arm-* | c[123]* \
	      | mips-* | pyramid-* | tron-* | a29k-* | romp-* | rs6000-* \
	      | none-* | 580-* | cray2-* | h8300-* | i960-* | xmp-* | ymp-* \
	      | hppa1.0-* | hppa1.1-* | alpha-* | we32k-* | cydra-* | ns16k-* \
	      | pn-* | np1-* | xps100-* | clipper-* | orion-* | sparclite-* \
	      | pdp11-* | sh-* | powerpc-* | sparc64-* | mips64-* | mipsel-* \
	      | mips64el-* | mips64orion-* | mips64orionel-* )
		;;
	# Recognize the various machine names and aliases which stand
	# for a CPU type and a company and sometimes even an OS.
	3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc)
		basic_machine=m68000-att
		;;
	3b*)
		basic_machine=we32k-att
		;;
	alliant | fx80)
		basic_machine=fx80-alliant
		;;
	altos | altos3068)
		basic_machine=m68k-altos
		;;
	am29k)
		basic_machine=a29k-none
		os=-bsd
		;;
	amdahl)
		basic_machine=580-amdahl
		os=-sysv
		;;
	amiga | amiga-*)
		basic_machine=m68k-cbm
		;;
	amigados)
		basic_machine=m68k-cbm
		os=-amigados
		;;
	amigaunix | amix)
		basic_machine=m68k-cbm
		os=-sysv4
		;;
	apollo68)
		basic_machine=m68k-apollo
		os=-sysv
		;;
	balance)
		basic_machine=ns32k-sequent
		os=-dynix
		;;
	convex-c1)
		basic_machine=c1-convex
		os=-bsd
		;;
	convex-c2)
		basic_machine=c2-convex
		os=-bsd
		;;
	convex-c32)
		basic_machine=c32-convex
		os=-bsd
		;;
	convex-c34)
		basic_machine=c34-convex
		os=-bsd
		;;
	convex-c38)
		basic_machine=c38-convex
		os=-bsd
		;;
	cray | ymp)
		basic_machine=ymp-cray
		os=-unicos
		;;
	cray2)
		basic_machine=cray2-cray
		os=-unicos
		;;
	crds | unos)
		basic_machine=m68k-crds
		;;
	da30 | da30-*)
		basic_machine=m68k-da30
		;;
	decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn)
		basic_machine=mips-dec
		;;
	delta | 3300 | motorola-3300 | motorola-delta \
	      | 3300-motorola | delta-motorola)
		basic_machine=m68k-motorola
		;;
	delta88)
		basic_machine=m88k-motorola
		os=-sysv3
		;;
	dpx20 | dpx20-*)
		basic_machine=rs6000-bull
		os=-bosx
		;;
	dpx2* | dpx2*-bull)
		basic_machine=m68k-bull
		os=-sysv3
		;;
	ebmon29k)
		basic_machine=a29k-amd
		os=-ebmon
		;;
	elxsi)
		basic_machine=elxsi-elxsi
		os=-bsd
		;;
	encore | umax | mmax)
		basic_machine=ns32k-encore
		;;
	fx2800)
		basic_machine=i860-alliant
		;;
	genix)
		basic_machine=ns32k-ns
		;;
	gmicro)
		basic_machine=tron-gmicro
		os=-sysv
		;;
	h3050r* | hiux*)
		basic_machine=hppa1.1-hitachi
		os=-hiuxwe2
		;;
	h8300hms)
		basic_machine=h8300-hitachi
		os=-hms
		;;
	harris)
		basic_machine=m88k-harris
		os=-sysv3
		;;
	hp300-*)
		basic_machine=m68k-hp
		;;
	hp300bsd)
		basic_machine=m68k-hp
		os=-bsd
		;;
	hp300hpux)
		basic_machine=m68k-hp
		os=-hpux
		;;
	hp9k2[0-9][0-9] | hp9k31[0-9])
		basic_machine=m68000-hp
		;;
	hp9k3[2-9][0-9])
		basic_machine=m68k-hp
		;;
	hp9k7[0-9][0-9] | hp7[0-9][0-9] | hp9k8[0-9]7 | hp8[0-9]7)
		basic_machine=hppa1.1-hp
		;;
	hp9k8[0-9][0-9] | hp8[0-9][0-9])
		basic_machine=hppa1.0-hp
		;;
	i370-ibm* | ibm*)
		basic_machine=i370-ibm
		os=-mvs
		;;
# I'm not sure what "Sysv32" means.  Should this be sysv3.2?
	i[345]86v32)
		basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
		os=-sysv32
		;;
	i[345]86v4*)
		basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
		os=-sysv4
		;;
	i[345]86v)
		basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
		os=-sysv
		;;
	i[345]86sol2)
		basic_machine=`echo $1 | sed -e 's/86.*/86-unknown/'`
		os=-solaris2
		;;
	iris | iris4d)
		basic_machine=mips-sgi
		case $os in
		    -irix*)
			;;
		    *)
			os=-irix4
			;;
		esac
		;;
	isi68 | isi)
		basic_machine=m68k-isi
		os=-sysv
		;;
	m88k-omron*)
		basic_machine=m88k-omron
		;;
	magnum | m3230)
		basic_machine=mips-mips
		os=-sysv
		;;
	merlin)
		basic_machine=ns32k-utek
		os=-sysv
		;;
	miniframe)
		basic_machine=m68000-convergent
		;;
	mips3*-*)
		basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`
		;;
	mips3*)
		basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown
		;;
	ncr3000)
		basic_machine=i486-ncr
		os=-sysv4
		;;
	news | news700 | news800 | news900)
		basic_machine=m68k-sony
		os=-newsos
		;;
	news1000)
		basic_machine=m68030-sony
		os=-newsos
		;;
	news-3600 | risc-news)
		basic_machine=mips-sony
		os=-newsos
		;;
	next | m*-next )
		basic_machine=m68k-next
		case $os in
		    -nextstep* )
			;;
		    -ns2*)
		      os=-nextstep2
			;;
		    *)
		      os=-nextstep3
			;;
		esac
		;;
	nh3000)
		basic_machine=m68k-harris
		os=-cxux
		;;
	nh[45]000)
		basic_machine=m88k-harris
		os=-cxux
		;;
	nindy960)
		basic_machine=i960-intel
		os=-nindy
		;;
	np1)
		basic_machine=np1-gould
		;;
	pa-hitachi)
		basic_machine=hppa1.1-hitachi
		os=-hiuxwe2
		;;
	paragon)
		basic_machine=i860-intel
		os=-osf
		;;
	pbd)
		basic_machine=sparc-tti
		;;
	pbb)
		basic_machine=m68k-tti
		;;
        pc532 | pc532-*)
		basic_machine=ns32k-pc532
		;;
	pentium-*)
		# We will change tis to say i586 once there has been
		# time for various packages to start to recognize that.
		basic_machine=i486-`echo $basic_machine | sed 's/^[^-]*-//'`
		;;
	pn)
		basic_machine=pn-gould
		;;
	ps2)
		basic_machine=i386-ibm
		;;
	rtpc | rtpc-*)
		basic_machine=romp-ibm
		;;
	sequent)
		basic_machine=i386-sequent
		;;
	sh)
		basic_machine=sh-hitachi
		os=-hms
		;;
	sps7)
		basic_machine=m68k-bull
		os=-sysv2
		;;
	spur)
		basic_machine=spur-unknown
		;;
	sun2)
		basic_machine=m68000-sun
		;;
	sun2os3)
		basic_machine=m68000-sun
		os=-sunos3
		;;
	sun2os4)
		basic_machine=m68000-sun
		os=-sunos4
		;;
	sun3os3)
		basic_machine=m68k-sun
		os=-sunos3
		;;
	sun3os4)
		basic_machine=m68k-sun
		os=-sunos4
		;;
	sun4os3)
		basic_machine=sparc-sun
		os=-sunos3
		;;
	sun4os4)
		basic_machine=sparc-sun
		os=-sunos4
		;;
	sun3 | sun3-*)
		basic_machine=m68k-sun
		;;
	sun4)
		basic_machine=sparc-sun
		;;
	sun386 | sun386i | roadrunner)
		basic_machine=i386-sun
		;;
	symmetry)
		basic_machine=i386-sequent
		os=-dynix
		;;
	tower | tower-32)
		basic_machine=m68k-ncr
		;;
	ultra3)
		basic_machine=a29k-nyu
		os=-sym1
		;;
	vaxv)
		basic_machine=vax-dec
		os=-sysv
		;;
	vms)
		basic_machine=vax-dec
		os=-vms
		;;
	vxworks960)
		basic_machine=i960-wrs
		os=-vxworks
		;;
	vxworks68)
		basic_machine=m68k-wrs
		os=-vxworks
		;;
	xmp)
		basic_machine=xmp-cray
		os=-unicos
		;;
        xps | xps100)
		basic_machine=xps100-honeywell
		;;
	none)
		basic_machine=none-none
		os=-none
		;;

# Here we handle the default manufacturer of certain CPU types.  It is in
# some cases the only manufacturer, in others, it is the most popular.
	mips)
		basic_machine=mips-mips
		;;
	romp)
		basic_machine=romp-ibm
		;;
	rs6000)
		basic_machine=rs6000-ibm
		;;
	vax)
		basic_machine=vax-dec
		;;
	pdp11)
		basic_machine=pdp11-dec
		;;
	we32k)
		basic_machine=we32k-att
		;;
	sparc)
		basic_machine=sparc-sun
		;;
        cydra)
		basic_machine=cydra-cydrome
		;;
	orion)
		basic_machine=orion-highlevel
		;;
	orion105)
		basic_machine=clipper-highlevel
		;;
	*)
		echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2
		exit 1
		;;
esac

# Here we canonicalize certain aliases for manufacturers.
case $basic_machine in
	*-digital*)
		basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'`
		;;
	*-commodore*)
		basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'`
		;;
	*)
		;;
esac

# Decode manufacturer-specific aliases for certain operating systems.

if [ x"$os" != x"" ]
then
case $os in
	# -solaris* is a basic system type, with this one exception.
	-solaris1 | -solaris1.*)
		os=`echo $os | sed -e 's|solaris1|sunos4|'`
		;;
	-solaris)
		os=-solaris2
		;;
	-gnu/linux*)
		os=`echo $os | sed -e 's|gnu/linux|linux|'`
		;;
	# First accept the basic system types.
	# The portable systems comes first.
	# Each alternative must end in a *, to match a version number.
	# -sysv* is not here because it comes later, after sysvr4.
	-gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \
	      | -vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[345]* \
	      | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \
	      | -amigados* | -msdos* | -newsos* | -unicos* | -aos* \
	      | -nindy* | -vxworks* | -ebmon* | -hms* | -mvs* | -clix* \
	      | -riscos* | -linux* | -uniplus* | -iris* | -rtu* | -xenix* \
	      | -hiux* | -386bsd* | -netbsd* | -freebsd* | -riscix* \
	      | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* \
	      | -ptx* | -coff* | -winnt*)
		;;
	-sunos5*)
		os=`echo $os | sed -e 's|sunos5|solaris2|'`
		;;
	-sunos6*)
		os=`echo $os | sed -e 's|sunos6|solaris3|'`
		;;
	-osfrose*)
		os=-osfrose
		;;
	-osf*)
		os=-osf
		;;
	-utek*)
		os=-bsd
		;;
	-dynix*)
		os=-bsd
		;;
	-acis*)
		os=-aos
		;;
	-ctix* | -uts*)
		os=-sysv
		;;
	-triton*)
		os=-sysv3
		;;
	-oss*)
		os=-sysv3
		;;
	-svr4)
		os=-sysv4
		;;
	-svr3)
		os=-sysv3
		;;
	-sysvr4)
		os=-sysv4
		;;
	# This must come after -sysvr4.
	-sysv*)
		;;
	-xenix)
		os=-xenix
		;;
	-none)
		;;
	*)
		# Get rid of the `-' at the beginning of $os.
		os=`echo $os | sed 's/[^-]*-//'`
		echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2
		exit 1
		;;
esac
else

# Here we handle the default operating systems that come with various machines.
# The value should be what the vendor currently ships out the door with their
# machine or put another way, the most popular os provided with the machine.

# Note that if you're going to try to match "-MANUFACTURER" here (say,
# "-sun"), then you have to tell the case statement up towards the top
# that MANUFACTURER isn't an operating system.  Otherwise, code above
# will signal an error saying that MANUFACTURER isn't an operating
# system, and we'll never get to this point.

case $basic_machine in
	*-acorn)
		os=-riscix1.2
		;;
        pdp11-*)
		os=-none
		;;
	*-dec | vax-*)
		os=-ultrix4.2
		;;
	i386-sun)
		os=-sunos4.0.2
		;;
	m68000-sun)
		os=-sunos3
		# This also exists in the configure program, but was not the
		# default.
		# os=-sunos4
		;;
	*-tti)	# must be before sparc entry or we get the wrong os.
		os=-sysv3
		;;
	sparc-* | *-sun)
		os=-sunos4.1.1
		;;
	*-ibm)
		os=-aix
		;;
	*-hp)
		os=-hpux
		;;
	*-hitachi)
		os=-hiux
		;;
	i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent)
		os=-sysv
		;;
	*-cbm)
		os=-amigados
		;;
	*-dg)
		os=-dgux
		;;
	*-dolphin)
		os=-sysv3
		;;
	m68k-ccur)
		os=-rtu
		;;
	m88k-omron*)
		os=-luna
		;;
	*-sequent)
		os=-ptx
		;;
	*-crds)
		os=-unos
		;;
	*-ns)
		os=-genix
		;;
	i370-*)
		os=-mvs
		;;
	*-next)
		os=-nextstep3
		;;
        *-gould)
		os=-sysv
		;;
        *-highlevel)
		os=-bsd
		;;
	*-encore)
		os=-bsd
		;;
        *-sgi)
		os=-irix
		;;
	*-masscomp)
		os=-rtu
		;;
	*)
		os=-none
		;;
esac
fi

# Here we handle the case where we know the os, and the CPU type, but not the
# manufacturer.  We pick the logical manufacturer.
vendor=unknown
case $basic_machine in
	*-unknown)
		case $os in
			-riscix*)
				vendor=acorn
				;;
			-sunos*)
				vendor=sun
				;;
			-lynxos*)
				vendor=lynx
				;;
			-aix*)
				vendor=ibm
				;;
			-hpux*)
				vendor=hp
				;;
			-hiux*)
				vendor=hitachi
				;;
			-unos*)
				vendor=crds
				;;
			-dgux*)
				vendor=dg
				;;
			-luna*)
				vendor=omron
				;;
			-genix*)
				vendor=ns
				;;
			-mvs*)
				vendor=ibm
				;;
			-ptx*)
				vendor=sequent
				;;
		esac
		basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"`
		;;
esac

echo $basic_machine$os
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted config/install-sh.

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

#
# install - install a program, script, or datafile
# This comes from X11R5; it is not part of GNU.
#
# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $
#
# This script is compatible with the BSD install script, but was written
# from scratch.
#


# set DOITPROG to echo to test this script

# Don't use :- since 4.3BSD and earlier shells don't like it.
doit="${DOITPROG-}"


# put in absolute paths if you don't have them in your path; or use env. vars.

mvprog="${MVPROG-mv}"
cpprog="${CPPROG-cp}"
chmodprog="${CHMODPROG-chmod}"
chownprog="${CHOWNPROG-chown}"
chgrpprog="${CHGRPPROG-chgrp}"
stripprog="${STRIPPROG-strip}"
rmprog="${RMPROG-rm}"

instcmd="$mvprog"
chmodcmd=""
chowncmd=""
chgrpcmd=""
stripcmd=""
rmcmd="$rmprog -f"
mvcmd="$mvprog"
src=""
dst=""

while [ x"$1" != x ]; do
    case $1 in
	-c) instcmd="$cpprog"
	    shift
	    continue;;

	-m) chmodcmd="$chmodprog $2"
	    shift
	    shift
	    continue;;

	-o) chowncmd="$chownprog $2"
	    shift
	    shift
	    continue;;

	-g) chgrpcmd="$chgrpprog $2"
	    shift
	    shift
	    continue;;

	-s) stripcmd="$stripprog"
	    shift
	    continue;;

	*)  if [ x"$src" = x ]
	    then
		src=$1
	    else
		dst=$1
	    fi
	    shift
	    continue;;
    esac
done

if [ x"$src" = x ]
then
	echo "install:  no input file specified"
	exit 1
fi

if [ x"$dst" = x ]
then
	echo "install:  no destination specified"
	exit 1
fi


# If destination is a directory, append the input filename; if your system
# does not like double slashes in filenames, you may need to add some logic

if [ -d $dst ]
then
	dst="$dst"/`basename $src`
fi

# Make a temp file name in the proper directory.

dstdir=`dirname $dst`
dsttmp=$dstdir/#inst.$$#

# Move or copy the file name to the temp name

$doit $instcmd $src $dsttmp

# and set any options; do chmod last to preserve setuid bits

if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi
if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi
if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi
if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi

# Now rename the file to the real destination.

$doit $rmcmd $dst
$doit $mvcmd $dsttmp $dst


exit 0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































Deleted config/installFile.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
#!/bin/sh
#
# installFile.tcl - a Tcl version of install-sh
#	that copies a file and preserves its permission bits.
#	This also optimizes out installation of existing files
#	that have the same size and time stamp as the source.
#
# \
exec tclsh8.3 "$0" ${1+"$@"}

set doCopy 0	;# Rename files instead of copy
set doStrip 0	;# Strip the symbols from installed copy
set verbose 0
set src ""
set dst ""

# Process command line arguments, compatible with install-sh

for {set i 0} {$i < $argc} {incr i} {
    set arg [lindex $argv $i]
    switch -- $arg {
	-c {
	    set doCopy 1
	}
	-m  {
	    incr i
	    # Assume UNIX standard "644", etc, so force Tcl to think octal
	    set permissions 0[lindex $argv $i]
	}
	-o  {
	    incr i
	    set owner [lindex $argv $i]
	}
	-g  {
	    incr i
	    set group [lindex $argv $i]
	}
	-s {
	    set doStrip 1
	}
	-v {
	    set verbose 1
	}
	default {
	    set src $arg
	    incr i
	    set dst [lindex $argv $i]
	    break
	}
    }
}
if {[string length $src] == 0} {
    puts stderr "$argv0: no input file specified"
    exit 1
}
if {[string length $dst] == 0} {
    puts stderr "$argv0: no destination file specified"
    exit 1
}

# Compatibility with CYGNUS-style pathnames
regsub {^/(cygdrive)?/(.)/(.*)} $src {\2:/\3} src
regsub {^/(cygdrive)?/(.)/(.*)} $dst {\2:/\3} dst

if {$verbose && $doStrip} {
    puts stderr "Ignoring -s (strip) option for $dst"
}
if {[file isdirectory $dst]} {
    set dst [file join $dst [file tail $src]]
}

# Temporary file name

set dsttmp [file join [file dirname $dst] #inst.[pid]#]

# Optimize out install if the file already exists

set actions ""
if {[file exists $dst] &&
	([file mtime $src] == [file mtime $dst]) &&
	([file size $src] == [file size $dst])} {

    # Looks like the same file, so don't bother to copy.
    # Set dsttmp in case we still need to tweak mode, group, etc.

    set dsttmp $dst
    lappend actions "already installed"
} else {
    if {"[file type $src]" == "link"} {
	# Perfom a true copy.
	set in  [open $src r]
	set out [open $dsttmp w]
	fcopy $in $out
	close $in
	close $out
    } else {
	file copy -force $src $dsttmp
    }
    lappend actions copied
}

# update the modification time of the target file
file mtime $dsttmp [clock seconds]

# At this point "$dsttmp" is installed, but might not have the
# right permissions and may need to be renamed.


foreach attrName {owner group permissions} {
    upvar 0 $attrName attr

    if {[info exists attr]} {
	if {![catch {file attributes $dsttmp -$attrName} dstattr]} {

	    # This system supports "$attrName" kind of attributes

	    if {($attr != $dstattr)} {
		file attributes $dsttmp -$attrName $attr
		lappend actions "set $attrName to $attr"
	    }
	}
    }
}

if {[string compare $dst $dsttmp] != 0} {
    file rename -force $dsttmp $dst
}
if {$verbose} {
    puts stderr "$dst: [join $actions ", "]"
}
exit 0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































Deleted config/mkinstalldirs.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#! /bin/sh
# mkinstalldirs --- make directory hierarchy
# Author: Noah Friedman <[email protected]>
# Created: 1993-05-16
# Public domain

# $Id: mkinstalldirs,v 1.1 2002/12/05 20:22:57 andreas_kupries Exp $

errstatus=0

for file
do
   set fnord `echo ":$file" | sed -ne 's/^:\//#/;s/^://;s/\// /g;s/^#/\//;p'`
   shift

   pathcomp=
   for d
   do
     pathcomp="$pathcomp$d"
     case "$pathcomp" in
       -* ) pathcomp=./$pathcomp ;;
     esac

     if test ! -d "$pathcomp"; then
        echo "mkdir $pathcomp"

        mkdir "$pathcomp" || lasterr=$?

        if test ! -d "$pathcomp"; then
  	  errstatus=$lasterr
        fi
     fi

     pathcomp="$pathcomp/"
   done
done

exit $errstatus

# mkinstalldirs ends here
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted config/tcl.m4.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
# tcl.m4 --
#
#	This file provides a set of autoconf macros to help TEA-enable
#	a Tcl extension.
#
# Copyright (c) 1999-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

#------------------------------------------------------------------------
# SC_PATH_TCLCONFIG --
#
#	Locate the tclConfig.sh file and perform a sanity check on
#	the Tcl compile flags
#
# Arguments:
#	none
#
# Results:
#
#	Adds the following arguments to configure:
#		--with-tcl=...
#
#	Defines the following vars:
#		TCL_BIN_DIR	Full path to the directory containing
#				the tclConfig.sh file
#------------------------------------------------------------------------

AC_DEFUN(SC_PATH_TCLCONFIG, [
    #
    # Ok, lets find the tcl configuration
    # First, look for one uninstalled.
    # the alternative search directory is invoked by --with-tcl
    #

    if test x"${no_tcl}" = x ; then
	# we reset no_tcl in case something fails here
	no_tcl=true
	AC_ARG_WITH(tcl, [  --with-tcl              directory containing tcl configuration (tclConfig.sh)], with_tclconfig=${withval})
	AC_MSG_CHECKING([for Tcl configuration])
	AC_CACHE_VAL(ac_cv_c_tclconfig,[

	    # First check to see if --with-tcl was specified.
	    if test x"${with_tclconfig}" != x ; then
		if test -f "${with_tclconfig}/tclConfig.sh" ; then
		    ac_cv_c_tclconfig=`(cd ${with_tclconfig}; pwd)`
		else
		    AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh])
		fi
	    fi

	    # then check for a private Tcl installation
	    if test x"${ac_cv_c_tclconfig}" = x ; then
		for i in \
			../tcl \
			`ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
			../../tcl \
			`ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
			../../../tcl \
			`ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
		    if test -f "$i/unix/tclConfig.sh" ; then
			ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
			break
		    fi
		done
	    fi

	    # check in a few common install locations
	    if test x"${ac_cv_c_tclconfig}" = x ; then
		for i in `ls -d ${prefix}/lib 2>/dev/null` \
			`ls -d /usr/lib 2>/dev/null` \
			`ls -d /usr/local/lib 2>/dev/null` ; do
		    if test -f "$i/tclConfig.sh" ; then
			ac_cv_c_tclconfig=`(cd $i; pwd)`
			break
		    fi
		done
	    fi

	    # check in a few other private locations
	    if test x"${ac_cv_c_tclconfig}" = x ; then
		for i in \
			${srcdir}/../tcl \
			`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
		    if test -f "$i/unix/tclConfig.sh" ; then
		    ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
		    break
		fi
		done
	    fi
	])

	if test x"${ac_cv_c_tclconfig}" = x ; then
	    TCL_BIN_DIR="# no Tcl configs found"
	    AC_MSG_WARN(Can't find Tcl configuration definitions)
	    exit 0
	else
	    no_tcl=
	    TCL_BIN_DIR=${ac_cv_c_tclconfig}
	    AC_MSG_RESULT(found $TCL_BIN_DIR/tclConfig.sh)
	fi
    fi
])

#------------------------------------------------------------------------
# SC_PATH_TKCONFIG --
#
#	Locate the tkConfig.sh file
#
# Arguments:
#	none
#
# Results:
#
#	Adds the following arguments to configure:
#		--with-tk=...
#
#	Defines the following vars:
#		TK_BIN_DIR	Full path to the directory containing
#				the tkConfig.sh file
#------------------------------------------------------------------------

AC_DEFUN(SC_PATH_TKCONFIG, [
    #
    # Ok, lets find the tk configuration
    # First, look for one uninstalled.
    # the alternative search directory is invoked by --with-tk
    #

    if test x"${no_tk}" = x ; then
	# we reset no_tk in case something fails here
	no_tk=true
	AC_ARG_WITH(tk, [  --with-tk               directory containing tk configuration (tkConfig.sh)], with_tkconfig=${withval})
	AC_MSG_CHECKING([for Tk configuration])
	AC_CACHE_VAL(ac_cv_c_tkconfig,[

	    # First check to see if --with-tkconfig was specified.
	    if test x"${with_tkconfig}" != x ; then
		if test -f "${with_tkconfig}/tkConfig.sh" ; then
		    ac_cv_c_tkconfig=`(cd ${with_tkconfig}; pwd)`
		else
		    AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh])
		fi
	    fi

	    # then check for a private Tk library
	    if test x"${ac_cv_c_tkconfig}" = x ; then
		for i in \
			../tk \
			`ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \
			../../tk \
			`ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \
			../../../tk \
			`ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
		    if test -f "$i/unix/tkConfig.sh" ; then
			ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
			break
		    fi
		done
	    fi
	    # check in a few common install locations
	    if test x"${ac_cv_c_tkconfig}" = x ; then
		for i in `ls -d ${prefix}/lib 2>/dev/null` \
			`ls -d /usr/lib 2>/dev/null` \
			`ls -d /usr/local/lib 2>/dev/null` ; do
		    if test -f "$i/tkConfig.sh" ; then
			ac_cv_c_tkconfig=`(cd $i; pwd)`
			break
		    fi
		done
	    fi
	    # check in a few other private locations
	    if test x"${ac_cv_c_tkconfig}" = x ; then
		for i in \
			${srcdir}/../tk \
			`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
		    if test -f "$i/unix/tkConfig.sh" ; then
			ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
			break
		    fi
		done
	    fi
	])
	if test x"${ac_cv_c_tkconfig}" = x ; then
	    TK_BIN_DIR="# no Tk configs found"
	    AC_MSG_WARN(Can't find Tk configuration definitions)
	    exit 0
	else
	    no_tk=
	    TK_BIN_DIR=${ac_cv_c_tkconfig}
	    AC_MSG_RESULT(found $TK_BIN_DIR/tkConfig.sh)
	fi
    fi

])

#------------------------------------------------------------------------
# SC_LOAD_TCLCONFIG --
#
#	Load the tclConfig.sh file
#
# Arguments:
#	
#	Requires the following vars to be set:
#		TCL_BIN_DIR
#
# Results:
#
#	Subst the following vars:
#		TCL_BIN_DIR
#		TCL_SRC_DIR
#		TCL_LIB_FILE
#
#------------------------------------------------------------------------

AC_DEFUN(SC_LOAD_TCLCONFIG, [
    AC_MSG_CHECKING([for existence of $TCL_BIN_DIR/tclConfig.sh])

    if test -f "$TCL_BIN_DIR/tclConfig.sh" ; then
        AC_MSG_RESULT([loading])
	. $TCL_BIN_DIR/tclConfig.sh
    else
        AC_MSG_RESULT([file not found])
    fi

    #
    # The eval is required to do the TCL_DBGX substitution in the
    # TCL_LIB_FILE variable
    #

    eval TCL_LIB_FILE=${TCL_LIB_FILE}
    eval TCL_LIB_FLAG=${TCL_LIB_FLAG}

    AC_SUBST(TCL_DBGX)
    AC_SUBST(TCL_BIN_DIR)
    AC_SUBST(TCL_SRC_DIR)
    AC_SUBST(TCL_LIB_FILE)
    AC_SUBST(TCL_LIBS)
    AC_SUBST(TCL_DEFS)
    AC_SUBST(TCL_SHLIB_LD_LIBS)
    AC_SUBST(TCL_EXTRA_CFLAGS)
    AC_SUBST(TCL_LD_FLAGS)
    AC_SUBST(TCL_LIB_FILE)
    AC_SUBST(TCL_STUB_LIB_FILE)
    AC_SUBST(TCL_LIB_SPEC)
    AC_SUBST(TCL_BUILD_LIB_SPEC)
    AC_SUBST(TCL_STUB_LIB_SPEC)
    AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
])

#------------------------------------------------------------------------
# SC_LOAD_TKCONFIG --
#
#	Load the tkConfig.sh file
#
# Arguments:
#	
#	Requires the following vars to be set:
#		TK_BIN_DIR
#
# Results:
#
#	Sets the following vars that should be in tkConfig.sh:
#		TK_BIN_DIR
#------------------------------------------------------------------------

AC_DEFUN(SC_LOAD_TKCONFIG, [
    AC_MSG_CHECKING([for existence of $TK_BIN_DIR/tkConfig.sh])

    if test -f "$TK_BIN_DIR/tkConfig.sh" ; then
        AC_MSG_RESULT([loading])
	. $TK_BIN_DIR/tkConfig.sh
    else
        AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh])
    fi

    AC_SUBST(TK_BIN_DIR)
    AC_SUBST(TK_SRC_DIR)
    AC_SUBST(TK_LIB_FILE)
    AC_SUBST(TK_XINCLUDES)
])

#------------------------------------------------------------------------
# SC_ENABLE_GCC --
#
#	Allows the use of GCC if available
#
# Arguments:
#	none
#	
# Results:
#
#	Adds the following arguments to configure:
#		--enable-gcc
#
#	Sets the following vars:
#		CC	Command to use for the compiler
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_GCC, [
    AC_ARG_ENABLE(gcc, [  --enable-gcc            allow use of gcc if available [--disable-gcc]],
	[ok=$enableval], [ok=no])
    if test "$ok" = "yes"; then
	CC=gcc
    else
	case "`uname -s`" in
	    *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*)
		CC=cl
	    ;;
	    *)
		CC=${CC-cc}
	    ;;
	esac
    fi
    AC_PROG_CC
])

#------------------------------------------------------------------------
# SC_ENABLE_SHARED --
#
#	Allows the building of shared libraries
#
# Arguments:
#	none
#	
# Results:
#
#	Adds the following arguments to configure:
#		--enable-shared=yes|no
#
#	Defines the following vars:
#		STATIC_BUILD	Used for building import/export libraries
#				on Windows.
#
#	Sets the following vars:
#		SHARED_BUILD	Value of 1 or 0
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_SHARED, [
    AC_MSG_CHECKING([how to build libraries])
    AC_ARG_ENABLE(shared,
	[  --enable-shared         build and link with shared libraries [--enable-shared]],
	[tcl_ok=$enableval], [tcl_ok=yes])

    if test "${enable_shared+set}" = set; then
	enableval="$enable_shared"
	tcl_ok=$enableval
    else
	tcl_ok=yes
    fi

    if test "$tcl_ok" = "yes" ; then
	AC_MSG_RESULT([shared])
	SHARED_BUILD=1
    else
	AC_MSG_RESULT([static])
	SHARED_BUILD=0
	AC_DEFINE(STATIC_BUILD)
    fi
])

#------------------------------------------------------------------------
# SC_ENABLE_THREADS --
#
#	Specify if thread support should be enabled
#
# Arguments:
#	none
#	
# Results:
#
#	Adds the following arguments to configure:
#		--enable-threads
#
#	Sets the following vars:
#		THREADS_LIBS	Thread library(s)
#
#	Defines the following vars:
#		TCL_THREADS
#		_REENTRANT
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_THREADS, [
    AC_MSG_CHECKING(for building with threads)
    AC_ARG_ENABLE(threads, [  --enable-threads        build with threads],
	[tcl_ok=$enableval], [tcl_ok=no])

    if test "$tcl_ok" = "yes"; then
	TCL_THREADS=1
	AC_DEFINE(TCL_THREADS)
	AC_DEFINE(_REENTRANT)

	case "`uname -s`" in
	    *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*)
		    AC_MSG_RESULT(yes)
		;;
	    *)
		AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
		if test "$tcl_ok" = "yes"; then
		    # The space is needed
		    THREADS_LIBS=" -lpthread"
		    AC_MSG_RESULT(yes)
		else
		    TCL_THREADS=0
		    AC_MSG_RESULT(no)
		    AC_MSG_WARN("Don t know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...")
		fi
		;;
	esac
    else
	TCL_THREADS=0
	AC_MSG_RESULT(no (default))
    fi

])

#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
#	Specify if debugging symbols should be used
#
# Arguments:
#	none
#	
#	Requires the following vars to be set:
#		CFLAGS_DEBUG
#		CFLAGS_OPTIMIZE
#		LDFLAGS_DEBUG
#		LDFLAGS_OPTIMIZE
#	
# Results:
#
#	Adds the following arguments to configure:
#		--enable-symbols
#
#	Defines the following vars:
#		CFLAGS_DEFAULT	Sets to CFLAGS_DEBUG if true
#				Sets to CFLAGS_OPTIMIZE if false
#		LDFLAGS_DEFAULT	Sets to LDFLAGS_DEBUG if true
#				Sets to LDFLAGS_OPTIMIZE if false
#		DBGX		Debug library extension
#
#------------------------------------------------------------------------

AC_DEFUN(SC_ENABLE_SYMBOLS, [
    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*)
	    tcl_dbgx=d
	;;
	*)
	    tcl_dbgx=g
	;;
    esac

    AC_MSG_CHECKING([for build with symbols])
    AC_ARG_ENABLE(symbols, [  --enable-symbols        build with debugging symbols [--disable-symbols]],    [tcl_ok=$enableval], [tcl_ok=no])
    if test "$tcl_ok" = "yes"; then
	CFLAGS_DEFAULT="${CFLAGS_DEBUG}"
	LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}"
	DBGX=${tcl_dbgx}
	TCL_DBGX=${tcl_dbgx}
	AC_MSG_RESULT([yes])
    else
	CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}"
	LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}"
	DBGX=""
	TCL_DBGX=""
	AC_MSG_RESULT([no])
    fi

    AC_SUBST(TCL_DBGX)
    AC_SUBST(CFLAGS_DEFAULT)
    AC_SUBST(LDFLAGS_DEFAULT)
])

#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
#	Try to determine the proper flags to pass to the compiler
#	for building shared libraries and other such nonsense.
#
# Arguments:
#	none
#
# Results:
#
#	Defines the following vars:
#
#       DL_OBJS -       Name of the object file that implements dynamic
#                       loading for Tcl on this system.
#       DL_LIBS -       Library file(s) to include in tclsh and other base
#                       applications in order for the "load" command to work.
#       LDFLAGS -      Flags to pass to the compiler when linking object
#                       files into an executable application binary such
#                       as tclsh.
#       LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
#                       that tell the run-time dynamic linker where to look
#                       for shared libraries such as libtcl.so.  Depends on
#                       the variable LIB_RUNTIME_DIR in the Makefile.
#       MAKE_LIB -      Command to execute to build the Tcl library;
#                       differs depending on whether or not Tcl is being
#                       compiled as a shared library.
#       SHLIB_CFLAGS -  Flags to pass to cc when compiling the components
#                       of a shared library (may request position-independent
#                       code, among other things).
#       SHLIB_LD -      Base command to use for combining object files
#                       into a shared library.
#       SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
#                       creating shared libraries.  This symbol typically
#                       goes at the end of the "ld" commands that build
#                       shared libraries. The value of the symbol is
#                       "${LIBS}" if all of the dependent libraries should
#                       be specified when creating a shared library.  If
#                       dependent libraries should not be specified (as on
#                       SunOS 4.x, where they cause the link to fail, or in
#                       general if Tcl and Tk aren't themselves shared
#                       libraries), then this symbol has an empty string
#                       as its value.
#       SHLIB_SUFFIX -  Suffix to use for the names of dynamically loadable
#                       extensions.  An empty string means we don't know how
#                       to use shared libraries on this platform.
#       TCL_LIB_FILE -  Name of the file that contains the Tcl library, such
#                       as libtcl7.8.so or libtcl7.8.a.
#       TCL_LIB_SUFFIX -Specifies everything that comes after the "libtcl"
#                       in the shared library name, using the $VERSION variable
#                       to put the version in the right place.  This is used
#                       by platforms that need non-standard library names.
#                       Examples:  ${VERSION}.so.1.1 on NetBSD, since it needs
#                       to have a version after the .so, and ${VERSION}.a
#                       on AIX, since the Tcl shared library needs to have
#                       a .a extension whereas shared objects for loadable
#                       extensions have a .so extension.  Defaults to
#                       ${VERSION}${SHLIB_SUFFIX}.
#       TCL_NEEDS_EXP_FILE -
#                       1 means that an export file is needed to link to a
#                       shared library.
#       TCL_EXP_FILE -  The name of the installed export / import file which
#                       should be used to link to the Tcl shared library.
#                       Empty if Tcl is unshared.
#       TCL_BUILD_EXP_FILE -
#                       The name of the built export / import file which
#                       should be used to link to the Tcl shared library.
#                       Empty if Tcl is unshared.
#	CFLAGS_DEBUG -
#			Flags used when running the compiler in debug mode
#	CFLAGS_OPTIMIZE -
#			Flags used when running the compiler in optimize mode
#
#	EXTRA_CFLAGS
#
#	Subst's the following vars:
#		DL_LIBS
#		CFLAGS_DEBUG
#		CFLAGS_OPTIMIZE
#--------------------------------------------------------------------

AC_DEFUN(SC_CONFIG_CFLAGS, [

    # Step 0: Enable 64 bit support?

    AC_MSG_CHECKING([if 64bit support is enabled])
    AC_ARG_ENABLE(64bit,[  --enable-64bit          enable 64bit support],,enableval="no")

    if test "$enableval" = "yes"; then
	AC_MSG_RESULT(Will compile with 64bit support)
	do64bit=yes
    else
	do64bit=no
    fi
    AC_MSG_RESULT($do64bit)
 
    # Step 1: set the variable "system" to hold the name and version number
    # for the system.  This can usually be done via the "uname" command, but
    # there are a few systems, like Next, where this doesn't work.

    AC_MSG_CHECKING([system version (for dynamic loading)])
    if test -f /usr/lib/NextStep/software_version; then
	system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
    else
	system=`uname -s`-`uname -r`
	if test "$?" -ne 0 ; then
	    AC_MSG_RESULT([unknown (can't find uname command)])
	    system=unknown
	else
	    # Special check for weird MP-RAS system (uname returns weird
	    # results, and the version is kept in special file).
	
	    if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
		system=MP-RAS-`awk '{print $3}' /etc/.relid'`
	    fi
	    if test "`uname -s`" = "AIX" ; then
		system=AIX-`uname -v`.`uname -r`
	    fi
	    AC_MSG_RESULT($system)
	fi
    fi

    # Step 2: check for existence of -ldl library.  This is needed because
    # Linux can use either -ldl or -ldld for dynamic loading.

    AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no)

    # Step 3: set configuration options based on system name and version.

    do64bit_ok=no
    fullSrcDir=`cd $srcdir; pwd`
    EXTRA_CFLAGS=""
    TCL_EXPORT_FILE_SUFFIX=""
    UNSHARED_LIB_SUFFIX=""
    TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
    ECHO_VERSION='`echo ${VERSION}`'
    TCL_LIB_VERSIONS_OK=ok
    CFLAGS_DEBUG=-g
    CFLAGS_OPTIMIZE=-O
    TCL_NEEDS_EXP_FILE=0
    TCL_BUILD_EXP_FILE=""
    TCL_EXP_FILE=""
    STLIB_LD="ar cr"
    case $system in
	AIX-5.*)
	    if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		AC_MSG_RESULT(Using $CC for compiling with threads)
	    fi
	    # AIX-5 uses ELF style dynamic libraries
	    SHLIB_CFLAGS=""
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"

	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    # AIX-5 has dl* in libc.so
	    DL_LIBS=""
	    LDFLAGS=""
	    if test "$using_gcc" = "yes" ; then
		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    else
		LD_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
	    fi

	    if test "$do64bit" = "yes" ; then
		if test "$using_gcc" = "no" ; then
		    do64bit_ok=yes
		    EXTRA_CFLAGS="-q64"
		    LDFLAGS="-q64"
		else 
		    AC_MSG_WARN("64bit mode not supported with GCC on $system")
		fi
	    fi
	    ;;
	AIX-*)
	    if test "${TCL_THREADS}" = "1" -a "$using_gcc" = "no" ; then
		# AIX requires the _r compiler when gcc isn't being used
		if test "${CC}" != "cc_r" ; then
		    CC=${CC}_r
		fi
		AC_MSG_RESULT(Using $CC for compiling with threads)
	    fi
	    SHLIB_CFLAGS=""
	    SHLIB_LD="$fullSrcDir/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    TCL_NEEDS_EXP_FILE=1
	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'

	    # AIX v<=4.1 has some different flags than 4.2+
	    if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
		LIBOBJS="$LIBOBJS tclLoadAix.o"
		DL_LIBS="-lld"
	    fi

	    # On AIX <=v4 systems, libbsd.a has to be linked in to support
	    # non-blocking file IO.  This library has to be linked in after
	    # the MATH_LIBS or it breaks the pow() function.  The way to
	    # insure proper sequencing, is to add it to the tail of MATH_LIBS.
	    # This library also supplies gettimeofday.
	    #
	    # AIX does not have a timezone field in struct tm. When the AIX
	    # bsd library is used, the timezone global and the gettimeofday
	    # methods are to be avoided for timezone deduction instead, we
	    # deduce the timezone by comparing the localtime result on a
	    # known GMT value.

	    AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no)
	    if test $libbsd = yes; then
	    	MATH_LIBS="$MATH_LIBS -lbsd"
	    	AC_DEFINE(USE_DELTA_FOR_TZ)
	    fi
	    ;;
	BSD/OS-2.1*|BSD/OS-3*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="shlicc -r"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	BSD/OS-4.*)
	    SHLIB_CFLAGS="-export-dynamic -fPIC"
	    SHLIB_LD="cc -shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-export-dynamic"
	    LD_SEARCH_FLAGS=""
	    ;;
	*win32*|*WIN32*|CYGWIN_NT*|cygwin_nt*|*CYGWIN_98*|*CYGWIN_95*)
	    CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
	    CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
	    LDFLAGS_CONSOLE="-subsystem:console"
	    LDFLAGS_WINDOW="-subsystem:windows"
	    LDFLAGS_DEBUG="-debug:full -debugtype:cv"
	    LDFLAGS_OPTIMIZE="-release"
	    EXTRA_CFLAGS="-YX"
	    PATHTYPE=-w
	    STLIB_LD="lib -nologo"
	    SHLIB_LD="link -dll -nologo -incremental:no"
	    SHLIB_LD_LIBS="user32.lib advapi32.lib"
	    RC="rc"
	    ;;
	dgux*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*|HP-UX-*.11.*)
	    SHLIB_SUFFIX=".sl"
	    AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
	    if test "$tcl_ok" = yes; then
		SHLIB_CFLAGS="+z"
		SHLIB_LD="ld -b"
		SHLIB_LD_LIBS=""
		DL_OBJS="tclLoadShl.o"
		DL_LIBS="-ldld"
		LDFLAGS="-Wl,-E"
		LD_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
	    fi
	    ;;
	IRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
	    ;;
	IRIX-5.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    EXTRA_CFLAGS=""
	    LDFLAGS=""
	    ;;
	IRIX-6.*|IRIX64-6.5*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -n32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    if test "$using_gcc" = "yes" ; then
		EXTRA_CFLAGS="-mabi=n32"
		LDFLAGS="-mabi=n32"
	    else
		case $system in
		    IRIX-6.3)
			# Use to build 6.2 compatible binaries on 6.3.
			EXTRA_CFLAGS="-n32 -D_OLD_TERMIOS"
			;;
		    *)
			EXTRA_CFLAGS="-n32"
			;;
		esac
		LDFLAGS="-n32"
	    fi
	    ;;
	IRIX64-6.*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="ld -32 -shared -rdata_shared"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    ;;
	Linux*)
	    SHLIB_CFLAGS="-fPIC"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"

	    # egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings 
	    # when you inline the string and math operations.  Turn this off to
	    # get rid of the warnings.

	    CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"

	    if test "$have_dl" = yes; then
		SHLIB_LD="${CC} -shared"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS="-ldl"
		LDFLAGS="-rdynamic"
		LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    else
		AC_CHECK_HEADER(dld.h, [
		    SHLIB_LD="ld -shared"
		    DL_OBJS="tclLoadDld.o"
		    DL_LIBS="-ldld"
		    LDFLAGS=""
		    LD_SEARCH_FLAGS=""])
	    fi
	    if test "`uname -m`" = "alpha" ; then
		EXTRA_CFLAGS="-mieee"
	    fi
	    ;;
	MP-RAS-02*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	MP-RAS-*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS="-Wl,-Bexport"
	    LD_SEARCH_FLAGS=""
	    ;;
	NetBSD-*|FreeBSD-[[12]].*|OpenBSD-*)
	    # Not available on all versions:  check for include file.
	    AC_CHECK_HEADER(dlfcn.h, [
		SHLIB_CFLAGS="-fpic"
		SHLIB_LD="ld -Bshareable -x"
		SHLIB_LD_LIBS=""
		SHLIB_SUFFIX=".so"
		DL_OBJS="tclLoadDl.o"
		DL_LIBS=""
		LDFLAGS=""
		LD_SEARCH_FLAGS=""
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
	    ], [
		SHLIB_CFLAGS=""
		SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
		SHLIB_LD_LIBS='${LIBS}'
		SHLIB_SUFFIX=".a"
		DL_OBJS="tclLoadAout.o"
		DL_LIBS=""
		LDFLAGS=""
		LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
		SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    ])

	    # FreeBSD doesn't handle version numbers with dots.

	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	FreeBSD-*)
	    # FreeBSD 3.* and greater have ELF.
	    SHLIB_CFLAGS="-fpic"
	    SHLIB_LD="ld -Bshareable -x"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	NEXTSTEP-*)
	    SHLIB_CFLAGS=""
	    SHLIB_LD="cc -nostdlib -r"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadNext.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OS/390-*)
	    CFLAGS_OPTIMIZE=""      # Optimizer is buggy
	    AC_DEFINE(_OE_SOCKETS)  # needed in sys/socket.h
	    ;;      
	OSF1-1.0|OSF1-1.1|OSF1-1.2)
	    # OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
	    SHLIB_CFLAGS=""
	    # Hack: make package name same as library name
	    SHLIB_LD='ld -R -export $@:'
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadOSF.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-1.*)
	    # OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
	    SHLIB_CFLAGS="-fpic"
	    SHLIB_LD="ld -shared"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	OSF1-V*)
	    # Digital OSF/1
	    SHLIB_CFLAGS=""
	    SHLIB_LD='ld -shared -expect_unresolved "*"'
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
	    ;;
	RISCos-*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".a"
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    ;;
	SCO_SV-3.2*)
	    # Note, dlopen is available only on SCO 3.2.5 and greater.  However,
	    # this test works, since "uname -s" was non-standard in 3.2.4 and
	    # below.
	    SHLIB_CFLAGS="-Kpic -belf"
	    SHLIB_LD="ld -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS=""
	    LDFLAGS="-belf -Wl,-Bexport"
	    LD_SEARCH_FLAGS=""
	    ;;
	SINIX*5.4*)
	    SHLIB_CFLAGS="-K PIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS=""
	    ;;
	SunOS-4*)
	    SHLIB_CFLAGS="-PIC"
	    SHLIB_LD="ld"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'

	    # SunOS can't handle version numbers with dots in them in library
	    # specs, like -ltcl7.5, so use -ltcl75 instead.  Also, it
	    # requires an extra version number at the end of .so file names.
	    # So, the library has to have a name like libtcl75.so.1.0

	    SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
	    UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
	    TCL_LIB_VERSIONS_OK=nodots
	    ;;
	SunOS-5.[[0-6]]*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"

	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    LDFLAGS=""
	    LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    ;;
	SunOS-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="/usr/ccs/bin/ld -G -z text"
	    LDFLAGS=""
    
	    do64bit_ok=no
	    if test "$do64bit" = "yes" ; then
	    arch=`isainfo`
	    if test "$arch" = "sparcv9 sparc" ; then
		if test "$CC" != "gcc" -a `$CC -v 2>&1 | grep -c gcc` = "0" ; then
		do64bit_ok=yes
		EXTRA_CFLAGS="-xarch=v9"
		LDFLAGS="-xarch=v9"
		else 
		AC_MSG_WARN("64bit mode not supported using GCC on $system")
		fi
	    else
		AC_MSG_WARN("64bit mode only supported sparcv9 system")
	    fi
	    fi
	    
	    # Note: need the LIBS below, otherwise Tk won't find Tcl's
	    # symbols when dynamically loaded into tclsh.

	    SHLIB_LD_LIBS='${LIBS}'
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then
		LD_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
	    else
		LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
	    fi
	    ;;
	ULTRIX-4.*)
	    SHLIB_CFLAGS="-G 0"
	    SHLIB_SUFFIX=".a"
	    SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
	    SHLIB_LD_LIBS='${LIBS}'
	    DL_OBJS="tclLoadAout.o"
	    DL_LIBS=""
	    LDFLAGS="-Wl,-D,08000000"
	    LD_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
	    ;;
	UNIX_SV* | UnixWare-5*)
	    SHLIB_CFLAGS="-KPIC"
	    SHLIB_LD="cc -G"
	    SHLIB_LD_LIBS=""
	    SHLIB_SUFFIX=".so"
	    DL_OBJS="tclLoadDl.o"
	    DL_LIBS="-ldl"
	    # Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
	    # that don't grok the -Bexport option.  Test that it does.
	    hold_ldflags=$LDFLAGS
	    AC_MSG_CHECKING(for ld accepts -Bexport flag)
	    LDFLAGS="${LDFLAGS} -Wl,-Bexport"
	    AC_TRY_LINK(, [int i;], found=yes, found=no)
	    LDFLAGS=$hold_ldflags
	    AC_MSG_RESULT($found)
	    if test $found = yes; then
	    LDFLAGS="-Wl,-Bexport"
	    else
	    LDFLAGS=""
	    fi
	    LD_SEARCH_FLAGS=""
	    ;;
    esac

    if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
    AC_MSG_WARN("64bit support being disabled -- not supported on this platform")
    fi

    # Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic
    # Loading for Tcl -- What Became of It?".  Proc. 2nd Tcl/Tk Workshop,
    # New Orleans, LA, Computerized Processes Unlimited, 1994), then we need
    # to determine which of several header files defines the a.out file
    # format (a.out.h, sys/exec.h, or sys/exec_aout.h).  At present, we
    # support only a file format that is more or less version-7-compatible. 
    # In particular,
    #	- a.out files must begin with `struct exec'.
    #	- the N_TXTOFF on the `struct exec' must compute the seek address
    #	  of the text segment
    #	- The `struct exec' must contain a_magic, a_text, a_data, a_bss
    #	  and a_entry fields.
    # The following compilation should succeed if and only if either sys/exec.h
    # or a.out.h is usable for the purpose.
    #
    # Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
    # `struct exec' includes a second header that contains information that
    # duplicates the v7 fields that are needed.

    if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
	AC_MSG_CHECKING(sys/exec.h)
	AC_TRY_COMPILE([#include <sys/exec.h>],[
	    struct exec foo;
	    unsigned long seek;
	    int flag;
#if defined(__mips) || defined(mips)
	    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
	    seek = N_TXTOFF (foo);
#endif
	    flag = (foo.a_magic == OMAGIC);
	    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
    ], tcl_ok=usable, tcl_ok=unusable)
	AC_MSG_RESULT($tcl_ok)
	if test $tcl_ok = usable; then
	    AC_DEFINE(USE_SYS_EXEC_H)
	else
	    AC_MSG_CHECKING(a.out.h)
	    AC_TRY_COMPILE([#include <a.out.h>],[
		struct exec foo;
		unsigned long seek;
		int flag;
#if defined(__mips) || defined(mips)
		seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		seek = N_TXTOFF (foo);
#endif
		flag = (foo.a_magic == OMAGIC);
		return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
	    ], tcl_ok=usable, tcl_ok=unusable)
	    AC_MSG_RESULT($tcl_ok)
	    if test $tcl_ok = usable; then
		AC_DEFINE(USE_A_OUT_H)
	    else
		AC_MSG_CHECKING(sys/exec_aout.h)
		AC_TRY_COMPILE([#include <sys/exec_aout.h>],[
		    struct exec foo;
		    unsigned long seek;
		    int flag;
#if defined(__mips) || defined(mips)
		    seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
		    seek = N_TXTOFF (foo);
#endif
		    flag = (foo.a_midmag == OMAGIC);
		    return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
		], tcl_ok=usable, tcl_ok=unusable)
		AC_MSG_RESULT($tcl_ok)
		if test $tcl_ok = usable; then
		    AC_DEFINE(USE_SYS_EXEC_AOUT_H)
		else
		    DL_OBJS=""
		fi
	    fi
	fi
    fi

    # Step 5: disable dynamic loading if requested via a command-line switch.

    AC_ARG_ENABLE(load, [  --disable-load          disallow dynamic loading and "load" command],
	[tcl_ok=$enableval], [tcl_ok=yes])
    if test "$tcl_ok" = "no"; then
	DL_OBJS=""
    fi

    if test "x$DL_OBJS" != "x" ; then
	BUILD_DLTEST="\$(DLTEST_TARGETS)"
    else
	echo "Can't figure out how to do dynamic loading or shared libraries"
	echo "on this system."
	SHLIB_CFLAGS=""
	SHLIB_LD=""
	SHLIB_SUFFIX=""
	DL_OBJS="tclLoadNone.o"
	DL_LIBS=""
	LDFLAGS=""
	LD_SEARCH_FLAGS=""
	BUILD_DLTEST=""
    fi

    # If we're running gcc, then change the C flags for compiling shared
    # libraries to the right flags for gcc, instead of those for the
    # standard manufacturer compiler.

    if test "$DL_OBJS" != "tclLoadNone.o" ; then
	if test "$CC" = "gcc" -o `$CC -v 2>&1 | grep -c gcc` != "0" ; then
	    case $system in
		AIX-*)
		    ;;
		BSD/OS*)
		    ;;
		IRIX*)
		    ;;
		NetBSD-*|FreeBSD-*|OpenBSD-*)
		    ;;
		RISCos-*)
		    ;;
		ULTRIX-4.*)
		    ;;
		*)
		    SHLIB_CFLAGS="-fPIC"
		    ;;
	    esac
	fi
    fi

    if test "$SHARED_LIB_SUFFIX" = "" ; then
	SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
    fi
    if test "$UNSHARED_LIB_SUFFIX" = "" ; then
	UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
    fi

    AC_SUBST(STLIB_LD)
    AC_SUBST(SHLIB_LD)
    AC_SUBST(SHLIB_CFLAGS)
    AC_SUBST(SHLIB_LDFLAGS)
    AC_SUBST(DL_LIBS)
    AC_SUBST(CFLAGS_DEBUG)
    AC_SUBST(CFLAGS_OPTIMIZE)
    AC_SUBST(LDFLAGS_DEBUG)
    AC_SUBST(LDFLAGS_OPTIMIZE)
])

#--------------------------------------------------------------------
# SC_SERIAL_PORT
#
#	Determine which interface to use to talk to the serial port.
#	Note that #include lines must begin in leftmost column for
#	some compilers to recognize them as preprocessor directives.
#
# Arguments:
#	none
#	
# Results:
#
#	Defines only one of the following vars:
#		USE_TERMIOS
#		USE_TERMIO
#		USE_SGTTY
#
#--------------------------------------------------------------------

AC_DEFUN(SC_SERIAL_PORT, [
    AC_MSG_CHECKING([termios vs. termio vs. sgtty])

    AC_TRY_RUN([
#include <termios.h>

main()
{
    struct termios t;
    if (tcgetattr(0, &t) == 0) {
	cfsetospeed(&t, 0);
	t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}], tk_ok=termios, tk_ok=no, tk_ok=no)

    if test $tk_ok = termios; then
	AC_DEFINE(USE_TERMIOS)
    else
	AC_TRY_RUN([
#include <termio.h>

main()
{
    struct termio t;
    if (ioctl(0, TCGETA, &t) == 0) {
	t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
    }], tk_ok=termio, tk_ok=no, tk_ok=no)

    if test $tk_ok = termio; then
	AC_DEFINE(USE_TERMIO)
    else
	AC_TRY_RUN([
#include <sgtty.h>

main()
{
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}], tk_ok=sgtty, tk_ok=none, tk_ok=none)

    if test $tk_ok = sgtty; then
	AC_DEFINE(USE_SGTTY)
    else
	AC_TRY_RUN([
#include <termios.h>
#include <errno.h>

main()
{
    struct termios t;
    if (tcgetattr(0, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	cfsetospeed(&t, 0);
	t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
}], tk_ok=termios, tk_ok=no, tk_ok=no)

    if test $tk_ok = termios; then
	AC_DEFINE(USE_TERMIOS)
    else
	AC_TRY_RUN([
#include <termio.h>
#include <errno.h>

main()
{
    struct termio t;
    if (ioctl(0, TCGETA, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
	return 0;
    }
    return 1;
    }], tk_ok=termio, tk_ok=no, tk_ok=no)

    if test $tk_ok = termio; then
	AC_DEFINE(USE_TERMIO)
    else
	AC_TRY_RUN([
#include <sgtty.h>
#include <errno.h>

main()
{
    struct sgttyb t;
    if (ioctl(0, TIOCGETP, &t) == 0
	|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
	t.sg_ospeed = 0;
	t.sg_flags |= ODDP | EVENP | RAW;
	return 0;
    }
    return 1;
}], tk_ok=sgtty, tk_ok=none, tk_ok=none)

    if test $tk_ok = sgtty; then
	AC_DEFINE(USE_SGTTY)
    fi
    fi
    fi
    fi
    fi
    fi
    AC_MSG_RESULT($tk_ok)
])

#--------------------------------------------------------------------
# SC_MISSING_POSIX_HEADERS
#
#	Supply substitutes for missing POSIX header files.  Special
#	notes:
#	    - stdlib.h doesn't define strtol, strtoul, or
#	      strtod insome versions of SunOS
#	    - some versions of string.h don't declare procedures such
#	      as strstr
#
# Arguments:
#	none
#	
# Results:
#
#	Defines some of the following vars:
#		NO_DIRENT_H
#		NO_ERRNO_H
#		NO_VALUES_H
#		NO_LIMITS_H
#		NO_STDLIB_H
#		NO_STRING_H
#		NO_SYS_WAIT_H
#		NO_DLFCN_H
#		HAVE_UNISTD_H
#		HAVE_SYS_PARAM_H
#
#		HAVE_STRING_H ?
#
#--------------------------------------------------------------------

AC_DEFUN(SC_MISSING_POSIX_HEADERS, [

    AC_MSG_CHECKING(dirent.h)
    AC_TRY_LINK([#include <sys/types.h>
#include <dirent.h>], [
#ifndef _POSIX_SOURCE
#   ifdef __Lynx__
	/*
	 * Generate compilation error to make the test fail:  Lynx headers
	 * are only valid if really in the POSIX environment.
	 */

	missing_procedure();
#   endif
#endif
DIR *d;
struct dirent *entryPtr;
char *p;
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
], tcl_ok=yes, tcl_ok=no)

    if test $tcl_ok = no; then
	AC_DEFINE(NO_DIRENT_H)
    fi

    AC_MSG_RESULT($tcl_ok)
    AC_CHECK_HEADER(errno.h, , AC_DEFINE(NO_ERRNO_H))
    AC_CHECK_HEADER(float.h, , AC_DEFINE(NO_FLOAT_H))
    AC_CHECK_HEADER(values.h, , AC_DEFINE(NO_VALUES_H))
    AC_CHECK_HEADER(limits.h, , AC_DEFINE(NO_LIMITS_H))
    AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
    AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
    AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
    AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0)
    if test $tcl_ok = 0; then
	AC_DEFINE(NO_STDLIB_H)
    fi
    AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0)
    AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0)
    AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0)

    # See also memmove check below for a place where NO_STRING_H can be
    # set and why.

    if test $tcl_ok = 0; then
	AC_DEFINE(NO_STRING_H)
    fi

    AC_CHECK_HEADER(sys/wait.h, , AC_DEFINE(NO_SYS_WAIT_H))
    AC_CHECK_HEADER(dlfcn.h, , AC_DEFINE(NO_DLFCN_H))

    # OS/390 lacks sys/param.h (and doesn't need it, by chance).

    AC_HAVE_HEADERS(unistd.h sys/param.h)

])

#--------------------------------------------------------------------
# SC_PATH_X
#
#	Locate the X11 header files and the X11 library archive.  Try
#	the ac_path_x macro first, but if it doesn't find the X stuff
#	(e.g. because there's no xmkmf program) then check through
#	a list of possible directories.  Under some conditions the
#	autoconf macro will return an include directory that contains
#	no include files, so double-check its result just to be safe.
#
# Arguments:
#	none
#	
# Results:
#
#	Sets the the following vars:
#		XINCLUDES
#		XLIBSW
#
#--------------------------------------------------------------------

AC_DEFUN(SC_PATH_X, [
    AC_PATH_X
    not_really_there=""
    if test "$no_x" = ""; then
	if test "$x_includes" = ""; then
	    AC_TRY_CPP([#include <X11/XIntrinsic.h>], , not_really_there="yes")
	else
	    if test ! -r $x_includes/X11/Intrinsic.h; then
		not_really_there="yes"
	    fi
	fi
    fi
    if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then
	AC_MSG_CHECKING(for X11 header files)
	XINCLUDES="# no special path needed"
	AC_TRY_CPP([#include <X11/Intrinsic.h>], , XINCLUDES="nope")
	if test "$XINCLUDES" = nope; then
	    dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include"
	    for i in $dirs ; do
		if test -r $i/X11/Intrinsic.h; then
		    AC_MSG_RESULT($i)
		    XINCLUDES=" -I$i"
		    break
		fi
	    done
	fi
    else
	if test "$x_includes" != ""; then
	    XINCLUDES=-I$x_includes
	else
	    XINCLUDES="# no special path needed"
	fi
    fi
    if test "$XINCLUDES" = nope; then
	AC_MSG_RESULT(couldn't find any!)
	XINCLUDES="# no include files found"
    fi

    if test "$no_x" = yes; then
	AC_MSG_CHECKING(for X11 libraries)
	XLIBSW=nope
	dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib"
	for i in $dirs ; do
	    if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl; then
		AC_MSG_RESULT($i)
		XLIBSW="-L$i -lX11"
		x_libraries="$i"
		break
	    fi
	done
    else
	if test "$x_libraries" = ""; then
	    XLIBSW=-lX11
	else
	    XLIBSW="-L$x_libraries -lX11"
	fi
    fi
    if test "$XLIBSW" = nope ; then
	AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow)
    fi
    if test "$XLIBSW" = nope ; then
	AC_MSG_RESULT(couldn't find any!  Using -lX11.)
	XLIBSW=-lX11
    fi
])
#--------------------------------------------------------------------
# SC_BLOCKING_STYLE
#
#	The statements below check for systems where POSIX-style
#	non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented. 
#	On these systems (mostly older ones), use the old BSD-style
#	FIONBIO approach instead.
#
# Arguments:
#	none
#	
# Results:
#
#	Defines some of the following vars:
#		HAVE_SYS_IOCTL_H
#		HAVE_SYS_FILIO_H
#		USE_FIONBIO
#		O_NONBLOCK
#
#--------------------------------------------------------------------

AC_DEFUN(SC_BLOCKING_STYLE, [
    AC_CHECK_HEADERS(sys/ioctl.h)
    AC_CHECK_HEADERS(sys/filio.h)
    AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O])
    if test -f /usr/lib/NextStep/software_version; then
	system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
    else
	system=`uname -s`-`uname -r`
	if test "$?" -ne 0 ; then
	    system=unknown
	else
	    # Special check for weird MP-RAS system (uname returns weird
	    # results, and the version is kept in special file).
	
	    if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
		system=MP-RAS-`awk '{print $3}' /etc/.relid'`
	    fi
	    if test "`uname -s`" = "AIX" ; then
		system=AIX-`uname -v`.`uname -r`
	    fi
	fi
    fi
    case $system in
	# There used to be code here to use FIONBIO under AIX.  However, it
	# was reported that FIONBIO doesn't work under AIX 3.2.5.  Since
	# using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO
	# code (JO, 5/31/97).

	OSF*)
	    AC_DEFINE(USE_FIONBIO)
	    AC_MSG_RESULT(FIONBIO)
	    ;;
	SunOS-4*)
	    AC_DEFINE(USE_FIONBIO)
	    AC_MSG_RESULT(FIONBIO)
	    ;;
	ULTRIX-4.*)
	    AC_DEFINE(USE_FIONBIO)
	    AC_MSG_RESULT(FIONBIO)
	    ;;
	*)
	    AC_MSG_RESULT(O_NONBLOCK)
	    ;;
    esac
])

#--------------------------------------------------------------------
# SC_HAVE_VFORK
#
#	Check to see whether the system provides a vfork kernel call.
#	If not, then use fork instead.  Also, check for a problem with
#	vforks and signals that can cause core dumps if a vforked child
#	resets a signal handler.  If the problem exists, then use fork
#	instead of vfork.
#
# Arguments:
#	none
#	
# Results:
#
#	Defines some of the following vars:
#		vfork (=fork)
#
#--------------------------------------------------------------------

AC_DEFUN(SC_HAVE_VFORK, [
    AC_TYPE_SIGNAL()
    AC_CHECK_FUNC(vfork, tcl_ok=1, tcl_ok=0)
    if test "$tcl_ok" = 1; then
	AC_MSG_CHECKING([vfork/signal bug]);
	AC_TRY_RUN([
#include <stdio.h>
#include <signal.h>
#include <sys/wait.h>
int gotSignal = 0;
sigProc(sig)
    int sig;
{
    gotSignal = 1;
}
main()
{
    int pid, sts;
    (void) signal(SIGCHLD, sigProc);
    pid = vfork();
    if (pid <  0) {
	exit(1);
    } else if (pid == 0) {
	(void) signal(SIGCHLD, SIG_DFL);
	_exit(0);
    } else {
	(void) wait(&sts);
    }
    exit((gotSignal) ? 0 : 1);
}], tcl_ok=1, tcl_ok=0, tcl_ok=0)

	if test "$tcl_ok" = 1; then
	    AC_MSG_RESULT(ok)
	else
	    AC_MSG_RESULT([buggy, using fork instead])
	fi
    fi
    rm -f core
    if test "$tcl_ok" = 0; then
	AC_DEFINE(vfork, fork)
    fi
])

#--------------------------------------------------------------------
# SC_TIME_HANLDER
#
#	Checks how the system deals with time.h, what time structures
#	are used on the system, and what fields the structures have.
#
# Arguments:
#	none
#	
# Results:
#
#	Defines some of the following vars:
#		USE_DELTA_FOR_TZ
#		HAVE_TM_GMTOFF
#		HAVE_TM_TZADJ
#		HAVE_TIMEZONE_VAR
#
#--------------------------------------------------------------------

AC_DEFUN(SC_TIME_HANDLER, [
    AC_CHECK_HEADERS(sys/time.h)
    AC_HEADER_TIME
    AC_STRUCT_TIMEZONE

    AC_MSG_CHECKING([tm_tzadj in struct tm])
    AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;],
	    [AC_DEFINE(HAVE_TM_TZADJ)
	    AC_MSG_RESULT(yes)],
	    AC_MSG_RESULT(no))

    AC_MSG_CHECKING([tm_gmtoff in struct tm])
    AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;],
	    [AC_DEFINE(HAVE_TM_GMTOFF)
	    AC_MSG_RESULT(yes)],
	    AC_MSG_RESULT(no))

    #
    # Its important to include time.h in this check, as some systems
    # (like convex) have timezone functions, etc.
    #
    have_timezone=no
    AC_MSG_CHECKING([long timezone variable])
    AC_TRY_COMPILE([#include <time.h>],
	    [extern long timezone;
	    timezone += 1;
	    exit (0);],
	    [have_timezone=yes
	    AC_DEFINE(HAVE_TIMEZONE_VAR)
	    AC_MSG_RESULT(yes)],
	    AC_MSG_RESULT(no))

    #
    # On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
    #
    if test "$have_timezone" = no; then
    AC_MSG_CHECKING([time_t timezone variable])
    AC_TRY_COMPILE([#include <time.h>],
	    [extern time_t timezone;
	    timezone += 1;
	    exit (0);],
	    [AC_DEFINE(HAVE_TIMEZONE_VAR)
	    AC_MSG_RESULT(yes)],
	    AC_MSG_RESULT(no))
    fi

    #
    # AIX does not have a timezone field in struct tm. When the AIX bsd
    # library is used, the timezone global and the gettimeofday methods are
    # to be avoided for timezone deduction instead, we deduce the timezone
    # by comparing the localtime result on a known GMT value.
    #

    if test "`uname -s`" = "AIX" ; then
	AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes)
	if test $libbsd = yes; then
	    AC_DEFINE(USE_DELTA_FOR_TZ)
	fi
    fi
])

#--------------------------------------------------------------------
# SC_BUGGY_STRTOD
#
#	Under Solaris 2.4, strtod returns the wrong value for the
#	terminating character under some conditions.  Check for this
#	and if the problem exists use a substitute procedure
#	"fixstrtod" (provided by Tcl) that corrects the error.
#
# Arguments:
#	none
#	
# Results:
#
#	Might defines some of the following vars:
#		strtod (=fixstrtod)
#
#--------------------------------------------------------------------

AC_DEFUN(SC_BUGGY_STRTOD, [
    AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
    if test "$tcl_strtod" = 1; then
	AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs])
	AC_TRY_RUN([
	    extern double strtod();
	    int main()
	    {
		char *string = "NaN", *spaceString = " ";
		char *term;
		double value;
		value = strtod(string, &term);
		if ((term != string) && (term[-1] == 0)) {
		    exit(1);
		}
		value = strtod(spaceString, &term);
		if (term == (spaceString+1)) {
		    exit(1);
		}
		exit(0);
	    }], tcl_ok=1, tcl_ok=0, tcl_ok=0)
	if test "$tcl_ok" = 1; then
	    AC_MSG_RESULT(ok)
	else
	    AC_MSG_RESULT(buggy)
	    LIBOBJS="$LIBOBJS fixstrtod.o"
	    AC_DEFINE(strtod, fixstrtod)
	fi
    fi
])

#--------------------------------------------------------------------
# SC_TCL_LINK_LIBS
#
#	Search for the libraries needed to link the Tcl shell.
#	Things like the math library (-lm) and socket stuff (-lsocket vs.
#	-lnsl) are dealt with here.
#
# Arguments:
#	Requires the following vars to be set in the Makefile:
#		DL_LIBS
#		LIBS
#		MATH_LIBS
#	
# Results:
#
#	Subst's the following var:
#		TCL_LIBS
#		MATH_LIBS
#
#	Might append to the following vars:
#		LIBS
#
#	Might define the following vars:
#		HAVE_NET_ERRNO_H
#
#--------------------------------------------------------------------

AC_DEFUN(SC_TCL_LINK_LIBS, [
    #--------------------------------------------------------------------
    # On a few very rare systems, all of the libm.a stuff is
    # already in libc.a.  Set compiler flags accordingly.
    # Also, Linux requires the "ieee" library for math to work
    # right (and it must appear before "-lm").
    #--------------------------------------------------------------------

    AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm")
    AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"])

    #--------------------------------------------------------------------
    # On AIX systems, libbsd.a has to be linked in to support
    # non-blocking file IO.  This library has to be linked in after
    # the MATH_LIBS or it breaks the pow() function.  The way to
    # insure proper sequencing, is to add it to the tail of MATH_LIBS.
    # This library also supplies gettimeofday.
    #--------------------------------------------------------------------

    libbsd=no
    if test "`uname -s`" = "AIX" ; then
	AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes)
	if test $libbsd = yes; then
	    MATH_LIBS="$MATH_LIBS -lbsd"
	fi
    fi


    #--------------------------------------------------------------------
    # Interactive UNIX requires -linet instead of -lsocket, plus it
    # needs net/errno.h to define the socket-related error codes.
    #--------------------------------------------------------------------

    AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"])
    AC_CHECK_HEADER(net/errno.h, AC_DEFINE(HAVE_NET_ERRNO_H))

    #--------------------------------------------------------------------
    #	Check for the existence of the -lsocket and -lnsl libraries.
    #	The order here is important, so that they end up in the right
    #	order in the command line generated by make.  Here are some
    #	special considerations:
    #	1. Use "connect" and "accept" to check for -lsocket, and
    #	   "gethostbyname" to check for -lnsl.
    #	2. Use each function name only once:  can't redo a check because
    #	   autoconf caches the results of the last check and won't redo it.
    #	3. Use -lnsl and -lsocket only if they supply procedures that
    #	   aren't already present in the normal libraries.  This is because
    #	   IRIX 5.2 has libraries, but they aren't needed and they're
    #	   bogus:  they goof up name resolution if used.
    #	4. On some SVR4 systems, can't use -lsocket without -lnsl too.
    #	   To get around this problem, check for both libraries together
    #	   if -lsocket doesn't work by itself.
    #--------------------------------------------------------------------

    tcl_checkBoth=0
    AC_CHECK_FUNC(connect, tcl_checkSocket=0, tcl_checkSocket=1)
    if test "$tcl_checkSocket" = 1; then
	AC_CHECK_LIB(socket, main, LIBS="$LIBS -lsocket", tcl_checkBoth=1)
    fi
    if test "$tcl_checkBoth" = 1; then
	tk_oldLibs=$LIBS
	LIBS="$LIBS -lsocket -lnsl"
	AC_CHECK_FUNC(accept, tcl_checkNsl=0, [LIBS=$tk_oldLibs])
    fi
    AC_CHECK_FUNC(gethostbyname, , AC_CHECK_LIB(nsl, main,
	    [LIBS="$LIBS -lnsl"]))
    
    # Don't perform the eval of the libraries here because DL_LIBS
    # won't be set until we call SC_CONFIG_CFLAGS

    TCL_LIBS='${DL_LIBS} ${LIBS} ${MATH_LIBS}'
    AC_SUBST(TCL_LIBS)
    AC_SUBST(MATH_LIBS)
])

#------------------------------------------------------------------------
# SC_MAKE_LIB --
#
#	Generate a line that can be used to build a shared/unshared library
#	in a platform independent manner.
#
# Arguments:
#	none
#
#	Requires:
#
# Results:
#
#	Defines the following vars:
#		MAKE_LIB	Makefile rule for building a library
#		MAKE_SHARED_LIB	Makefile rule for building a shared library
#		MAKE_UNSHARED_LIB	Makefile rule for building a static
#				library
#------------------------------------------------------------------------

AC_DEFUN(SC_MAKE_LIB, [
    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    if test "${CC-cc}" = "cl"; then
		MAKE_STATIC_LIB="\${STLIB_LD} -out:\[$]@ \$(${PACKAGE}_LIB_OBJECTS) "
		MAKE_SHARED_LIB="\${SHLIB_LD} \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS} \$(LDFLAGS) -out:\[$]@ \$(${PACKAGE}_LIB_OBJECTS) "
	    fi
	    ;;
	*)
	    MAKE_STATIC_LIB="\${STLIB_LD} \[$]@ \$(${PACKAGE}_LIB_OBJECTS)"
	    MAKE_SHARED_LIB="\${SHLIB_LD} -o \[$]@ \$(${PACKAGE}_LIB_OBJECTS) \${SHLIB_LDFLAGS} \${SHLIB_LD_LIBS}"
	    ;;
    esac

    if test "${SHARED_BUILD}" = "1" ; then
	MAKE_LIB=${MAKE_SHARED_LIB}
    else
	MAKE_LIB=${MAKE_STATIC_LIB}
    fi

    AC_SUBST(MAKE_LIB)
    AC_SUBST(MAKE_SHARED_LIB)
    AC_SUBST(MAKE_STATIC_LIB)
])

#------------------------------------------------------------------------
# SC_LIB_SPEC --
#
#	Compute the name of an existing object library located in libdir
#	from the given base name and produce the appropriate linker flags.
#
# Arguments:
#	basename	The base name of the library without version
#			numbers, extensions, or "lib" prefixes.
#	extra_dir	Extra directory in which to search for the
#			library.  This location is used first, then
#			$prefix/$exec-prefix, then some defaults.
#
# Requires:
#	CYGPATH		command used to generate native style paths
#
# Results:
#
#	Defines the following vars:
#		${basename}_LIB_NAME	The computed library name.
#		${basename}_LIB_SPEC	The computed linker flags.
#------------------------------------------------------------------------

AC_DEFUN(SC_LIB_SPEC, [
    AC_MSG_CHECKING(for $1 library)

    # Look in exec-prefix and prefix for the library.  If neither of
    # these were specified, look in libdir.  It doesn't matter if libdir
    # wasn't specified since a search in the unspecified directory will
    # fail (NONE/lib)

    if test x"${exec_prefix}" != x"NONE" ; then
	sc_lib_name_dir="${exec_prefix}/lib"
    elif test x"${prefix}" != x"NONE" ; then
	sc_lib_name_dir="${prefix}/lib"
    else
	eval "sc_lib_name_dir=${libdir}"
    fi

    if test x"$2" != x ; then
	sc_extra_lib_dir=$2
    else
	sc_extra_lib_dir=NONE
    fi

    for i in \
	    `ls -dr ${sc_extra_lib_dir}/$1[[0-9]]*.lib 2>/dev/null ` \
	    `ls -dr ${sc_extra_lib_dir}/$1.lib 2>/dev/null ` \
	    `ls -dr ${sc_extra_lib_dir}/lib$1[[0-9]]* 2>/dev/null ` \
	    `ls -dr ${sc_extra_lib_dir}/lib$1.* 2>/dev/null ` \
	    `ls -dr ${sc_lib_name_dir}/$1[[0-9]]*.lib 2>/dev/null ` \
	    `ls -dr ${sc_lib_name_dir}/$1.lib 2>/dev/null ` \
	    `ls -dr ${sc_lib_name_dir}/lib$1[[0-9]]* 2>/dev/null ` \
	    `ls -dr ${sc_lib_name_dir}/lib$1.* 2>/dev/null ` \
	    `ls -dr /usr/lib/$1[[0-9]]*.lib 2>/dev/null ` \
	    `ls -dr /usr/lib/$1.lib 2>/dev/null ` \
	    `ls -dr /usr/lib/lib$1[[0-9]]* 2>/dev/null ` \
	    `ls -dr /usr/lib/lib$1.* 2>/dev/null ` \
	    `ls -dr /usr/local/lib/$1[[0-9]]*.lib 2>/dev/null ` \
	    `ls -dr /usr/local/lib/$1.lib 2>/dev/null ` \
	    `ls -dr /usr/local/lib/lib$1[[0-9]]* 2>/dev/null ` \
	    `ls -dr /usr/local/lib/lib$1.* 2>/dev/null ` ; do
	if test -f "$i" ; then

	    sc_lib_name_dir=`dirname $i`
	    $1_LIB_NAME=`basename $i`
	    $1_LIB_PATH_NAME=$i
	    break
	fi
    done

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    $1_LIB_SPEC=\"`${CYGPATH} ${$1_LIB_PATH_NAME}`\"
	    ;;
	*)
	    # Strip off the leading "lib" and trailing ".a" or ".so"

	    sc_lib_name_lib=`echo ${$1_LIB_NAME}|sed -e 's/^lib//' -e 's/\.[[^.]]*$//' -e 's/\.so.*//'`
	    $1_LIB_SPEC="-L${sc_lib_name_dir} -l${sc_lib_name_lib}"
	    ;;
    esac

    if test "x${$1_LIB_NAME}" = x ; then
	AC_MSG_ERROR(not found)
    else
	AC_MSG_RESULT(${$1_LIB_SPEC})
    fi
])

#------------------------------------------------------------------------
# SC_PRIVATE_TCL_HEADERS --
#
#	Locate the private Tcl include files
#
# Arguments:
#
#	Requires:
#		TCL_SRC_DIR	Assumes that SC_LOAD_TCLCONFIG has
#				 already been called.
#
# Results:
#
#	Substs the following vars:
#		TCL_TOP_DIR_NATIVE
#		TCL_GENERIC_DIR_NATIVE
#		TCL_UNIX_DIR_NATIVE
#		TCL_WIN_DIR_NATIVE
#		TCL_BMAP_DIR_NATIVE
#		TCL_TOOL_DIR_NATIVE
#		TCL_PLATFORM_DIR_NATIVE
#		TCL_BIN_DIR_NATIVE
#		TCL_INCLUDES
#------------------------------------------------------------------------

AC_DEFUN(SC_PRIVATE_TCL_HEADERS, [
    AC_MSG_CHECKING(for Tcl private include files)

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    TCL_TOP_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}`\"
	    TCL_GENERIC_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/generic`\"
	    TCL_UNIX_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/unix`\"
	    TCL_WIN_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/win`\"
	    TCL_BMAP_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/bitmaps`\"
	    TCL_TOOL_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/tools`\"
	    TCL_COMPAT_DIR_NATIVE=\"`${CYGPATH} ${TCL_SRC_DIR}/compat`\"
	    TCL_PLATFORM_DIR_NATIVE=${TCL_WIN_DIR_NATIVE}
	;;
	*)
	    TCL_TOP_DIR_NATIVE='$(TCL_SRC_DIR)'
	    TCL_GENERIC_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/generic'
	    TCL_UNIX_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/unix'
	    TCL_WIN_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/win'
	    TCL_BMAP_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/bitmaps'
	    TCL_TOOL_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/tools'
	    TCL_COMPAT_DIR_NATIVE='$(TCL_TOP_DIR_NATIVE)/compat'
	    TCL_PLATFORM_DIR_NATIVE=${TCL_UNIX_DIR_NATIVE}
	;;
    esac

    AC_SUBST(TCL_TOP_DIR_NATIVE)
    AC_SUBST(TCL_GENERIC_DIR_NATIVE)
    AC_SUBST(TCL_UNIX_DIR_NATIVE)
    AC_SUBST(TCL_WIN_DIR_NATIVE)
    AC_SUBST(TCL_BMAP_DIR_NATIVE)
    AC_SUBST(TCL_TOOL_DIR_NATIVE)
    AC_SUBST(TCL_PLATFORM_DIR_NATIVE)

    TCL_INCLUDES="-I${TCL_GENERIC_DIR_NATIVE} -I${TCL_PLATFORM_DIR_NATIVE}"
    AC_SUBST(TCL_INCLUDES)
    AC_MSG_RESULT(Using srcdir found in tclConfig.sh)
])

#------------------------------------------------------------------------
# SC_PUBLIC_TCL_HEADERS --
#
#	Locate the installed public Tcl header files
#
# Arguments:
#	None.
#
# Requires:
#	CYGPATH must be set
#
# Results:
#
#	Adds a --with-tclinclude switch to configure.
#	Result is cached.
#
#	Substs the following vars:
#		TCL_INCLUDES
#------------------------------------------------------------------------

AC_DEFUN(SC_PUBLIC_TCL_HEADERS, [
    AC_MSG_CHECKING(for Tcl public headers)

    AC_ARG_WITH(tclinclude, [ --with-tclinclude      directory containing the public Tcl header files.], with_tclinclude=${withval})

    if test x"${with_tclinclude}" != x ; then
	if test -f "${with_tclinclude}/tcl.h" ; then
	    ac_cv_c_tclh=${with_tclinclude}
	else
	    AC_MSG_ERROR([${with_tclinclude} directory does not contain Tcl public header file tcl.h])
	fi
    else
	AC_CACHE_VAL(ac_cv_c_tclh, [
	    # Use the value from --with-tclinclude, if it was given

	    if test x"${with_tclinclude}" != x ; then
		ac_cv_c_tclh=${with_tclinclude}
	    else
		# Check in the includedir, if --prefix was specified

		eval "temp_includedir=${includedir}"
		for i in \
			`ls -d ${TCL_PREFIX}/include 2>/dev/null` \
			`ls -d ${temp_includedir} 2>/dev/null` \
			`ls -d ${TCL_BIN_DIR}/../include 2>/dev/null` \
			/usr/local/include /usr/include ; do
		    if test -f "$i/tcl.h" ; then
			ac_cv_c_tclh=$i
			break
		    fi
		done
	    fi
	])
    fi

    # Print a message based on how we determined the include path

    if test x"${ac_cv_c_tclh}" = x ; then
	AC_MSG_ERROR(tcl.h not found.  Please specify its location with --with-tclinclude)
    else
	AC_MSG_RESULT(${ac_cv_c_tclh})
    fi

    # Convert to a native path and substitute into the output files.

    INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tclh}`

    TCL_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\"

    AC_SUBST(TCL_INCLUDES)
])

#------------------------------------------------------------------------
# SC_PRIVATE_TK_HEADERS --
#
#	Locate the private Tk include files
#
# Arguments:
#
#	Requires:
#		TK_SRC_DIR	Assumes that SC_LOAD_TKCONFIG has
#				 already been called.
#
# Results:
#
#	Substs the following vars:
#		TK_INCLUDES
#------------------------------------------------------------------------

AC_DEFUN(SC_PRIVATE_TK_HEADERS, [
    AC_MSG_CHECKING(for Tk private include files)

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    TK_TOP_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}`\"
	    TK_UNIX_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/unix`\"
	    TK_WIN_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/win`\"
	    TK_GENERIC_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/generic`\"
	    TK_XLIB_DIR_NATIVE=\"`${CYGPATH} ${TK_SRC_DIR}/xlib`\"
	    TK_PLATFORM_DIR_NATIVE=${TK_WIN_DIR_NATIVE}

	    TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE} -I${TK_XLIB_DIR_NATIVE}"
	;;
	*)
	    TK_TOP_DIR_NATIVE='$(TK_SRC_DIR)'
	    TK_GENERIC_DIR_NATIVE='$(TK_TOP_DIR_NATIVE)/generic'
	    TK_UNIX_DIR_NATIVE='$(TK_TOP_DIR_NATIVE)/unix'
	    TK_WIN_DIR_NATIVE='$(TK_TOP_DIR_NATIVE)/win'
	    TK_PLATFORM_DIR_NATIVE=${TK_UNIX_DIR_NATIVE}

	    TK_INCLUDES="-I${TK_GENERIC_DIR_NATIVE} -I${TK_PLATFORM_DIR_NATIVE}"
	;;
    esac

    AC_SUBST(TK_TOP_DIR_NATIVE)
    AC_SUBST(TK_UNIX_DIR_NATIVE)
    AC_SUBST(TK_WIN_DIR_NATIVE)
    AC_SUBST(TK_GENERIC_DIR_NATIVE)
    AC_SUBST(TK_XLIB_DIR_NATIVE)
    AC_SUBST(TK_PLATFORM_DIR_NATIVE)

    AC_SUBST(TK_INCLUDES)
    AC_MSG_RESULT(Using srcdir found in tkConfig.sh)
])

#------------------------------------------------------------------------
# SC_PUBLIC_TK_HEADERS --
#
#	Locate the installed public Tk header files
#
# Arguments:
#	None.
#
# Requires:
#	CYGPATH must be set
#
# Results:
#
#	Adds a --with-tkinclude switch to configure.
#	Result is cached.
#
#	Substs the following vars:
#		TK_INCLUDES
#------------------------------------------------------------------------

AC_DEFUN(SC_PUBLIC_TK_HEADERS, [
    AC_MSG_CHECKING(for Tk public headers)

    AC_ARG_WITH(tkinclude, [ --with-tkinclude      directory containing the public Tk header files.], with_tkinclude=${withval})

    if test x"${with_tkinclude}" != x ; then
	if test -f "${with_tkinclude}/tk.h" ; then
	    ac_cv_c_tkh=${with_tkinclude}
	else
	    AC_MSG_ERROR([${with_tkinclude} directory does not contain Tk public header file tk.h])
	fi
    else
	AC_CACHE_VAL(ac_cv_c_tkh, [
	    # Use the value from --with-tkinclude, if it was given

	    if test x"${with_tkinclude}" != x ; then
		ac_cv_c_tkh=${with_tkinclude}
	    else
		# Check in the includedir, if --prefix was specified

		eval "temp_includedir=${includedir}"
		for i in \
			`ls -d ${TCL_PREFIX}/include 2>/dev/null` \
			`ls -d ${temp_includedir} 2>/dev/null` \
			`ls -d ${TCL_BIN_DIR}/../include 2>/dev/null` \
			/usr/local/include /usr/include ; do
		    if test -f "$i/tk.h" ; then
			ac_cv_c_tkh=$i
			break
		    fi
		done
	    fi
	])
    fi

    # Print a message based on how we determined the include path

    if test x"${ac_cv_c_tkh}" = x ; then
	AC_MSG_ERROR(tk.h not found.  Please specify its location with --with-tkinclude)
    else
	AC_MSG_RESULT(${ac_cv_c_tkh})
    fi

    # Convert to a native path and substitute into the output files.

    INCLUDE_DIR_NATIVE=`${CYGPATH} ${ac_cv_c_tkh}`

    TK_INCLUDES=-I\"${INCLUDE_DIR_NATIVE}\"

    AC_SUBST(TK_INCLUDES)
])

#------------------------------------------------------------------------
# SC_SIMPLE_EXEEXT
#	Select the executable extension based on the host type.  This
#	is a lightweight replacement for AC_EXEEXT that doesn't require
#	a compiler.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		EXEEXT
#------------------------------------------------------------------------

AC_DEFUN(SC_SIMPLE_EXEEXT, [
    AC_MSG_CHECKING(executable extension based on host type)

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    EXEEXT=".exe"
	;;
	*)
	    EXEEXT=""
	;;
    esac

    AC_MSG_RESULT(${EXEEXT})
    AC_SUBST(EXEEXT)
])

#------------------------------------------------------------------------
# SC_PROG_TCLSH
#	Locate a tclsh shell in the following directories:
#		${exec_prefix}/bin
#		${prefix}/bin
#		${TCL_BIN_DIR}
#		${TCL_BIN_DIR}/../bin
#		${PATH}
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		TCLSH_PROG
#------------------------------------------------------------------------

AC_DEFUN(SC_PROG_TCLSH, [
    AC_MSG_CHECKING([for tclsh])

    AC_CACHE_VAL(ac_cv_path_tclsh, [
	search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/tclsh[[8-9]]*${EXEEXT} 2> /dev/null` \
		    `ls -r $dir/tclsh*${EXEEXT} 2> /dev/null` ; do
		if test x"$ac_cv_path_tclsh" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_tclsh=$j
			break
		    fi
		fi
	    done
	done
    ])

    if test -f "$ac_cv_path_tclsh" ; then
	TCLSH_PROG=$ac_cv_path_tclsh
	AC_MSG_RESULT($TCLSH_PROG)
    else
	AC_MSG_ERROR(No tclsh found in PATH:  $search_path)
    fi
    AC_SUBST(TCLSH_PROG)
])

#------------------------------------------------------------------------
# SC_PROG_WISH
#	Locate a wish shell in the following directories:
#		${exec_prefix}/bin
#		${prefix}/bin
#		${TCL_BIN_DIR}
#		${TCL_BIN_DIR}/../bin
#		${PATH}
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		WISH_PROG
#------------------------------------------------------------------------

AC_DEFUN(SC_PROG_WISH, [
    AC_MSG_CHECKING([for wish])

    AC_CACHE_VAL(ac_cv_path_wish, [
	search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/wish[[8-9]]*${EXEEXT} 2> /dev/null` \
		    `ls -r $dir/wish*${EXEEXT} 2> /dev/null` ; do
		if test x"$ac_cv_path_wish" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_wish=$j
			break
		    fi
		fi
	    done
	done
    ])

    if test -f "$ac_cv_path_wish" ; then
	WISH_PROG=$ac_cv_path_wish
	AC_MSG_RESULT($WISH_PROG)
    else
	AC_MSG_ERROR(No wish found in PATH:  $search_path)
    fi
    AC_SUBST(WISH_PROG)
])

#------------------------------------------------------------------------
# SC_SET_PLATFORM
#	Determine the common name of the platform we are using
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		PLATFORM
#		CYGPATH
#------------------------------------------------------------------------

AC_DEFUN(SC_SET_PLATFORM, [
    AC_MSG_CHECKING(host platform)

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*)
		CYGPATH="cygpath -w"
		PLATFORM=win32-ix86
	    ;;
	SunOS)
		CYGPATH=echo
		PLATFORM=solaris-sparc
	    ;;
	Linux)
		CYGPATH=echo
		PLATFORM=linux-ix86
	    ;;
	FreeBSD)
		CYGPATH=echo
		PLATFORM=freebsd-ix86
	    ;;
	AIX)
		CYGPATH=echo
		PLATFORM=aix-risc
	    ;;
	HP-UX)
		CYGPATH=echo
		PLATFORM=hpux-parisc
	    ;;
	IRIX)
		CYGPATH=echo
		PLATFORM=irix-mips
	    ;;
	*)
		CYGPATH=echo
		PLATFORM=UNSUPPORTED
	    ;;
    esac

    if test x"${PLATFORM}" = x"UNSUPPORTED" ; then
	AC_MSG_ERROR(Can't figure out what platform you are using)
    else
	AC_MSG_RESULT(${PLATFORM})
    fi

    AC_SUBST(PLATFORM)
    AC_SUBST(CYGPATH)
])

#------------------------------------------------------------------------
# SC_PATH_MODULE
#	Add a --with-foodir flag for locating sources for an external module
#	Search order:
#		--with-foodir configure switch value
#		cached configure value
#		$2 argument
#		${srcdir}/modules/$1
#		${srcdir}/../$1
#		${srcdir}/../$1[0-9]*
#
# Arguments
#	$1	Name of module to locate
#	$2	Default directory where module can be found.  If not specified,
#		the macro looks in some well-known locations.  This argument
#		is mainly used for internal modules.
#
# Results
#	sets MODULE_DIR_$1 to point to the top level directory of
#	the module.
#------------------------------------------------------------------------

AC_DEFUN(SC_PATH_MODULE, [

    if test x"${CYGPATH}" = x ; then
        SC_SET_PLATFORM
    fi

    modsrcdir=$1

    AC_ARG_WITH($1dir, [  --with-$1dir              directory containing sources for $1], with_module=${withval}, with_module="")
    AC_MSG_CHECKING([for $1dir])

    if test x"${with_module}" = x ; then
	AC_CACHE_VAL(ac_cv_module_$1dir,[
	    if test x"${with_module}" != x ; then
		# Sanity check.  Look for this module dir
		if test -d "${with_module}" ; then
		    ac_cv_module_$1dir=`(cd ${with_module} ; pwd)`
		fi
	    fi


	    # If not found, look in a few standard places for this module.
	    # Look in the default location (as specified by the argument(s)
	    # to this macro) first

	    if test x"$2" != x ; then
		for i in \
			`ls -dr $2 2>/dev/null` \
			`ls -dr ${srcdir}/$2 2>/dev/null` \
			`ls -dr ${srcdir}/../$2 2>/dev/null` \
			`ls -dr ${srcdir}/../$2[[0-9]]* 2>/dev/null` ; do
		    if test -d $i ; then
			ac_cv_module_$1dir=`(cd $i; pwd)`
			break
		    fi
                done
	    fi
    
	    # Make sure not to require a specific version number.

	    if test x"${ac_cv_module_$1dir}" = x ; then
		for i in \
			`ls -dr ${srcdir}/modules/$modsrcdir 2>/dev/null` \
			`ls -dr ${srcdir}/../$modsrcdir 2>/dev/null` \
			`ls -dr ${srcdir}/../$modsrcdir[[0-9]]* 2>/dev/null` ; do
		    if test -d $i ; then
			ac_cv_module_$1dir=`(cd $i; pwd)`
			break
		    fi
		done
	    fi
    

	])
    else
	if test -d "${with_module}" ; then
	    ac_cv_module_$1dir=`(cd ${with_module} ; pwd)`
	else
	    AC_MSG_ERROR("Directory ${with_module} does not exist!")
	fi
    fi

    if test x"${ac_cv_module_$1dir}" = x ; then
	AC_MSG_WARN(MISSING.  Use --with-$1dir to specify location of $1 or make sure you have checked out the sources from cvs.)
	MISSING_MODULE_LIST="${MISSING_MODULE_LIST} $1"
        MODULE_LIST="${MODULE_LIST} $1"
    else
	# Strip off any trailing \ from the path
	MODULE_DIR_$1=`${CYGPATH} ${ac_cv_module_$1dir} | sed -e 's%\\\\$%%'`
	AC_MSG_RESULT(${MODULE_DIR_$1})
	AC_SUBST(MODULE_DIR_$1)
	if test x"$1" != x"${PACKAGE}" ; then
	    MODULE_LIST="${MODULE_LIST} $1"
	fi
    fi
])

#------------------------------------------------------------------------
# SC_PATH_TOOLS
#	Add a --with-toolsdir flag for locating sources for an external module
#
# Arguments
#	none
#
# Results
#	sets MODULE_DIR_tools to point to the top level directory of
#	the module.
#------------------------------------------------------------------------

AC_DEFUN(SC_PATH_TOOLS, [
    AC_ARG_WITH(toolsdir, [  --with-toolsdir              directory containing sources for tools], with_module=${withval}, with_module="")
    AC_MSG_CHECKING([for toolsdir])

    if test x"${with_module}" = x ; then
	AC_CACHE_VAL(ac_cv_module_toolsdir,[
	    if test x"${with_module}" != x ; then
		# Sanity check.  Look for configure.in in this module dir
		if test -d "${with_module}" ; then
		    ac_cv_module_toolsdir=`(cd ${with_module} ; pwd)`
		fi
	    fi



	    # If not found, look in a few standard places for this module.
	    # Make sure not to require a specific version number.

	    if test x"${ac_cv_module_toolsdir}" = x ; then
		for i in \
			`ls -dr /tools/1.[[1-5]] 2>/dev/null` \
			`ls -dr /tools/TclPro1.[[1-5]] 2>/dev/null` \
			`ls -dr //t/tools/1.[[1-5]] 2>/dev/null` \
			`ls -dr //t/tools/TclPro1.[[1-5]] 2>/dev/null` \
			`ls -dr //pop/tools/1.[[1-5]] 2>/dev/null` \
			`ls -dr //pop/tools/TclPro1.[[1-5]] 2>/dev/null` ; do
		    if test -d $i ; then
			ac_cv_module_toolsdir=`(cd $i; pwd)`
			break
		    fi
		done
	    fi


	])
    else
	if test -d "${with_module}" ; then
	    ac_cv_module_toolsdir=`(cd ${with_module} ; pwd)`
	else
	    AC_MSG_WARN(Directory ${with_module} does not exist!)
	fi
    fi

    if test x"${ac_cv_module_toolsdir}" = x ; then
	AC_MSG_WARN(No tools directory - pressing forward with bogus value.)
	MODULE_DIR_tools=no_tools_dir
	AC_SUBST(MODULE_DIR_tools)
#	AC_MSG_ERROR("Use --with-toolsdir to specify location of tools")
#	exit 1
    else
	MODULE_DIR_tools=${ac_cv_module_toolsdir}
	AC_MSG_RESULT(${ac_cv_module_toolsdir})
	AC_SUBST(MODULE_DIR_tools)
    fi
])

#------------------------------------------------------------------------
# SC_PATH_PROTOOLS
#	Path to a valid Tclpro installation.  You must call SC_ SET_PLATFORM
#	before calling this macro.
#
# Arguments
#	none
#
# Results
#	Subst's the following values:
#		PROTOOLSDIR
#------------------------------------------------------------------------

AC_DEFUN(SC_PATH_PROTOOLS, [
    if test x"${PLATFORM}" = x ; then
        SC_SET_PLATFORM
    fi

    AC_ARG_WITH(protools, [ --with-protools            directory containing the Tclpro installation], protools_dir=${withval})

    AC_MSG_CHECKING(for protclsh in a TclPro installation)

    if test x"${protools_dir}" != x ; then
	# Look for protclsh

	for i in `ls -r ${protools_dir}/${PLATFORM}/bin/protclsh* 2>/dev/null` ; do
	    if test -f $i ; then
		PROTCLSH=$i
		break
	    fi
	done
    else
	for i in `ls -dr /tools/TclPro1.[[3-4]] 2>/dev/null` \
		`ls -dr //t/tools/TclPro1.[[3-4]] 2>/dev/null ` ; do

	    # Look for protclsh

	    for j in `ls $i/${PLATFORM}/bin/protclsh* 2>/dev/null` ; do
		if test -f $j ; then
		    PROTCLSH=$j
		    break
		fi
	    done

	    if test x"${PROTCLSH}" != x ; then
		protools_dir=$i
		break
	    fi
	done
    fi

    if test x"${PROTCLSH}" = x ; then
	AC_MSG_WARN(Could not locate a TclPro installation containing protclsh.  Use --with-protoolsdir to specify a valid TclPro installation.)
	protools_dir=BOGUS_protools_dir
    else
	AC_MSG_RESULT("found ${PROTCLSH}")
    fi

    PROTOOLSDIR=${protools_dir}
    AC_SUBST(PROTOOLSDIR)
])
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted configure.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
#! /bin/sh

# Guess values for system-dependent variables and create Makefiles.
# Generated automatically using autoconf version 2.13 
# Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
#
# This configure script is free software; the Free Software Foundation
# gives unlimited permission to copy, distribute and modify it.

# Defaults:
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:

# Initialize some variables set by options.
# The variables have the same names as the options, with
# dashes changed to underlines.
build=NONE
cache_file=./config.cache
exec_prefix=NONE
host=NONE
no_create=
nonopt=NONE
no_recursion=
prefix=NONE
program_prefix=NONE
program_suffix=NONE
program_transform_name=s,x,x,
silent=
site=
srcdir=
target=NONE
verbose=
x_includes=NONE
x_libraries=NONE
bindir='${exec_prefix}/bin'
sbindir='${exec_prefix}/sbin'
libexecdir='${exec_prefix}/libexec'
datadir='${prefix}/share'
sysconfdir='${prefix}/etc'
sharedstatedir='${prefix}/com'
localstatedir='${prefix}/var'
libdir='${exec_prefix}/lib'
includedir='${prefix}/include'
oldincludedir='/usr/include'
infodir='${prefix}/info'
mandir='${prefix}/man'

# Initialize some other variables.
subdirs=
MFLAGS= MAKEFLAGS=
SHELL=${CONFIG_SHELL-/bin/sh}
# Maximum number of lines to put in a shell here document.
ac_max_here_lines=12

ac_prev=
for ac_option
do

  # If the previous option needs an argument, assign it.
  if test -n "$ac_prev"; then
    eval "$ac_prev=\$ac_option"
    ac_prev=
    continue
  fi

  case "$ac_option" in
  -*=*) ac_optarg=`echo "$ac_option" | sed 's/[-_a-zA-Z0-9]*=//'` ;;
  *) ac_optarg= ;;
  esac

  # Accept the important Cygnus configure options, so we can diagnose typos.

  case "$ac_option" in

  -bindir | --bindir | --bindi | --bind | --bin | --bi)
    ac_prev=bindir ;;
  -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
    bindir="$ac_optarg" ;;

  -build | --build | --buil | --bui | --bu)
    ac_prev=build ;;
  -build=* | --build=* | --buil=* | --bui=* | --bu=*)
    build="$ac_optarg" ;;

  -cache-file | --cache-file | --cache-fil | --cache-fi \
  | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
    ac_prev=cache_file ;;
  -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
  | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
    cache_file="$ac_optarg" ;;

  -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
    ac_prev=datadir ;;
  -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
  | --da=*)
    datadir="$ac_optarg" ;;

  -disable-* | --disable-*)
    ac_feature=`echo $ac_option|sed -e 's/-*disable-//'`
    # Reject names that are not valid shell variable names.
    if test -n "`echo $ac_feature| sed 's/[-a-zA-Z0-9_]//g'`"; then
      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
    fi
    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
    eval "enable_${ac_feature}=no" ;;

  -enable-* | --enable-*)
    ac_feature=`echo $ac_option|sed -e 's/-*enable-//' -e 's/=.*//'`
    # Reject names that are not valid shell variable names.
    if test -n "`echo $ac_feature| sed 's/[-_a-zA-Z0-9]//g'`"; then
      { echo "configure: error: $ac_feature: invalid feature name" 1>&2; exit 1; }
    fi
    ac_feature=`echo $ac_feature| sed 's/-/_/g'`
    case "$ac_option" in
      *=*) ;;
      *) ac_optarg=yes ;;
    esac
    eval "enable_${ac_feature}='$ac_optarg'" ;;

  -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
  | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
  | --exec | --exe | --ex)
    ac_prev=exec_prefix ;;
  -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
  | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
  | --exec=* | --exe=* | --ex=*)
    exec_prefix="$ac_optarg" ;;

  -gas | --gas | --ga | --g)
    # Obsolete; use --with-gas.
    with_gas=yes ;;

  -help | --help | --hel | --he)
    # Omit some internal or obsolete options to make the list less imposing.
    # This message is too long to be a string in the A/UX 3.1 sh.
    cat << EOF
Usage: configure [options] [host]
Options: [defaults in brackets after descriptions]
Configuration:
  --cache-file=FILE       cache test results in FILE
  --help                  print this message
  --no-create             do not create output files
  --quiet, --silent       do not print \`checking...' messages
  --version               print the version of autoconf that created configure
Directory and file names:
  --prefix=PREFIX         install architecture-independent files in PREFIX
                          [$ac_default_prefix]
  --exec-prefix=EPREFIX   install architecture-dependent files in EPREFIX
                          [same as prefix]
  --bindir=DIR            user executables in DIR [EPREFIX/bin]
  --sbindir=DIR           system admin executables in DIR [EPREFIX/sbin]
  --libexecdir=DIR        program executables in DIR [EPREFIX/libexec]
  --datadir=DIR           read-only architecture-independent data in DIR
                          [PREFIX/share]
  --sysconfdir=DIR        read-only single-machine data in DIR [PREFIX/etc]
  --sharedstatedir=DIR    modifiable architecture-independent data in DIR
                          [PREFIX/com]
  --localstatedir=DIR     modifiable single-machine data in DIR [PREFIX/var]
  --libdir=DIR            object code libraries in DIR [EPREFIX/lib]
  --includedir=DIR        C header files in DIR [PREFIX/include]
  --oldincludedir=DIR     C header files for non-gcc in DIR [/usr/include]
  --infodir=DIR           info documentation in DIR [PREFIX/info]
  --mandir=DIR            man documentation in DIR [PREFIX/man]
  --srcdir=DIR            find the sources in DIR [configure dir or ..]
  --program-prefix=PREFIX prepend PREFIX to installed program names
  --program-suffix=SUFFIX append SUFFIX to installed program names
  --program-transform-name=PROGRAM
                          run sed PROGRAM on installed program names
EOF
    cat << EOF
Host type:
  --build=BUILD           configure for building on BUILD [BUILD=HOST]
  --host=HOST             configure for HOST [guessed]
  --target=TARGET         configure for TARGET [TARGET=HOST]
Features and packages:
  --disable-FEATURE       do not include FEATURE (same as --enable-FEATURE=no)
  --enable-FEATURE[=ARG]  include FEATURE [ARG=yes]
  --with-PACKAGE[=ARG]    use PACKAGE [ARG=yes]
  --without-PACKAGE       do not use PACKAGE (same as --with-PACKAGE=no)
  --x-includes=DIR        X include files are in DIR
  --x-libraries=DIR       X library files are in DIR
EOF
    if test -n "$ac_help"; then
      echo "--enable and --with options recognized:$ac_help"
    fi
    exit 0 ;;

  -host | --host | --hos | --ho)
    ac_prev=host ;;
  -host=* | --host=* | --hos=* | --ho=*)
    host="$ac_optarg" ;;

  -includedir | --includedir | --includedi | --included | --include \
  | --includ | --inclu | --incl | --inc)
    ac_prev=includedir ;;
  -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
  | --includ=* | --inclu=* | --incl=* | --inc=*)
    includedir="$ac_optarg" ;;

  -infodir | --infodir | --infodi | --infod | --info | --inf)
    ac_prev=infodir ;;
  -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
    infodir="$ac_optarg" ;;

  -libdir | --libdir | --libdi | --libd)
    ac_prev=libdir ;;
  -libdir=* | --libdir=* | --libdi=* | --libd=*)
    libdir="$ac_optarg" ;;

  -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
  | --libexe | --libex | --libe)
    ac_prev=libexecdir ;;
  -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
  | --libexe=* | --libex=* | --libe=*)
    libexecdir="$ac_optarg" ;;

  -localstatedir | --localstatedir | --localstatedi | --localstated \
  | --localstate | --localstat | --localsta | --localst \
  | --locals | --local | --loca | --loc | --lo)
    ac_prev=localstatedir ;;
  -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
  | --localstate=* | --localstat=* | --localsta=* | --localst=* \
  | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
    localstatedir="$ac_optarg" ;;

  -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
    ac_prev=mandir ;;
  -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
    mandir="$ac_optarg" ;;

  -nfp | --nfp | --nf)
    # Obsolete; use --without-fp.
    with_fp=no ;;

  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
  | --no-cr | --no-c)
    no_create=yes ;;

  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
    no_recursion=yes ;;

  -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
  | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
  | --oldin | --oldi | --old | --ol | --o)
    ac_prev=oldincludedir ;;
  -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
  | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
  | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
    oldincludedir="$ac_optarg" ;;

  -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
    ac_prev=prefix ;;
  -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
    prefix="$ac_optarg" ;;

  -program-prefix | --program-prefix | --program-prefi | --program-pref \
  | --program-pre | --program-pr | --program-p)
    ac_prev=program_prefix ;;
  -program-prefix=* | --program-prefix=* | --program-prefi=* \
  | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
    program_prefix="$ac_optarg" ;;

  -program-suffix | --program-suffix | --program-suffi | --program-suff \
  | --program-suf | --program-su | --program-s)
    ac_prev=program_suffix ;;
  -program-suffix=* | --program-suffix=* | --program-suffi=* \
  | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
    program_suffix="$ac_optarg" ;;

  -program-transform-name | --program-transform-name \
  | --program-transform-nam | --program-transform-na \
  | --program-transform-n | --program-transform- \
  | --program-transform | --program-transfor \
  | --program-transfo | --program-transf \
  | --program-trans | --program-tran \
  | --progr-tra | --program-tr | --program-t)
    ac_prev=program_transform_name ;;
  -program-transform-name=* | --program-transform-name=* \
  | --program-transform-nam=* | --program-transform-na=* \
  | --program-transform-n=* | --program-transform-=* \
  | --program-transform=* | --program-transfor=* \
  | --program-transfo=* | --program-transf=* \
  | --program-trans=* | --program-tran=* \
  | --progr-tra=* | --program-tr=* | --program-t=*)
    program_transform_name="$ac_optarg" ;;

  -q | -quiet | --quiet | --quie | --qui | --qu | --q \
  | -silent | --silent | --silen | --sile | --sil)
    silent=yes ;;

  -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
    ac_prev=sbindir ;;
  -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
  | --sbi=* | --sb=*)
    sbindir="$ac_optarg" ;;

  -sharedstatedir | --sharedstatedir | --sharedstatedi \
  | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
  | --sharedst | --shareds | --shared | --share | --shar \
  | --sha | --sh)
    ac_prev=sharedstatedir ;;
  -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
  | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
  | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
  | --sha=* | --sh=*)
    sharedstatedir="$ac_optarg" ;;

  -site | --site | --sit)
    ac_prev=site ;;
  -site=* | --site=* | --sit=*)
    site="$ac_optarg" ;;

  -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
    ac_prev=srcdir ;;
  -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
    srcdir="$ac_optarg" ;;

  -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
  | --syscon | --sysco | --sysc | --sys | --sy)
    ac_prev=sysconfdir ;;
  -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
  | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
    sysconfdir="$ac_optarg" ;;

  -target | --target | --targe | --targ | --tar | --ta | --t)
    ac_prev=target ;;
  -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
    target="$ac_optarg" ;;

  -v | -verbose | --verbose | --verbos | --verbo | --verb)
    verbose=yes ;;

  -version | --version | --versio | --versi | --vers)
    echo "configure generated by autoconf version 2.13"
    exit 0 ;;

  -with-* | --with-*)
    ac_package=`echo $ac_option|sed -e 's/-*with-//' -e 's/=.*//'`
    # Reject names that are not valid shell variable names.
    if test -n "`echo $ac_package| sed 's/[-_a-zA-Z0-9]//g'`"; then
      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
    fi
    ac_package=`echo $ac_package| sed 's/-/_/g'`
    case "$ac_option" in
      *=*) ;;
      *) ac_optarg=yes ;;
    esac
    eval "with_${ac_package}='$ac_optarg'" ;;

  -without-* | --without-*)
    ac_package=`echo $ac_option|sed -e 's/-*without-//'`
    # Reject names that are not valid shell variable names.
    if test -n "`echo $ac_package| sed 's/[-a-zA-Z0-9_]//g'`"; then
      { echo "configure: error: $ac_package: invalid package name" 1>&2; exit 1; }
    fi
    ac_package=`echo $ac_package| sed 's/-/_/g'`
    eval "with_${ac_package}=no" ;;

  --x)
    # Obsolete; use --with-x.
    with_x=yes ;;

  -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
  | --x-incl | --x-inc | --x-in | --x-i)
    ac_prev=x_includes ;;
  -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
  | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
    x_includes="$ac_optarg" ;;

  -x-libraries | --x-libraries | --x-librarie | --x-librari \
  | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
    ac_prev=x_libraries ;;
  -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
  | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
    x_libraries="$ac_optarg" ;;

  -*) { echo "configure: error: $ac_option: invalid option; use --help to show usage" 1>&2; exit 1; }
    ;;

  *)
    if test -n "`echo $ac_option| sed 's/[-a-z0-9.]//g'`"; then
      echo "configure: warning: $ac_option: invalid host type" 1>&2
    fi
    if test "x$nonopt" != xNONE; then
      { echo "configure: error: can only configure for one host and one target at a time" 1>&2; exit 1; }
    fi
    nonopt="$ac_option"
    ;;

  esac
done

if test -n "$ac_prev"; then
  { echo "configure: error: missing argument to --`echo $ac_prev | sed 's/_/-/g'`" 1>&2; exit 1; }
fi

trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15

# File descriptor usage:
# 0 standard input
# 1 file creation
# 2 errors and warnings
# 3 some systems may open it to /dev/tty
# 4 used on the Kubota Titan
# 6 checking for... messages and results
# 5 compiler messages saved in config.log
if test "$silent" = yes; then
  exec 6>/dev/null
else
  exec 6>&1
fi
exec 5>./config.log

echo "\
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
" 1>&5

# Strip out --no-create and --no-recursion so they do not pile up.
# Also quote any args containing shell metacharacters.
ac_configure_args=
for ac_arg
do
  case "$ac_arg" in
  -no-create | --no-create | --no-creat | --no-crea | --no-cre \
  | --no-cr | --no-c) ;;
  -no-recursion | --no-recursion | --no-recursio | --no-recursi \
  | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) ;;
  *" "*|*"	"*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?]*)
  ac_configure_args="$ac_configure_args '$ac_arg'" ;;
  *) ac_configure_args="$ac_configure_args $ac_arg" ;;
  esac
done

# NLS nuisances.
# Only set these to C if already set.  These must not be set unconditionally
# because not all systems understand e.g. LANG=C (notably SCO).
# Fixing LC_MESSAGES prevents Solaris sh from translating var values in `set'!
# Non-C LC_CTYPE values break the ctype check.
if test "${LANG+set}"   = set; then LANG=C;   export LANG;   fi
if test "${LC_ALL+set}" = set; then LC_ALL=C; export LC_ALL; fi
if test "${LC_MESSAGES+set}" = set; then LC_MESSAGES=C; export LC_MESSAGES; fi
if test "${LC_CTYPE+set}"    = set; then LC_CTYPE=C;    export LC_CTYPE;    fi

# confdefs.h avoids OS command line length limits that DEFS can exceed.
rm -rf conftest* confdefs.h
# AIX cpp loses on an empty file, so make sure it contains at least a newline.
echo > confdefs.h

# A filename unique to this package, relative to the directory that
# configure is in, which we can look for to find out if srcdir is correct.
ac_unique_file=ChangeLog

# Find the source files, if location was not specified.
if test -z "$srcdir"; then
  ac_srcdir_defaulted=yes
  # Try the directory containing this script, then its parent.
  ac_prog=$0
  ac_confdir=`echo $ac_prog|sed 's%/[^/][^/]*$%%'`
  test "x$ac_confdir" = "x$ac_prog" && ac_confdir=.
  srcdir=$ac_confdir
  if test ! -r $srcdir/$ac_unique_file; then
    srcdir=..
  fi
else
  ac_srcdir_defaulted=no
fi
if test ! -r $srcdir/$ac_unique_file; then
  if test "$ac_srcdir_defaulted" = yes; then
    { echo "configure: error: can not find sources in $ac_confdir or .." 1>&2; exit 1; }
  else
    { echo "configure: error: can not find sources in $srcdir" 1>&2; exit 1; }
  fi
fi
srcdir=`echo "${srcdir}" | sed 's%\([^/]\)/*$%\1%'`

# Prefer explicitly selected file to automatically selected ones.
if test -z "$CONFIG_SITE"; then
  if test "x$prefix" != xNONE; then
    CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
  else
    CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
  fi
fi
for ac_site_file in $CONFIG_SITE; do
  if test -r "$ac_site_file"; then
    echo "loading site script $ac_site_file"
    . "$ac_site_file"
  fi
done

if test -r "$cache_file"; then
  echo "loading cache $cache_file"
  . $cache_file
else
  echo "creating cache $cache_file"
  > $cache_file
fi

ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross

ac_exeext=
ac_objext=o
if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then
  # Stardent Vistra SVR4 grep lacks -e, says [email protected].
  if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then
    ac_n= ac_c='
' ac_t='	'
  else
    ac_n=-n ac_c= ac_t=
  fi
else
  ac_n= ac_c='\c' ac_t=
fi



case "`uname -s`" in
    *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*)
	CYGPATH="cygpath -w"
	;;
    *)
	CYGPATH=echo
	;;
esac



    echo $ac_n "checking executable extension based on host type""... $ac_c" 1>&6
echo "configure:538: checking executable extension based on host type" >&5

    case "`uname -s`" in
	*win32* | *WIN32* | *CYGWIN_NT* |*CYGWIN_98*|*CYGWIN_95*)
	    EXEEXT=".exe"
	;;
	*)
	    EXEEXT=""
	;;
    esac

    echo "$ac_t""${EXEEXT}" 1>&6
    


    echo $ac_n "checking for tclsh""... $ac_c" 1>&6
echo "configure:554: checking for tclsh" >&5

    if eval "test \"`echo '$''{'ac_cv_path_tclsh'+set}'`\" = set"; then
  echo $ac_n "(cached) $ac_c" 1>&6
else
  
	search_path=`echo ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${PATH} | sed -e 's/:/ /g'`
	for dir in $search_path ; do
	    for j in `ls -r $dir/tclsh[8-9]*${EXEEXT} 2> /dev/null` \
		    `ls -r $dir/tclsh*${EXEEXT} 2> /dev/null` ; do
		if test x"$ac_cv_path_tclsh" = x ; then
		    if test -f "$j" ; then
			ac_cv_path_tclsh=$j
			break
		    fi
		fi
	    done
	done
    
fi


    if test -f "$ac_cv_path_tclsh" ; then
	TCLSH_PROG=$ac_cv_path_tclsh
	echo "$ac_t""$TCLSH_PROG" 1>&6
    else
	{ echo "configure: error: No tclsh found in PATH:  $search_path" 1>&2; exit 1; }
    fi
    


# ### ######### ###########################

PACKAGE=`$TCLSH_PROG ${srcdir}/sak.tcl name`
MAJOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl major`
MINOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl minor`
PATCHLEVEL=""

VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL}
NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION}




# ### ######### ###########################

trap '' 1 2 15
cat > confcache <<\EOF
# This file is a shell script that caches the results of configure
# tests run on this system so they can be shared between configure
# scripts and configure runs.  It is not useful on other systems.
# If it contains results you don't want to keep, you may remove or edit it.
#
# By default, configure uses ./config.cache as the cache file,
# creating it if it does not exist already.  You can give configure
# the --cache-file=FILE option to use a different cache file; that is
# what configure does when it calls configure scripts in
# subdirectories, so they share the cache.
# Giving --cache-file=/dev/null disables caching, for debugging configure.
# config.status only pays attention to the cache file if you give it the
# --recheck option to rerun configure.
#
EOF
# The following way of writing the cache mishandles newlines in values,
# but we know of no workaround that is simple, portable, and efficient.
# So, don't put newlines in cache variables' values.
# Ultrix sh set writes to stderr and can't be redirected directly,
# and sets the high bit in the cache file unless we assign to the vars.
(set) 2>&1 |
  case `(ac_space=' '; set | grep ac_space) 2>&1` in
  *ac_space=\ *)
    # `set' does not quote correctly, so add quotes (double-quote substitution
    # turns \\\\ into \\, and sed turns \\ into \).
    sed -n \
      -e "s/'/'\\\\''/g" \
      -e "s/^\\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\\)=\\(.*\\)/\\1=\${\\1='\\2'}/p"
    ;;
  *)
    # `set' quotes correctly as required by POSIX, so do not add quotes.
    sed -n -e 's/^\([a-zA-Z0-9_]*_cv_[a-zA-Z0-9_]*\)=\(.*\)/\1=${\1=\2}/p'
    ;;
  esac >> confcache
if cmp -s $cache_file confcache; then
  :
else
  if test -w $cache_file; then
    echo "updating cache $cache_file"
    cat confcache > $cache_file
  else
    echo "not updating unwritable cache $cache_file"
  fi
fi
rm -f confcache

trap 'rm -fr conftest* confdefs* core core.* *.core $ac_clean_files; exit 1' 1 2 15

test "x$prefix" = xNONE && prefix=$ac_default_prefix
# Let make expand exec_prefix.
test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'

# Any assignment to VPATH causes Sun make to only execute
# the first set of double-colon rules, so remove it if not needed.
# If there is a colon in the path, we need to keep it.
if test "x$srcdir" = x.; then
  ac_vpsub='/^[ 	]*VPATH[ 	]*=[^:]*$/d'
fi

trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15

# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
cat > conftest.defs <<\EOF
s%#define \([A-Za-z_][A-Za-z0-9_]*\) *\(.*\)%-D\1=\2%g
s%[ 	`~#$^&*(){}\\|;'"<>?]%\\&%g
s%\[%\\&%g
s%\]%\\&%g
s%\$%$$%g
EOF
DEFS=`sed -f conftest.defs confdefs.h | tr '\012' ' '`
rm -f conftest.defs


# Without the "./", some shells look in PATH for config.status.
: ${CONFIG_STATUS=./config.status}

echo creating $CONFIG_STATUS
rm -f $CONFIG_STATUS
cat > $CONFIG_STATUS <<EOF
#! /bin/sh
# Generated automatically by configure.
# Run this file to recreate the current configuration.
# This directory was configured as follows,
# on host `(hostname || uname -n) 2>/dev/null | sed 1q`:
#
# $0 $ac_configure_args
#
# Compiler output produced by configure, useful for debugging
# configure, is in ./config.log if it exists.

ac_cs_usage="Usage: $CONFIG_STATUS [--recheck] [--version] [--help]"
for ac_option
do
  case "\$ac_option" in
  -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
    echo "running \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion"
    exec \${CONFIG_SHELL-/bin/sh} $0 $ac_configure_args --no-create --no-recursion ;;
  -version | --version | --versio | --versi | --vers | --ver | --ve | --v)
    echo "$CONFIG_STATUS generated by autoconf version 2.13"
    exit 0 ;;
  -help | --help | --hel | --he | --h)
    echo "\$ac_cs_usage"; exit 0 ;;
  *) echo "\$ac_cs_usage"; exit 1 ;;
  esac
done

ac_given_srcdir=$srcdir

trap 'rm -fr `echo "Makefile" | sed "s/:[^ ]*//g"` conftest*; exit 1' 1 2 15
EOF
cat >> $CONFIG_STATUS <<EOF

# Protect against being on the right side of a sed subst in config.status.
sed 's/%@/@@/; s/@%/@@/; s/%g\$/@g/; /@g\$/s/[\\\\&%]/\\\\&/g;
 s/@@/%@/; s/@@/@%/; s/@g\$/%g/' > conftest.subs <<\\CEOF
$ac_vpsub
$extrasub
s%@SHELL@%$SHELL%g
s%@CFLAGS@%$CFLAGS%g
s%@CPPFLAGS@%$CPPFLAGS%g
s%@CXXFLAGS@%$CXXFLAGS%g
s%@FFLAGS@%$FFLAGS%g
s%@DEFS@%$DEFS%g
s%@LDFLAGS@%$LDFLAGS%g
s%@LIBS@%$LIBS%g
s%@exec_prefix@%$exec_prefix%g
s%@prefix@%$prefix%g
s%@program_transform_name@%$program_transform_name%g
s%@bindir@%$bindir%g
s%@sbindir@%$sbindir%g
s%@libexecdir@%$libexecdir%g
s%@datadir@%$datadir%g
s%@sysconfdir@%$sysconfdir%g
s%@sharedstatedir@%$sharedstatedir%g
s%@localstatedir@%$localstatedir%g
s%@libdir@%$libdir%g
s%@includedir@%$includedir%g
s%@oldincludedir@%$oldincludedir%g
s%@infodir@%$infodir%g
s%@mandir@%$mandir%g
s%@CYGPATH@%$CYGPATH%g
s%@EXEEXT@%$EXEEXT%g
s%@TCLSH_PROG@%$TCLSH_PROG%g
s%@PACKAGE@%$PACKAGE%g
s%@VERSION@%$VERSION%g

CEOF
EOF

cat >> $CONFIG_STATUS <<\EOF

# Split the substitutions into bite-sized pieces for seds with
# small command number limits, like on Digital OSF/1 and HP-UX.
ac_max_sed_cmds=90 # Maximum number of lines to put in a sed script.
ac_file=1 # Number of current file.
ac_beg=1 # First line for current file.
ac_end=$ac_max_sed_cmds # Line after last line for current file.
ac_more_lines=:
ac_sed_cmds=""
while $ac_more_lines; do
  if test $ac_beg -gt 1; then
    sed "1,${ac_beg}d; ${ac_end}q" conftest.subs > conftest.s$ac_file
  else
    sed "${ac_end}q" conftest.subs > conftest.s$ac_file
  fi
  if test ! -s conftest.s$ac_file; then
    ac_more_lines=false
    rm -f conftest.s$ac_file
  else
    if test -z "$ac_sed_cmds"; then
      ac_sed_cmds="sed -f conftest.s$ac_file"
    else
      ac_sed_cmds="$ac_sed_cmds | sed -f conftest.s$ac_file"
    fi
    ac_file=`expr $ac_file + 1`
    ac_beg=$ac_end
    ac_end=`expr $ac_end + $ac_max_sed_cmds`
  fi
done
if test -z "$ac_sed_cmds"; then
  ac_sed_cmds=cat
fi
EOF

cat >> $CONFIG_STATUS <<EOF

CONFIG_FILES=\${CONFIG_FILES-"Makefile"}
EOF
cat >> $CONFIG_STATUS <<\EOF
for ac_file in .. $CONFIG_FILES; do if test "x$ac_file" != x..; then
  # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
  case "$ac_file" in
  *:*) ac_file_in=`echo "$ac_file"|sed 's%[^:]*:%%'`
       ac_file=`echo "$ac_file"|sed 's%:.*%%'` ;;
  *) ac_file_in="${ac_file}.in" ;;
  esac

  # Adjust a relative srcdir, top_srcdir, and INSTALL for subdirectories.

  # Remove last slash and all that follows it.  Not all systems have dirname.
  ac_dir=`echo $ac_file|sed 's%/[^/][^/]*$%%'`
  if test "$ac_dir" != "$ac_file" && test "$ac_dir" != .; then
    # The file is in a subdirectory.
    test ! -d "$ac_dir" && mkdir "$ac_dir"
    ac_dir_suffix="/`echo $ac_dir|sed 's%^\./%%'`"
    # A "../" for each directory in $ac_dir_suffix.
    ac_dots=`echo $ac_dir_suffix|sed 's%/[^/]*%../%g'`
  else
    ac_dir_suffix= ac_dots=
  fi

  case "$ac_given_srcdir" in
  .)  srcdir=.
      if test -z "$ac_dots"; then top_srcdir=.
      else top_srcdir=`echo $ac_dots|sed 's%/$%%'`; fi ;;
  /*) srcdir="$ac_given_srcdir$ac_dir_suffix"; top_srcdir="$ac_given_srcdir" ;;
  *) # Relative path.
    srcdir="$ac_dots$ac_given_srcdir$ac_dir_suffix"
    top_srcdir="$ac_dots$ac_given_srcdir" ;;
  esac


  echo creating "$ac_file"
  rm -f "$ac_file"
  configure_input="Generated automatically from `echo $ac_file_in|sed 's%.*/%%'` by configure."
  case "$ac_file" in
  *Makefile*) ac_comsub="1i\\
# $configure_input" ;;
  *) ac_comsub= ;;
  esac

  ac_file_inputs=`echo $ac_file_in|sed -e "s%^%$ac_given_srcdir/%" -e "s%:% $ac_given_srcdir/%g"`
  sed -e "$ac_comsub
s%@configure_input@%$configure_input%g
s%@srcdir@%$srcdir%g
s%@top_srcdir@%$top_srcdir%g
" $ac_file_inputs | (eval "$ac_sed_cmds") > $ac_file
fi; done
rm -f conftest.s*

EOF
cat >> $CONFIG_STATUS <<EOF

EOF
cat >> $CONFIG_STATUS <<\EOF

exit 0
EOF
chmod +x $CONFIG_STATUS
rm -fr confdefs* $ac_clean_files
test "$no_create" = yes || ${CONFIG_SHELL-/bin/sh} $CONFIG_STATUS || exit 1

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted configure.in.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
AC_INIT(ChangeLog)

case "`uname -s`" in
    *win32* | *WIN32* | *CYGWIN_NT* | *CYGWIN_98* | *CYGWIN_95*)
	CYGPATH="cygpath -w"
	;;
    *)
	CYGPATH=echo
	;;
esac
AC_SUBST(CYGPATH)

SC_SIMPLE_EXEEXT
SC_PROG_TCLSH

# ### ######### ###########################

PACKAGE=`$TCLSH_PROG ${srcdir}/sak.tcl name`
MAJOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl major`
MINOR_VERSION=`$TCLSH_PROG ${srcdir}/sak.tcl minor`
PATCHLEVEL=""

VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL}
NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION}

AC_SUBST(PACKAGE)
AC_SUBST(VERSION)

# ### ######### ###########################

AC_OUTPUT([Makefile])
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted devdoc/cvs.branches.fig.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
#FIG 3.2
Landscape
Center
Inches
Letter  
100.00
Single
-2
1200 2
6 3000 2025 5400 2400
4 0 12 50 0 0 14 0.0000 4 150 2385 3000 2175 Point releases are branched\001
4 0 12 50 0 0 14 0.0000 4 150 1530 3000 2370 from RELEASES\001
-6
6 2400 750 5700 1200
4 0 1 50 0 0 14 0.0000 4 195 3225 2400 900 Developer performs internal releases,\001
4 0 1 50 0 0 14 0.0000 4 195 3285 2400 1095 merging from HEAD into RELEASES\001
-6
2 1 0 4 0 7 50 0 -1 0.000 0 0 7 1 0 2
	2 1 4.00 240.00 480.00
	 300 600 5700 600
2 1 0 2 1 7 50 0 -1 0.000 0 0 -1 1 0 2
	2 1 2.00 120.00 240.00
	 2100 600 2400 1800
2 1 0 5 12 7 50 0 -1 0.000 0 0 -1 1 0 3
	2 1 5.00 300.00 600.00
	 2700 1800 3000 3000 5700 3000
2 1 0 4 17 7 50 0 -1 0.000 0 0 7 1 0 3
	2 1 4.00 240.00 480.00
	 1200 600 1500 1800 5700 1800
4 0 0 50 0 0 14 0.0000 4 195 2835 3150 1575 Staging for release : RELEASES\001
4 0 0 50 0 0 14 0.0000 4 195 1905 3900 300 Development : HEAD\001
4 0 0 50 0 0 14 0.0000 4 150 930 4800 2700 Tcllib 1.2.0\001
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































Deleted devdoc/devguide.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
<!- Guide for Tcllib developers -->

<h1>Guide for Tcllib developers.
</h1>
<hr>

<h2>CVS Repository
</h2>
<table><tr><td valign=top>
      <!-- The local source of this image is
		tcllib/devel/cvs.branches.*
	-->
      <img src="http://sourceforge.net/dbimage.php?id=2221">
</td><td valign=top><p>

The CVS repository for Tcllib contains two main branches, the HEAD for
development, and RELEASES as the staging area for official
releases. At RELEASES the minor branches containing the various
official releases are anchored at.
</p></td></tr></table>

<p>All the branches are of interest to the developers for
      Tcllib. Ongoing development happens in HEAD, which can be
      unstable or may not work at all. Whenever a developer considers
      a piece of code, or module, he is responsible for as
      sufficiently stable she has to perform an internal release which
      merges this part from HEAD into RELEASES. Tools to help with
      this will be provided.
</p>

<p>The branches for the official releases of tcllib are of interest to
      a developer because it is expected that fixes for important bugs
      not only go into the HEAD branch but also into the release
      branches for the release they were found in and all releases
      following that one. This is to allow the release manager to
      create patch releases of existing releases distribung important
      bugfixes as well.
</p>

<p>Version numbers for modules are handled as described below. This
      way of handling them was chosen so that the modules in the
      development branch always uses version numbers different from
      the version numbers in the official releases made so far.
</p>
<ul>
<li>Whenever an internal release of a module FOO is done, the
	developer performing this internal release has to increment
	the version number of the module <b>after</b> the release was
	executed.
</ul>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































Deleted devdoc/dirlayout_install.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Tcllib installation directory layout
====================================

This document describes the possible layouts for an installed tcllib,
discusses their pro and contra and makes a choice for Tcllib 1.4. A
roadmap of changes in the future is made available as appendix.

[L1/D] Deep layout
------------------

        This is the layout of Tcllib 1.3 (and versions before that).

        A single directory tcllib<version> is created, and all
        subdirectories of the 'modules' subdirectory in the
        distribution is copied into it. This is restricted at large to
        *.tcl files, with exception made for some modules with special
        needs.

        Pro:
        Contra:
                Makes the handling of the various package indices,
                well, not difficult, but uncomfortable.


[L2/Fa] Flat layout 1
---------------------

        A directory is created for each module of tcllib.

        Pro:
                Handling of package indices is easier than for L1/D, a
                toplevel index file with all its problems is not
                required anymore.

        Contra:
                Directories should be versioned to avoid conflicts
                between multiple releases. modules have no
                version. This can be faked for mdules containing one
                package, but not for the modules with more.


[L2/Fb] Flat layout 2
---------------------

        A directory is created for each package in tcllib.

        Pro
                Handling of package indices is easy, one per package.

        Contra:
                Modules containing more than one package are difficult
                to handle. The system has to split them into the
                individual packages. This rendered very difficult
                because of shared package index files.
        
                This can be solved by moving tcllib (back) towards of
                one package per module. When that goal is reached
                L2/Fa and L2/Fb become the same, and the contra for
                L2/Fa vanishes too as an exact version number can be
                associated with each directory.

Chosen layout for Tcllib 1.4
----------------------------

        L1/D

        Despite the problems with package indices the contras against
        the flat structures are too strong at this point in
        time. Automatic solutions are not really possible, or require
        a very high effort.

Roadmap
-------
        Change the module directories of tcllib to contain exactly one
        package per directory, with appropriate index (and meta data).

        This not only makes sense for easier handling of installation
        and package indices, but also in the geater context of
        wrapping code for deployment.


-----------------------------------
This document is in the public domain.

                        Andreas Kupries <[email protected]>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































Deleted devdoc/indexing.txt.

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

This document describes the possibilities for using one or more
pkgIndex.tcl files in an installation of tcllib to provide the
information about all of its packages to a tcl interpreter, discusses
their pro and contra and makes a choice for Tcllib 1.4. A roadmap of
changes in the future is made available as appendix.

Background under which to see the solutions:

        There are three level of groupings:

        -       The tcllib project itself
        -       Modules in the project (== subdirectory of 'modules')
        -       Packages in a module.

        Each module currently contains one package index file.

        Some modules contain more than one package. They share the index.

        Most packages require specific versions of the Tcl
        interpreter. They perform the checks in their package index
        file and do not register if the pre-requisites are not
        fulfilled.

        Other checks are possible, but currently not in use.

Note I:
	Whether a solutions is actually applicable depends on external
	factors, like the chosen directory layout of an installed
	tcllib.

Note II:
	All solutions currently depend on the specific implementation
	of [tclPkgUnknown] coming with the basic core, simply by the
	fact that the files looked at are called 'pkgIndex.tcl'. This
	is therefore no contra argument against any specific solution,
	but against all. We ignore this as currently there is no
	better replacement in existence.

Note III:
	We have to support Tcl before 8.3. as some packages in tcllib
	allow this.


[i1/ng] No global package index
-------------------------------

        In this solution the module package indices are the only index
        files present in an installation.

        This solution is applicable if and only if one of the flat
        directory layouts (L2/Fa or L2/Fb) has been chosen.

        Pro:
                Simple. No need for complex management.


[i2/ad] Global package index, auto_path extension, direct
---------------------------------------------------------

        A single global package index is present in the toplevel
        directory of the installation.

        This solution is applicable if and only if the deep directory
        layout (L2/D) has been chosen.

        The package index contains a series of statements extending
        the auto_path variable with all module directories. The list
        of names of the module directories is hardcoded. In other
        words, it is _not_ determined via [glob].

        Example:
                lappend auto_path [file join $dir md4]
                lappend auto_path [file join $dir md5]
                lappend auto_path [file join $dir sha1]
                ...


        Pro:
                [[0]]   Compared to [i3/ag] this should be bit faster
                        as glob'ing the directory tree of tcllib is
                        avoided. This performance-boost is not a big
                        pro according to the opinions below.

                [[1]]   Relies on the module package index files for
                        the actual registration of packages, thus
                        automatically inherits the correct contraints
                        on the registration of packages. No additional
                        complexities.

                [[2]]   Easier to generate than [i6/dr].

        Contra:
                [[3]]   Hard coding the directory names implies that
                        adding modules to the installed tcllib is not
                        as easy as just creating a new directory for
                        the module/package. The global index has to be
                        updated too.

                        Contra-Contra:
                                <<Don: New, updated packages should be
                                installed separately, outside of
                                tcllib. The ticked version number
                                ensures that it is prefered over the
                                package in tcllib.>>

                                <<AK: Agree fully>>
        
                [[4]]   Extending the 'auto_path' list causes the
                        package management of the tcl core to re-read
                        the list and glob through all of them for new
                        package indices. This has a high cost in terms
                        of filesystem access, i.e. is an issue of
                        performance.

                        Contra-Contra:
                                <<Don: IMHO, it's not really tcllib's
                                job to fix [tclPkgUnknown]'s
                                performance problems. If performance
                                is a problem, users could try the
                                patch with Tcl Feature Request 680169
                                and see if it helps.>>

                                <<AK: Not sure yet about this>>


                [[5]]   This enables auto-loading in each module
                        (according to any tclIndex file installed).
                        This should not be done by the package
                        indexer, but by the package itself.  See
                        control for an example.

	  	[[10]]	Will not work with Tcl releases prior to
			8.3.1.  Only then was [tclPkgUnknown]
			"enhanced" to deal with changing ::auto_path
			values.  If tcllib 1.4 wishes to continue
			supporting pre-8.3.1 Tcl, then this option has
			to be supplemented with a fallback.


[i3/ag] Global package index, auto_path extension, glob
-------------------------------------------------------

        This is like [i2/ad], except that the list of sub directories
        is not hardcoded into the index, but determined through glob.

        Example:
                foreach subdir [glob -nocomplain -type d $dir/*] {
                    lappend auto_path $subdir
                }

        Pro:
                Anti-[[3]]
                [[1]]

        Contra:
                All the contras of [i2/ad] and Anti-[[0]].


[i4/sd] Global package index, sourcing module indices, direct
-------------------------------------------------------------

        A single global package index is present in the toplevel
        directory of the installation.

        This solution is applicable if and only if the deep directory
        layout (L2/D) has been chosen.

        The package index contains a series of statements source'ing
        the package index files of the modules in tcllib. The list
        of names of the module directories is hardcoded. In other
        words, it is _not_ determined via [glob].

        Example:
                set main $dir
                set dir [file join $main md4]  ; source [file join $dir pkgIndex.tcl]
                set dir [file join $main md5]  ; source [file join $dir pkgIndex.tcl]
                set dir [file join $main sha1] ; source [file join $dir pkgIndex.tcl]
                ...

        Pro:
                [[0]], but compared to [i5/sg].
                [[1]]
                [[2]]
                [[6]]   In contrast to [i2/ad] and [i3/ag] repeated
                        glob'bing for package index files is
                        avoided. This cuts down on costly FS accesses.
                        I.e. another perf. boost.

        Contra:
                [[3]]

[i5/sg] Global package index, sourcing module indices, glob
-----------------------------------------------------------

        This is like [i4/sd], except that the list of package indices
        to source is not hardcoded into the index, but determined
        through glob.

        Example:
                foreach subdir [glob -nocomplain -type d $dir/*] {
                        set dir $subdir
                        source [file join $dir pkgIndex.tcl]
                }

        Pro:
                Anti-[[3]]
                [[1]]
                [[2]]

        Contra:
                All the contras of [i2/sd], and Anti-[[0]]


[i6/dr] Global package index, direct registration
-------------------------------------------------

        A single global package index is present in the toplevel
        directory of the installation.

        This solution is applicable if and only if the deep directory
        layout (L2/D) has been chosen.

        The package index contains a series of statements which
        directly register all the tcllib packages.

        Example:
                if {[constraint]} {return}
                package ifneeded md4  [list source [file join $dir md4 md4.tcl]]
                package ifneeded md5  [list source [file join $dir md4 md4.tcl]]
                package ifneeded sha1 [list source [file join $dir md4 md4.tcl]]
                ... more constraints ... package ifneeded

        Pro:
                [[7]]   This is the fasted solution as the number of
                        accesses to the filesystem is minimal.

        Contra:
                [[[3]]
                Anti-[[1]]	Care has to be taken to ensure that
                                the constraints the module indices
                                place on the registration of packages
                                are replicated in the global
                                index. All other solutions simply used
                                the module indices and thus got it
                                right automatically. Now supporting
                                code is required to detect such
                                constraints and then to properly
                                recreate them globally.

                                = High complexity for the maintainer.

[i7/ad] Global package index, auto_path extension, direct
---------------------------------------------------------

        A single global package index is present in the toplevel
        directory of the installation.

        This solution is applicable if and only if the deep directory
        layout (L2/D) has been chosen.

        The package index contains a single statement extending the
        auto_path variable with the tcllib main directory. The
        standard package management will then find all module sub
        directories and the package indices in them.

        Example:
                lappend auto_path $dir

        Pro:
                [[1]]
                [[8]]   This is the easiest solution by far in terms
                        of code to write, and complexities to solve
                        (none).

		[[9]]	<<Don: I believe this is the only proposal listed
			that actually fixes tcllib Bug 720318
			(successful [package require] of packages
			within a SafeBase) because it is the only one
			that changes the value of ::auto_path.>>

			<<AK: This is true, yet brittle. It depends on
			when the SafeBase sees the auto_path. If it
			happens to be before a [package require
			something] forced the reading of all package
			indices (and thus the extension of
			'auto_path') we are still SOL.>>

	Contra: [[4]]
	  	[[10]]


[i8/pm] Global package index, pkg_mkIndex
-----------------------------------------

Just use [pkg_mkIndex modules */*.tcl] to generate the master index.

	Pro:
		Easy to do.

	Contra:
		Does not handle constraints in subordinate package
		indices, simply because they are actually ignored
		during processing.

		Adding code to handle constraints evolves this into
		[i6/dr].

	Note: The contra is hard enough IMHO to make this solution not
	applicable for 1.4, which does have constraints, and handling
	them wrong (not at all) is a bug.


General discussion
------------------

Given that a deep directory layout was chosen [i1/ng] is not
applicable and therefore dropped from the discussion.

In the pro and contra arguments listed above three independent axes of
reasoning emerged:

a)        Performance of the solution, with the number of accesses to
          filesystem the main factor determining it.

b)        Complexity/difficulty of the solution with regard to
          adding/updating packages.

c)        Complexity of generating the master index.

Axis (b) has essentially been thrown out. Trying to modify the
installation of tcllib itself is bad practice. Install new/updated
packages separately. The version numbering takes care of the rest,
i.e. usage of the new over the older version found in tcllib.

With respect to axis (c), complexity of generation, [i7/ad] is the
definite winner, with the other *d solutions close behind (all use
fixed scripts, I7/ad wins on size). This is followed by the *g
solutions as they require actual dynamic generation of code. And at
the bottom of the ladder is [i6/dr] with its need for close inspection
of the sub-ordinate indices to get everything right.

Now axis (a), performance, [i6/dr] is most likely the winner as it
causes only one index to be read and nothing else. This is followed by
the all *d solutions, they read the subordinate indices, but do not
need much globbing. The actual order in this group is difficult to
determine. I guess that the auto_path extending methods are slower
than the sourcing methods, and the adding of one directory faster than
the adding of all, as the latter looks for much more subdirectories.
The next group oare the *g solutions as they their own globbing too
beyond that done by the package mgmt.

Two final rankings

        (c), then (a)           (a), then (c)
        -------------           -------------
        [i7/ad]                 [i6/dr]
        [i4/sd]                 [i4/sd]
        [i2/ad]                 [i7/ad]
        [i5/sg]                 [i2/ad]
        [i3/ag]                 [i5/sg]
        [i6/dr]                 [i3/ag]
        -------------           -------------

[i4/sd] seems to be a good compromise solution between performance and
complexity of generation, but [i7/ad] is not too bad either.

[i4/sd] reminder:
        set main $dir
        set dir [file join $main md4]  ; source [file join $dir pkgIndex.tcl]
        set dir [file join $main md5]  ; source [file join $dir pkgIndex.tcl]
        set dir [file join $main sha1] ; source [file join $dir pkgIndex.tcl]
        ...

[i7/ad] reminder:
        lappend auto_path $dir

Other opinions:

      	Don Porter prefers [i7/ad], and [i6/dr] as second choice.  Also
	as [i7/ad] fallback for older Tcl before 8.3.1

	Joe English strictly opposes any solution modifying the
	auto_path, violoating his opinion that index scripts should
	have no side-effects beyond registering a package.


Chosen solution for Tcllib 1.4
------------------------------

After comparing the code for the combination of [i7/ad] and [i6/dr] as
submitted by Don Porter, and for [i4/sd] as submitted by myself
(Andreas), and a small discussion on the Tcl'ers chat between Don and
me we took [i4/sd] for the main body of the idnex, and the header of
Don's code. Basically the chosen package index is a combination of
[i7/id] and of [i4/sd] as fallback.

This is still as easy to generate as [4/sd], the index is also only a
bit more complex, and speed should be ok too.

Don convinced me that while extending auto_path is definitely bad in
the long-term it is still ok for the short-term and release 1.4.


Roadmap
-------

After Tcllib has been driven into the state of one package per module
directory, and switched to a flat directory layout for its
installation we switch to [i1/ng] for the indexing structure.


-----------------------------------
This document is in the public domain.

                        Andreas Kupries <[email protected]>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted devdoc/installation.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Tcllib installation directory layout
====================================

This document describes the possible layouts for an installed tcllib,
discusses their pro and contra and makes a choice for Tcllib 1.4. A
roadmap of changes in the future is made available as appendix.

[L1/D] Deep layout
------------------

	This is the layout of Tcllib 1.3 (and versions before that).

	A single directory tcllib<version> is created, and all
	subdirectories of the 'modules' subdirectory in the
	distribution is copied into it. This is restricted at large to
	*.tcl files, with exception made for some modules with special
	needs.

	Pro:
	Contra:
		Makes the handling of the various package indices,
		well, not difficult, but uncomfortable.


[L2/Fa] Flat layout 1
---------------------

	A directory is created for each module of tcllib.

	Pro:
		Handling of package indices is easier than for L1/D, a
		toplevel index file with all its problems is not
		required anymore.

	Contra:
		Directories should be versioned to avoid conflicts
		between multiple releases. modules have no
		version. This can be faked for mdules containing one
		package, but not for the modules with more.


[L2/Fb] Flat layout 2
---------------------

	A directory is created for each package in tcllib.

	Pro
		Handling of package indices is easy, one per package.

	Contra:
		Modules containing more than one package are difficult
		to handle. The system has to split them into the
		individual packages. This rendered very difficult
		because of shared package index files.
	
		This can be solved by moving tcllib (back) towards of
		one package per module. When that goal is reached
		L2/Fa and L2/Fb become the same, and the contra for
		L2/Fa vanishes too as an exact version number can be
		associated with each directory.

Chosen layout for Tcllib 1.4
----------------------------

	L2/D

	Despite the problems with package indices the contras against
	the flat structures are too strong at this point in
	time. Automatic solutions are not really possible, or require
	a very high effort.

Roadmap
-------
	Change the module directories of tcllib to contain exactly one
	package per directory, with appropriate index (and meta data).

	This not only makes sense for easier handling of installation
	and package indices, but also in the geater context of
	wrapping code for deployment.


-----------------------------------
This document is in the public domain.

			Andreas Kupries	<[email protected]>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































Deleted devdoc/releaseguide.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
<!- Guide to the creation of source releases for Tcllib -->

<h1>Guide to the creation of source releases for Tcllib
</h1>
<hr>

<h2>Recap
</h2>
<table><tr><td valign=top>
      <!-- The local source of this image is
		tcllib/devel/cvs.branches.*
	-->
      <img src="http://sourceforge.net/dbimage.php?id=2221">
</td><td valign=top><p>
The CVS repository for Tcllib contains two main branches,
      the HEAD for development, and RELEASES as the staging area for
      official releases.
</p></td></tr></table>

<h2>Dependencies
</h2>

<h2>Creation of a new official release
</h2>

<p>To create a new official release of Tcllib the release manager has
      to perform the steps described below:
</p>


<ol>
<li> Retrieve the sources at the current head
	from the CVS repository, using a command like
<pre>
	  CVSROOT=:pserver:[email protected]:/cvsroot/tcllib
	  cvs -d${CVSROOT} co tcllib
</pre>
	Vary this command according to taste as long as the overall
	meaning is not changed. Compression options and the like.

<li> Tag these sources with a new branch tag for the new release of
	  tcllib, like
<pre>
	  cvs -d${CVSROOT} rtag tcllib
</pre>

<li> Commit the changes, then update the working directory.

<li> Use a tclsh to run the <b>sak</b> tool with the argument <i>gendist</i>, like
<pre>
    tclsh /path/to/tcllib/sak.tcl gendist
</pre>

<li> This results in the creation of a <i>tcllib-VERSION</i> directory
in the current working directory, and of two archives, <i>.zip</i>,
and <i>.tar.gz</i>. A starkit will be created if <b>sdx</b> is present
in the PATH. If additionally a file named <b>tclkit</b> is present in
the current working directory a starpack will be created too, using
this tclkit as the runtime.


<li> Now follow the instructions in the Sourceforge site documentation
		    for uploading the archives generated by the last
		    step to
		    <b>ftp://upload.sourceforge.net/incoming</b>, and
		    follow the procedures for creating packages and
		    releases at Sourceforge.
</ol>

<p>At last notify the relevant persons in other communities like
Debian (See list of contacts) about the new release.
</p>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































Deleted examples/README.

1
2
This directory contains example applications using the facilities of
tcllib.
<
<




Deleted examples/csv/Bench.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
000,VERSIONS:,1:8.4a3,1:8.3.3,1:8.2.3,1:8.1.1,1:8.0.5,1:7.6p2,1:7.5p1
001,CATCH return ok,11,6,7,4,5,28,17
002,CATCH return error,70,64,275,54,204,146,33
003,CATCH no catch used,10,6,7,13,4,24,9
004,IF if true numeric,17,11,13,7,9,152,61
005,IF elseif true numeric,20,15,16,20,11,299,292
006,IF else true numeric,20,15,16,15,11,318,82
007,IF if true num/num,17,12,281,22,9,329,174
008,IF if false num/num,17,12,13,13,9,202,182
009,IF if false al/num,27,20,20,29,17,467,121
010,IF if true al/al,31,26,26,51,169,292,184
011,IF if false al/al,31,25,25,51,60,217,243
012,IF if true al,32,25,25,42,51,214,76
013,IF elseif true al,47,39,338,89,156,358,154
014,IF else true al,46,40,42,71,51,292,323
015,SWITCH first true,63,42,103,58,73,391,241
016,SWITCH second true,58,39,153,65,62,340,282
017,SWITCH ninth true,67,44,238,73,112,391,284
018,SWITCH default true,62,38,46,73,77,492,292
019,DATA create in a list,4883,4083,15014,12925,7886,40180,29501
020,DATA create in an array,5388,4916,19172,12827,16792,53723,40784
021,DATA access in a list,4028,3546,15346,10386,7024,182889,175028
022,DATA access in an array,3507,3223,14156,6966,7640,43232,39744
023,EVAL cmd eval in list obj var,26,22,52,40,84,27,26
024,EVAL cmd eval as list,24,21,49,88,144,22,52
025,EVAL cmd eval as string,60,50,54,79,90,26,64
026,EVAL cmd and mixed lists,3347,3546,32485,21937,13914,3017,2112
027,EVAL list cmd and mixed lists,3403,3591,40366,19014,14703,2936,2259
028,EVAL list cmd and pure lists,543,582,40115,21974,12611,2653,2245
029,EXPR unbraced,153,167,502,23,331,313,365
030,EXPR braced,29,25,29,53,92,505,386
031,EXPR inline,31,30,40,68,59,321,177
032,EXPR one operand,11,6,158,9,11,47,65
033,EXPR ten operands,18,13,97,13,20,159,141
034,EXPR fifty operands,48,43,45,71,85,708,430
035,EXPR incr with incr,16,11,10,16,22,31,45
036,EXPR incr with expr,11,7,9,11,13,73,74
037,FCOPY std:      160010 bytes,10069,10242,46300,25104,26557
038,FCOPY binary:   160010 bytes,9932,9892,41776,25211,
039,FCOPY encoding: 160010 bytes,9818,9831,44598,25972,
040,KLIST shuffle0 llength 1,144,127,554,271,367
041,KLIST shuffle0 llength 10,457,413,1592,901,728
042,KLIST shuffle0 llength 100,3986,3552,13565,8229,6484
043,KLIST shuffle0 llength 1000,44083,41766,164223,92480,81157
044,KLIST shuffle0 llength 10000,563245,533804,2073612,1214997,1161217
045,KLIST shuffle1 llength 1,84,85,367,163,149
046,KLIST shuffle1 llength 10,358,333,1371,718,634
047,KLIST shuffle1 llength 100,6374,5238,12737,9243,8576
048,KLIST shuffle1 llength 1000,1190696,1194146,1770024,1762135,1736049
049,KLIST shuffle1a llength 1,110,100,94,172,150
050,KLIST shuffle1a llength 10,474,368,404,768,910
051,KLIST shuffle1a llength 100,4667,3625,3833,8986,9480
052,KLIST shuffle1a llength 1000,47818,37340,39248,84798,95305
053,KLIST shuffle1a llength 10000,474513,380522,408005,861405,1004602
054,KLIST shuffle2 llength 1,104,99,108,196,229
055,KLIST shuffle2 llength 10,440,375,481,938,1080
056,KLIST shuffle2 llength 100,3762,3625,4250,8904,9803
057,KLIST shuffle2 llength 1000,39573,37028,45651,95513,116933
058,KLIST shuffle2 llength 10000,474558,433771,527055,1176566,1304458
059,KLIST shuffle3 llength 1,104,98,102,217,170
060,KLIST shuffle3 llength 10,380,335,376,786,832
061,KLIST shuffle3 llength 100,3408,2883,3413,7161,7632
062,KLIST shuffle3 llength 1000,38716,33237,37667,87353,82985
063,KLIST shuffle3 llength 10000,945771,777699,844383,1789387,1732151
064,KLIST shuffle4 llength 1,114,102,100,202,178
065,KLIST shuffle4 llength 10,431,374,416,837,876
066,KLIST shuffle4 llength 100,3871,3250,3758,8572,8278
067,KLIST shuffle4 llength 1000,40201,32119,38186,82985,80450
068,KLIST shuffle4 llength 10000,393369,330472,398724,874454,834612
069,"STR/LIST length, obj shimmer",2390,2767,2333,905,28,2585,2638
070,"LIST length, pure list",18,13,13,21,18,2023,1837
071,STR length of a LIST,15,12,12,529,23,525,400
072,"LIST exact search, first item",19,11,14,17,32,2303,1693
073,"LIST exact search, middle item",69,25,27,46,38,1787,1944
074,"LIST exact search, last item",132,48,50,90,111,2261,2009
075,"LIST exact search, non-item",314,110,121,212,220,2099,2118
076,"LIST sorted search, first item",23,12,12,16,29,1862,1610
077,"LIST sorted search, middle item",24,26,26,42,40,1623,2252
078,"LIST sorted search, last item",24,52,49,84,121,2145,1784
079,"LIST sorted search, non-item",23,111,122,201,257,1999,2057
080,"LIST exact search, untyped item",131,47,51,80,101,2166,2218
081,"LIST exact search, typed item",128,48,49,77,111,2072,1872
082,"LIST sorted search, typed item",19,46,50,93,104,1887,2221
083,LIST sort,3299,3578,3293,6723,7021,10959,9644
084,LIST typed sort,2739,2943,2660,4737,4651,28889,23969
085,LIST remove first element,317,296,363,806,866,625,522
086,LIST remove middle element,325,291,358,692,876,656,677
087,LIST remove last element,318,293,360,689,879,754,675
088,LIST replace first element,310,289,346,722,917,727,978
089,LIST replace middle element,316,286,353,693,1045,1024,876
090,LIST replace last element,316,283,346,963,832,1450,1243
091,LIST replace first el with multiple,333,304,372,819,938,702,612
092,LIST replace middle el with multiple,319,310,351,691,736,1088,1123
093,LIST replace last el with multiple,319,282,347,813,740,1413,1313
094,LIST replace range,294,282,343,744,866,1198,971
095,LIST remove in mixed list,389,374,2195,833,999,829,617
096,LIST replace in mixed list,377,352,2184,1054,925,756,592
097,LIST index first element,18,10,13,16,25,451,375
098,LIST index middle element,17,10,13,16,23,516,536
099,LIST index last element,17,11,13,13,17,622,663
100,LIST insert an item at start,291,298,366,775,805,729,563
101,LIST insert an item at middle,269,266,370,684,667,978,630
102,"LIST insert an item at ""end""",257,254,349,670,1013,1779,1200
103,"LIST small, early range",23,19,16,42,35,500,383
104,"LIST small, late range",23,18,16,28,38,618,685
105,"LIST large, early range",37,29,24,54,108,511,697
106,"LIST large, late range",40,30,21,81,131,567,551
107,LIST append to list,409,401,396,917,1032,737,682
108,LIST join list,1053,1072,1066,1818,1453,3672,3167
109,"LOOP for, iterate list",6616,5198,5372,13766,9653,662376,583297
110,"LOOP foreach, iterate list",1919,1845,1952,3750,3553,11561,12556
111,LOOP for (to 1000),2566,2674,3065,4639,4867,66896,73851
112,LOOP while (to 1000),2568,2942,3065,4551,4637,69891,80404
113,"LOOP for, iterate string",6456,9440,9637,141594,14530,219770,199570
114,"LOOP foreach, iterate string",2240,2249,3955,9099,8147,15468,13206
115,MAP string 1 val,679,5931,6028,9096,(8.2+),(8.2+),(8.2+)
116,MAP string 2 val,1562,6643,6877,12943,(8.2+),(8.2+),(8.2+)
117,MAP string 3 val,1836,7673,7832,12825,(8.2+),(8.2+),(8.2+)
118,MAP string 4 val,2510,8429,8622,17267,(8.2+),(8.2+),(8.2+)
119,MAP string 1 val -nocase,3497,10259,10381,17685,(8.2+),(8.2+),(8.2+)
120,MAP string 2 val -nocase,6218,14570,15024,27379,(8.2+),(8.2+),(8.2+)
121,MAP string 3 val -nocase,8364,19344,18973,35569,(8.2+),(8.2+),(8.2+)
122,MAP string 4 val -nocase,10135,21861,22132,39660,(8.2+),(8.2+),(8.2+)
123,MAP regsub 1 val,3702,3954,4303,9663,1830,4430,3684
124,MAP regsub 2 val,16066,16981,18176,41500,4184,9394,11576
125,MAP regsub 3 val,21671,23258,24817,52315,6075,11441,12456
126,MAP regsub 4 val,26657,29335,31350,67973,8659,15319,13884
127,MAP regsub 1 val -nocase,3686,3913,4332,9463,2766,4729,4488
128,MAP regsub 2 val -nocase,15821,17024,18134,40735,5881,9546,11911
129,MAP regsub 3 val -nocase,20987,23228,24747,52639,8625,12501,14437
130,MAP regsub 4 val -nocase,26227,29397,31314,66937,11664,14510,16818
131,"MAP string, no match",926,7712,8028,14020,(8.2+),(8.2+),(8.2+)
132,"MAP string -nocase, no match",6726,18725,18933,35683,(8.2+),(8.2+),(8.2+)
133,"MAP regsub, no match",1149,2764,2830,6704,1843,3352,4823
134,"MAP regsub -nocase, no match",1151,2785,2890,6609,3563,4499,5249
135,MAP string short,37,41,39,116,(8.2+),(8.2+),(8.2+)
136,MAP regsub short,164,180,193,308,154,244,432
137,MTHD direct ns proc call,10,6,8,3,7
138,MTHD imported ns proc call,11,6,7,5,7
139,MTHD interp alias proc call,25,18,18,18,9
140,MTHD indirect proc eval,36,29,61,56,72
141,MTHD indirect proc eval #2,58,48,57,81,107
142,MTHD array stored proc call,14,9,10,22,19
143,MTHD switch method call,50,38,83,119,172
144,MTHD ns lookup call,99,81,216,374,376
145,MTHD inline call,5,3,3,2,2
146,PROC explicit return,15,7,8,7,7,11,11
147,PROC implicit return,11,6,7,4,11,16,15
148,PROC explicit return (2),12,7,8,13,13,14,10
149,PROC implicit return (2),10,6,7,10,18,21,24
150,PROC explicit return (3),10,7,7,4,14,14,25
151,PROC implicit return (3),10,6,7,3,12,10,18
152,PROC heavily commented,10,5,6,12,5,629,753
153,"PROC do-nothing, no args",8,5,28,38,4,5,2
154,"PROC do-nothing, one arg",10,5,6,9,8,15,21
155,PROC local links with global,1579,1569,1626,3586,4533,7955,11505
156,PROC local links with upvar,1287,1166,1387,2806,2922,8371,10317
157,PROC local links with variable,1195,1101,1334,2614,1050,9091,9212
158,"READ 595K, gets",340064,299797,306109,819327,372526,978472,985676
159,"READ 595K, read",77751,97698,97019,227338,2936958,3774669,3834017
160,"READ 595K, read & size",77606,97909,97074,242255,124776,3696432,3704813
161,"READ 3050b, gets",1869,1641,2052,4118,954,2074,2201
162,"READ 3050b, read",522,494,494,789,748,503,415
163,"READ 3050b, read & size",569,534,530,790,410,467,361
164,"BREAD 595K, gets",350077,292326,304961,833500,365165,953379,979961
165,"BREAD 595K, read",50105,50454,50018,228963,2952787,3640795,3741298
166,"BREAD 595K, read & size",50303,50486,50140,246365,87019,3685978,3688120
167,"BREAD 3050b, gets",2097,1777,1774,5220,1062,2208,2178
168,"BREAD 3050b, read",340,347,334,1310,412,458,359
169,"BREAD 3050b, read & size",396,389,369,1144,1230,390,495
170,REGEXP literal regexp,39,37,38,42,31,26,26
171,REGEXP var-based regexp,41,40,40,55,45,30,61
172,REGEXP count all matches,137,139,530,1280,1332,2277,2776
173,REGEXP extract all matches,169,177,616,1790,1129,3068,3620
174,STARTUP time to launch tclsh,21138,20425,18293,85723,102877,70500,90323
175,STR str [string compare],18,26,24,17,26,199,193
176,STR str [string equal],18,25,23,68,38,160,198
177,"STR str $a equal """"",17,26,24,81,52,670,410
178,"STR str num == """"",19,14,24,36,52,338,419
179,STR str $a eq $b,22,33,31,39,56,231,261
180,STR str $a ne $b,23,31,30,85,47,226,265
181,STR str $a eq $b (same obj),22,33,36,161,53,271,338
182,STR str $a ne $b (same obj),21,33,30,28,57,203,235
183,STR length (==4010),15,14,13,678,17,508,867
184,STR index 0,26,19,19,487,30,522,614
185,STR index 100,21,24,19,500,43,491,601
186,STR index 500,21,18,19,483,42,489,493
187,STR index2 0,21,19,19,494,27,485,583
188,STR index2 100,20,19,19,470,26,557,459
189,STR index2 500,21,19,19,484,40,764,468
190,STR first (success),19,16,15,21,33,533,519
191,STR first (failure),120,56,50,123,117,697,822
192,STR first (total failure),109,42,28,54,57,545,631
193,STR last (success),19,229,224,469,18,815,728
194,STR last (failure),90,99,91,185,201,657,859
195,STR last (total failure),82,90,83,135,151,584,1153
196,"STR match, simple (success early)",17,14,13,25,33,503,489
197,"STR match, simple (success late)",16,14,13,11,27,619,502
198,"STR match, simple (failure)",17,15,13,26,36,421,680
199,"STR match, simple (total failure)",16,18,13,17,30,456,378
200,"STR match, complex (success early)",17,23,22,33,35,466,448
201,"STR match, complex (success late)",145,1020,1040,2173,926,1529,1676
202,"STR match, complex (failure)",122,1011,1010,1785,964,1357,1698
203,"STR match, complex (total failure)",90,994,994,1844,1216,1725,1602
204,"STR range, index 100..200 of 4010",26,21,21,716,25,589,609
205,"STR replace, no replacement",79,270,264,570,166,1217,1315
206,"STR replace, equal replacement",92,277,257,526,140,1560,1263
207,"STR replace, longer replacement",95,270,265,551,103,1563,1309
208,"STR repeat, abcdefghij * 10",19,22,22,21,199,997,963
209,"STR repeat, abcdefghij * 100",39,72,74,120,1267,8488,9065
210,"STR repeat, abcdefghij * 1000",245,565,557,798,12264,81587,86928
211,"STR repeat, 4010 chars * 10",314,797,671,1971,1494,11891,7688
212,"STR repeat, 4010 chars * 100",7347,18287,18194,47967,69328,105423,107290
213,"STR reverse iter1, 100 chars",1285,1628,1425,4104,1871,8459,8704
214,"STR reverse iter1, 100 uchars",1264,1768,1436,4448,1864,8250,9034
215,"STR reverse iter2, 100 chars",808,1252,1168,3860,2099,8379,8292
216,"STR reverse iter2, 100 uchars",807,1259,1096,4086,1602,9513,5431
217,"STR reverse recur1, 100 chars",4092,4770,3998,8749,8470,20868,11271
218,"STR reverse recur1, 100 uchars",4169,5467,4767,8794,9075,21634,13821
219,"STR split, 4010 chars",2663,2138,8847,23626,18954,4372,3169
220,"STR split, 12100 uchars",7207,6395,,,
221,"STR split iter, 4010 chars",9349,9372,16664,39846,35962,52886,48521
222,"STR split iter, 12100 uchars",28171,28299,,,
223,STR append,100,82,71,108,164,1055,1145
224,STR append (1KB + 1KB),65,55,49,96,79,236,290
225,STR append (10KB + 1KB),186,193,196,474,75,215,213
226,STR append (1MB + 2b * 1000),37786,70498,74635,178639,12391,82339,84345
227,STR append (1MB + 1KB),29729,63374,61479,136891,68,215,335
228,STR append (1MB + 1KB * 20),29635,64566,61865,127033,270,1551,1724
229,STR append (1MB + 1KB * 1000),66605,94413,101998,177875,10955,78370,81930
230,STR append (1MB + 1MB * 3),126103,153051,157370,282029,218,248,876
231,STR append (1MB + 1MB * 5),157407,303871,315407,1051814,45,543,342
232,STR append (1MB + (1b + 1K + 1b) * 100),33118,63834,69167,290360,2398,8930,9893
233,STR info locals match,828,818,993,2025,1518,8071,9043
234,TRACE no trace set,35,25,26,18,27,42,91
235,TRACE read,35,26,26,16,59,128,113
236,TRACE write,35,25,26,16,55,78,78
237,TRACE unset,35,26,26,16,70,94,112
238,TRACE all set (rwu),35,25,25,18,59,77,105
239,UNSET var exists,14,8,9,8,16,27,37
240,UNSET catch var exists,16,9,10,52,20,61,58
241,UNSET catch var !exist,69,64,59,191,120,77,96
242,UNSET info check var exists,19,14,13,69,27,80,78
243,UNSET info check var !exist,16,11,11,6,17,73,64
244,UNSET nocomplain var exists,14,9,10,35,20,52,56
245,UNSET nocomplain var !exist,14,64,59,157,122,90,109
246,VAR access locally set,14,8,10,18,20,106,67
247,VAR access local proc arg,14,9,10,6,26,88,110
248,VAR access global,34,25,26,101,61,82,121
249,VAR access upvar,36,29,30,103,65,97,101
250,VAR set scalar,10,6,7,4,11,35,74
251,VAR set array element,18,12,14,9,33,59,35
252,VAR 100 'set's in array,162,133,160,296,292,917,827
253,VAR 'array set' of 100 elems,293,251,264,741,816,1063,993
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted examples/csv/Bench.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
<html><head><title>Core Benchmark Results</title></head><body>
<h1>Core Benchmark Results</h1>
<p><table border=1>
<tr><td>000</td> <td>VERSIONS:                              </td> <td>1:8.4a3</td> <td>1:8.3.3</td> <td>1:8.2.3</td> <td>1:8.1.1</td> <td>1:8.0.5</td> <td>1:7.6p2</td> <td>1:7.5p1</td></tr>
<tr><td>001</td> <td>CATCH return ok                        </td> <td>11     </td> <td>6      </td> <td>7      </td> <td>4      </td> <td>5      </td> <td>28     </td> <td>17     </td></tr>
<tr><td>002</td> <td>CATCH return error                     </td> <td>70     </td> <td>64     </td> <td>275    </td> <td>54     </td> <td>204    </td> <td>146    </td> <td>33     </td></tr>
<tr><td>003</td> <td>CATCH no catch used                    </td> <td>10     </td> <td>6      </td> <td>7      </td> <td>13     </td> <td>4      </td> <td>24     </td> <td>9      </td></tr>
<tr><td>004</td> <td>IF if true numeric                     </td> <td>17     </td> <td>11     </td> <td>13     </td> <td>7      </td> <td>9      </td> <td>152    </td> <td>61     </td></tr>
<tr><td>005</td> <td>IF elseif true numeric                 </td> <td>20     </td> <td>15     </td> <td>16     </td> <td>20     </td> <td>11     </td> <td>299    </td> <td>292    </td></tr>
<tr><td>006</td> <td>IF else true numeric                   </td> <td>20     </td> <td>15     </td> <td>16     </td> <td>15     </td> <td>11     </td> <td>318    </td> <td>82     </td></tr>
<tr><td>007</td> <td>IF if true num/num                     </td> <td>17     </td> <td>12     </td> <td>281    </td> <td>22     </td> <td>9      </td> <td>329    </td> <td>174    </td></tr>
<tr><td>008</td> <td>IF if false num/num                    </td> <td>17     </td> <td>12     </td> <td>13     </td> <td>13     </td> <td>9      </td> <td>202    </td> <td>182    </td></tr>
<tr><td>009</td> <td>IF if false al/num                     </td> <td>27     </td> <td>20     </td> <td>20     </td> <td>29     </td> <td>17     </td> <td>467    </td> <td>121    </td></tr>
<tr><td>010</td> <td>IF if true al/al                       </td> <td>31     </td> <td>26     </td> <td>26     </td> <td>51     </td> <td>169    </td> <td>292    </td> <td>184    </td></tr>
<tr><td>011</td> <td>IF if false al/al                      </td> <td>31     </td> <td>25     </td> <td>25     </td> <td>51     </td> <td>60     </td> <td>217    </td> <td>243    </td></tr>
<tr><td>012</td> <td>IF if true al                          </td> <td>32     </td> <td>25     </td> <td>25     </td> <td>42     </td> <td>51     </td> <td>214    </td> <td>76     </td></tr>
<tr><td>013</td> <td>IF elseif true al                      </td> <td>47     </td> <td>39     </td> <td>338    </td> <td>89     </td> <td>156    </td> <td>358    </td> <td>154    </td></tr>
<tr><td>014</td> <td>IF else true al                        </td> <td>46     </td> <td>40     </td> <td>42     </td> <td>71     </td> <td>51     </td> <td>292    </td> <td>323    </td></tr>
<tr><td>015</td> <td>SWITCH first true                      </td> <td>63     </td> <td>42     </td> <td>103    </td> <td>58     </td> <td>73     </td> <td>391    </td> <td>241    </td></tr>
<tr><td>016</td> <td>SWITCH second true                     </td> <td>58     </td> <td>39     </td> <td>153    </td> <td>65     </td> <td>62     </td> <td>340    </td> <td>282    </td></tr>
<tr><td>017</td> <td>SWITCH ninth true                      </td> <td>67     </td> <td>44     </td> <td>238    </td> <td>73     </td> <td>112    </td> <td>391    </td> <td>284    </td></tr>
<tr><td>018</td> <td>SWITCH default true                    </td> <td>62     </td> <td>38     </td> <td>46     </td> <td>73     </td> <td>77     </td> <td>492    </td> <td>292    </td></tr>
<tr><td>019</td> <td>DATA create in a list                  </td> <td>4883   </td> <td>4083   </td> <td>15014  </td> <td>12925  </td> <td>7886   </td> <td>40180  </td> <td>29501  </td></tr>
<tr><td>020</td> <td>DATA create in an array                </td> <td>5388   </td> <td>4916   </td> <td>19172  </td> <td>12827  </td> <td>16792  </td> <td>53723  </td> <td>40784  </td></tr>
<tr><td>021</td> <td>DATA access in a list                  </td> <td>4028   </td> <td>3546   </td> <td>15346  </td> <td>10386  </td> <td>7024   </td> <td>182889 </td> <td>175028 </td></tr>
<tr><td>022</td> <td>DATA access in an array                </td> <td>3507   </td> <td>3223   </td> <td>14156  </td> <td>6966   </td> <td>7640   </td> <td>43232  </td> <td>39744  </td></tr>
<tr><td>023</td> <td>EVAL cmd eval in list obj var          </td> <td>26     </td> <td>22     </td> <td>52     </td> <td>40     </td> <td>84     </td> <td>27     </td> <td>26     </td></tr>
<tr><td>024</td> <td>EVAL cmd eval as list                  </td> <td>24     </td> <td>21     </td> <td>49     </td> <td>88     </td> <td>144    </td> <td>22     </td> <td>52     </td></tr>
<tr><td>025</td> <td>EVAL cmd eval as string                </td> <td>60     </td> <td>50     </td> <td>54     </td> <td>79     </td> <td>90     </td> <td>26     </td> <td>64     </td></tr>
<tr><td>026</td> <td>EVAL cmd and mixed lists               </td> <td>3347   </td> <td>3546   </td> <td>32485  </td> <td>21937  </td> <td>13914  </td> <td>3017   </td> <td>2112   </td></tr>
<tr><td>027</td> <td>EVAL list cmd and mixed lists          </td> <td>3403   </td> <td>3591   </td> <td>40366  </td> <td>19014  </td> <td>14703  </td> <td>2936   </td> <td>2259   </td></tr>
<tr><td>028</td> <td>EVAL list cmd and pure lists           </td> <td>543    </td> <td>582    </td> <td>40115  </td> <td>21974  </td> <td>12611  </td> <td>2653   </td> <td>2245   </td></tr>
<tr><td>029</td> <td>EXPR unbraced                          </td> <td>153    </td> <td>167    </td> <td>502    </td> <td>23     </td> <td>331    </td> <td>313    </td> <td>365    </td></tr>
<tr><td>030</td> <td>EXPR braced                            </td> <td>29     </td> <td>25     </td> <td>29     </td> <td>53     </td> <td>92     </td> <td>505    </td> <td>386    </td></tr>
<tr><td>031</td> <td>EXPR inline                            </td> <td>31     </td> <td>30     </td> <td>40     </td> <td>68     </td> <td>59     </td> <td>321    </td> <td>177    </td></tr>
<tr><td>032</td> <td>EXPR one operand                       </td> <td>11     </td> <td>6      </td> <td>158    </td> <td>9      </td> <td>11     </td> <td>47     </td> <td>65     </td></tr>
<tr><td>033</td> <td>EXPR ten operands                      </td> <td>18     </td> <td>13     </td> <td>97     </td> <td>13     </td> <td>20     </td> <td>159    </td> <td>141    </td></tr>
<tr><td>034</td> <td>EXPR fifty operands                    </td> <td>48     </td> <td>43     </td> <td>45     </td> <td>71     </td> <td>85     </td> <td>708    </td> <td>430    </td></tr>
<tr><td>035</td> <td>EXPR incr with incr                    </td> <td>16     </td> <td>11     </td> <td>10     </td> <td>16     </td> <td>22     </td> <td>31     </td> <td>45     </td></tr>
<tr><td>036</td> <td>EXPR incr with expr                    </td> <td>11     </td> <td>7      </td> <td>9      </td> <td>11     </td> <td>13     </td> <td>73     </td> <td>74     </td></tr>
<tr><td>037</td> <td>FCOPY std:      160010 bytes           </td> <td>10069  </td> <td>10242  </td> <td>46300  </td> <td>25104  </td> <td>26557  </td> <td>       </td> <td>       </td></tr>
<tr><td>038</td> <td>FCOPY binary:   160010 bytes           </td> <td>9932   </td> <td>9892   </td> <td>41776  </td> <td>25211  </td> <td>       </td> <td>       </td> <td>       </td></tr>
<tr><td>039</td> <td>FCOPY encoding: 160010 bytes           </td> <td>9818   </td> <td>9831   </td> <td>44598  </td> <td>25972  </td> <td>       </td> <td>       </td> <td>       </td></tr>
<tr><td>040</td> <td>KLIST shuffle0 llength 1               </td> <td>144    </td> <td>127    </td> <td>554    </td> <td>271    </td> <td>367    </td> <td>       </td> <td>       </td></tr>
<tr><td>041</td> <td>KLIST shuffle0 llength 10              </td> <td>457    </td> <td>413    </td> <td>1592   </td> <td>901    </td> <td>728    </td> <td>       </td> <td>       </td></tr>
<tr><td>042</td> <td>KLIST shuffle0 llength 100             </td> <td>3986   </td> <td>3552   </td> <td>13565  </td> <td>8229   </td> <td>6484   </td> <td>       </td> <td>       </td></tr>
<tr><td>043</td> <td>KLIST shuffle0 llength 1000            </td> <td>44083  </td> <td>41766  </td> <td>164223 </td> <td>92480  </td> <td>81157  </td> <td>       </td> <td>       </td></tr>
<tr><td>044</td> <td>KLIST shuffle0 llength 10000           </td> <td>563245 </td> <td>533804 </td> <td>2073612</td> <td>1214997</td> <td>1161217</td> <td>       </td> <td>       </td></tr>
<tr><td>045</td> <td>KLIST shuffle1 llength 1               </td> <td>84     </td> <td>85     </td> <td>367    </td> <td>163    </td> <td>149    </td> <td>       </td> <td>       </td></tr>
<tr><td>046</td> <td>KLIST shuffle1 llength 10              </td> <td>358    </td> <td>333    </td> <td>1371   </td> <td>718    </td> <td>634    </td> <td>       </td> <td>       </td></tr>
<tr><td>047</td> <td>KLIST shuffle1 llength 100             </td> <td>6374   </td> <td>5238   </td> <td>12737  </td> <td>9243   </td> <td>8576   </td> <td>       </td> <td>       </td></tr>
<tr><td>048</td> <td>KLIST shuffle1 llength 1000            </td> <td>1190696</td> <td>1194146</td> <td>1770024</td> <td>1762135</td> <td>1736049</td> <td>       </td> <td>       </td></tr>
<tr><td>049</td> <td>KLIST shuffle1a llength 1              </td> <td>110    </td> <td>100    </td> <td>94     </td> <td>172    </td> <td>150    </td> <td>       </td> <td>       </td></tr>
<tr><td>050</td> <td>KLIST shuffle1a llength 10             </td> <td>474    </td> <td>368    </td> <td>404    </td> <td>768    </td> <td>910    </td> <td>       </td> <td>       </td></tr>
<tr><td>051</td> <td>KLIST shuffle1a llength 100            </td> <td>4667   </td> <td>3625   </td> <td>3833   </td> <td>8986   </td> <td>9480   </td> <td>       </td> <td>       </td></tr>
<tr><td>052</td> <td>KLIST shuffle1a llength 1000           </td> <td>47818  </td> <td>37340  </td> <td>39248  </td> <td>84798  </td> <td>95305  </td> <td>       </td> <td>       </td></tr>
<tr><td>053</td> <td>KLIST shuffle1a llength 10000          </td> <td>474513 </td> <td>380522 </td> <td>408005 </td> <td>861405 </td> <td>1004602</td> <td>       </td> <td>       </td></tr>
<tr><td>054</td> <td>KLIST shuffle2 llength 1               </td> <td>104    </td> <td>99     </td> <td>108    </td> <td>196    </td> <td>229    </td> <td>       </td> <td>       </td></tr>
<tr><td>055</td> <td>KLIST shuffle2 llength 10              </td> <td>440    </td> <td>375    </td> <td>481    </td> <td>938    </td> <td>1080   </td> <td>       </td> <td>       </td></tr>
<tr><td>056</td> <td>KLIST shuffle2 llength 100             </td> <td>3762   </td> <td>3625   </td> <td>4250   </td> <td>8904   </td> <td>9803   </td> <td>       </td> <td>       </td></tr>
<tr><td>057</td> <td>KLIST shuffle2 llength 1000            </td> <td>39573  </td> <td>37028  </td> <td>45651  </td> <td>95513  </td> <td>116933 </td> <td>       </td> <td>       </td></tr>
<tr><td>058</td> <td>KLIST shuffle2 llength 10000           </td> <td>474558 </td> <td>433771 </td> <td>527055 </td> <td>1176566</td> <td>1304458</td> <td>       </td> <td>       </td></tr>
<tr><td>059</td> <td>KLIST shuffle3 llength 1               </td> <td>104    </td> <td>98     </td> <td>102    </td> <td>217    </td> <td>170    </td> <td>       </td> <td>       </td></tr>
<tr><td>060</td> <td>KLIST shuffle3 llength 10              </td> <td>380    </td> <td>335    </td> <td>376    </td> <td>786    </td> <td>832    </td> <td>       </td> <td>       </td></tr>
<tr><td>061</td> <td>KLIST shuffle3 llength 100             </td> <td>3408   </td> <td>2883   </td> <td>3413   </td> <td>7161   </td> <td>7632   </td> <td>       </td> <td>       </td></tr>
<tr><td>062</td> <td>KLIST shuffle3 llength 1000            </td> <td>38716  </td> <td>33237  </td> <td>37667  </td> <td>87353  </td> <td>82985  </td> <td>       </td> <td>       </td></tr>
<tr><td>063</td> <td>KLIST shuffle3 llength 10000           </td> <td>945771 </td> <td>777699 </td> <td>844383 </td> <td>1789387</td> <td>1732151</td> <td>       </td> <td>       </td></tr>
<tr><td>064</td> <td>KLIST shuffle4 llength 1               </td> <td>114    </td> <td>102    </td> <td>100    </td> <td>202    </td> <td>178    </td> <td>       </td> <td>       </td></tr>
<tr><td>065</td> <td>KLIST shuffle4 llength 10              </td> <td>431    </td> <td>374    </td> <td>416    </td> <td>837    </td> <td>876    </td> <td>       </td> <td>       </td></tr>
<tr><td>066</td> <td>KLIST shuffle4 llength 100             </td> <td>3871   </td> <td>3250   </td> <td>3758   </td> <td>8572   </td> <td>8278   </td> <td>       </td> <td>       </td></tr>
<tr><td>067</td> <td>KLIST shuffle4 llength 1000            </td> <td>40201  </td> <td>32119  </td> <td>38186  </td> <td>82985  </td> <td>80450  </td> <td>       </td> <td>       </td></tr>
<tr><td>068</td> <td>KLIST shuffle4 llength 10000           </td> <td>393369 </td> <td>330472 </td> <td>398724 </td> <td>874454 </td> <td>834612 </td> <td>       </td> <td>       </td></tr>
<tr><td>069</td> <td>STR/LIST length, obj shimmer           </td> <td>2390   </td> <td>2767   </td> <td>2333   </td> <td>905    </td> <td>28     </td> <td>2585   </td> <td>2638   </td></tr>
<tr><td>070</td> <td>LIST length, pure list                 </td> <td>18     </td> <td>13     </td> <td>13     </td> <td>21     </td> <td>18     </td> <td>2023   </td> <td>1837   </td></tr>
<tr><td>071</td> <td>STR length of a LIST                   </td> <td>15     </td> <td>12     </td> <td>12     </td> <td>529    </td> <td>23     </td> <td>525    </td> <td>400    </td></tr>
<tr><td>072</td> <td>LIST exact search, first item          </td> <td>19     </td> <td>11     </td> <td>14     </td> <td>17     </td> <td>32     </td> <td>2303   </td> <td>1693   </td></tr>
<tr><td>073</td> <td>LIST exact search, middle item         </td> <td>69     </td> <td>25     </td> <td>27     </td> <td>46     </td> <td>38     </td> <td>1787   </td> <td>1944   </td></tr>
<tr><td>074</td> <td>LIST exact search, last item           </td> <td>132    </td> <td>48     </td> <td>50     </td> <td>90     </td> <td>111    </td> <td>2261   </td> <td>2009   </td></tr>
<tr><td>075</td> <td>LIST exact search, non-item            </td> <td>314    </td> <td>110    </td> <td>121    </td> <td>212    </td> <td>220    </td> <td>2099   </td> <td>2118   </td></tr>
<tr><td>076</td> <td>LIST sorted search, first item         </td> <td>23     </td> <td>12     </td> <td>12     </td> <td>16     </td> <td>29     </td> <td>1862   </td> <td>1610   </td></tr>
<tr><td>077</td> <td>LIST sorted search, middle item        </td> <td>24     </td> <td>26     </td> <td>26     </td> <td>42     </td> <td>40     </td> <td>1623   </td> <td>2252   </td></tr>
<tr><td>078</td> <td>LIST sorted search, last item          </td> <td>24     </td> <td>52     </td> <td>49     </td> <td>84     </td> <td>121    </td> <td>2145   </td> <td>1784   </td></tr>
<tr><td>079</td> <td>LIST sorted search, non-item           </td> <td>23     </td> <td>111    </td> <td>122    </td> <td>201    </td> <td>257    </td> <td>1999   </td> <td>2057   </td></tr>
<tr><td>080</td> <td>LIST exact search, untyped item        </td> <td>131    </td> <td>47     </td> <td>51     </td> <td>80     </td> <td>101    </td> <td>2166   </td> <td>2218   </td></tr>
<tr><td>081</td> <td>LIST exact search, typed item          </td> <td>128    </td> <td>48     </td> <td>49     </td> <td>77     </td> <td>111    </td> <td>2072   </td> <td>1872   </td></tr>
<tr><td>082</td> <td>LIST sorted search, typed item         </td> <td>19     </td> <td>46     </td> <td>50     </td> <td>93     </td> <td>104    </td> <td>1887   </td> <td>2221   </td></tr>
<tr><td>083</td> <td>LIST sort                              </td> <td>3299   </td> <td>3578   </td> <td>3293   </td> <td>6723   </td> <td>7021   </td> <td>10959  </td> <td>9644   </td></tr>
<tr><td>084</td> <td>LIST typed sort                        </td> <td>2739   </td> <td>2943   </td> <td>2660   </td> <td>4737   </td> <td>4651   </td> <td>28889  </td> <td>23969  </td></tr>
<tr><td>085</td> <td>LIST remove first element              </td> <td>317    </td> <td>296    </td> <td>363    </td> <td>806    </td> <td>866    </td> <td>625    </td> <td>522    </td></tr>
<tr><td>086</td> <td>LIST remove middle element             </td> <td>325    </td> <td>291    </td> <td>358    </td> <td>692    </td> <td>876    </td> <td>656    </td> <td>677    </td></tr>
<tr><td>087</td> <td>LIST remove last element               </td> <td>318    </td> <td>293    </td> <td>360    </td> <td>689    </td> <td>879    </td> <td>754    </td> <td>675    </td></tr>
<tr><td>088</td> <td>LIST replace first element             </td> <td>310    </td> <td>289    </td> <td>346    </td> <td>722    </td> <td>917    </td> <td>727    </td> <td>978    </td></tr>
<tr><td>089</td> <td>LIST replace middle element            </td> <td>316    </td> <td>286    </td> <td>353    </td> <td>693    </td> <td>1045   </td> <td>1024   </td> <td>876    </td></tr>
<tr><td>090</td> <td>LIST replace last element              </td> <td>316    </td> <td>283    </td> <td>346    </td> <td>963    </td> <td>832    </td> <td>1450   </td> <td>1243   </td></tr>
<tr><td>091</td> <td>LIST replace first el with multiple    </td> <td>333    </td> <td>304    </td> <td>372    </td> <td>819    </td> <td>938    </td> <td>702    </td> <td>612    </td></tr>
<tr><td>092</td> <td>LIST replace middle el with multiple   </td> <td>319    </td> <td>310    </td> <td>351    </td> <td>691    </td> <td>736    </td> <td>1088   </td> <td>1123   </td></tr>
<tr><td>093</td> <td>LIST replace last el with multiple     </td> <td>319    </td> <td>282    </td> <td>347    </td> <td>813    </td> <td>740    </td> <td>1413   </td> <td>1313   </td></tr>
<tr><td>094</td> <td>LIST replace range                     </td> <td>294    </td> <td>282    </td> <td>343    </td> <td>744    </td> <td>866    </td> <td>1198   </td> <td>971    </td></tr>
<tr><td>095</td> <td>LIST remove in mixed list              </td> <td>389    </td> <td>374    </td> <td>2195   </td> <td>833    </td> <td>999    </td> <td>829    </td> <td>617    </td></tr>
<tr><td>096</td> <td>LIST replace in mixed list             </td> <td>377    </td> <td>352    </td> <td>2184   </td> <td>1054   </td> <td>925    </td> <td>756    </td> <td>592    </td></tr>
<tr><td>097</td> <td>LIST index first element               </td> <td>18     </td> <td>10     </td> <td>13     </td> <td>16     </td> <td>25     </td> <td>451    </td> <td>375    </td></tr>
<tr><td>098</td> <td>LIST index middle element              </td> <td>17     </td> <td>10     </td> <td>13     </td> <td>16     </td> <td>23     </td> <td>516    </td> <td>536    </td></tr>
<tr><td>099</td> <td>LIST index last element                </td> <td>17     </td> <td>11     </td> <td>13     </td> <td>13     </td> <td>17     </td> <td>622    </td> <td>663    </td></tr>
<tr><td>100</td> <td>LIST insert an item at start           </td> <td>291    </td> <td>298    </td> <td>366    </td> <td>775    </td> <td>805    </td> <td>729    </td> <td>563    </td></tr>
<tr><td>101</td> <td>LIST insert an item at middle          </td> <td>269    </td> <td>266    </td> <td>370    </td> <td>684    </td> <td>667    </td> <td>978    </td> <td>630    </td></tr>
<tr><td>102</td> <td>LIST insert an item at "end"           </td> <td>257    </td> <td>254    </td> <td>349    </td> <td>670    </td> <td>1013   </td> <td>1779   </td> <td>1200   </td></tr>
<tr><td>103</td> <td>LIST small, early range                </td> <td>23     </td> <td>19     </td> <td>16     </td> <td>42     </td> <td>35     </td> <td>500    </td> <td>383    </td></tr>
<tr><td>104</td> <td>LIST small, late range                 </td> <td>23     </td> <td>18     </td> <td>16     </td> <td>28     </td> <td>38     </td> <td>618    </td> <td>685    </td></tr>
<tr><td>105</td> <td>LIST large, early range                </td> <td>37     </td> <td>29     </td> <td>24     </td> <td>54     </td> <td>108    </td> <td>511    </td> <td>697    </td></tr>
<tr><td>106</td> <td>LIST large, late range                 </td> <td>40     </td> <td>30     </td> <td>21     </td> <td>81     </td> <td>131    </td> <td>567    </td> <td>551    </td></tr>
<tr><td>107</td> <td>LIST append to list                    </td> <td>409    </td> <td>401    </td> <td>396    </td> <td>917    </td> <td>1032   </td> <td>737    </td> <td>682    </td></tr>
<tr><td>108</td> <td>LIST join list                         </td> <td>1053   </td> <td>1072   </td> <td>1066   </td> <td>1818   </td> <td>1453   </td> <td>3672   </td> <td>3167   </td></tr>
<tr><td>109</td> <td>LOOP for, iterate list                 </td> <td>6616   </td> <td>5198   </td> <td>5372   </td> <td>13766  </td> <td>9653   </td> <td>662376 </td> <td>583297 </td></tr>
<tr><td>110</td> <td>LOOP foreach, iterate list             </td> <td>1919   </td> <td>1845   </td> <td>1952   </td> <td>3750   </td> <td>3553   </td> <td>11561  </td> <td>12556  </td></tr>
<tr><td>111</td> <td>LOOP for (to 1000)                     </td> <td>2566   </td> <td>2674   </td> <td>3065   </td> <td>4639   </td> <td>4867   </td> <td>66896  </td> <td>73851  </td></tr>
<tr><td>112</td> <td>LOOP while (to 1000)                   </td> <td>2568   </td> <td>2942   </td> <td>3065   </td> <td>4551   </td> <td>4637   </td> <td>69891  </td> <td>80404  </td></tr>
<tr><td>113</td> <td>LOOP for, iterate string               </td> <td>6456   </td> <td>9440   </td> <td>9637   </td> <td>141594 </td> <td>14530  </td> <td>219770 </td> <td>199570 </td></tr>
<tr><td>114</td> <td>LOOP foreach, iterate string           </td> <td>2240   </td> <td>2249   </td> <td>3955   </td> <td>9099   </td> <td>8147   </td> <td>15468  </td> <td>13206  </td></tr>
<tr><td>115</td> <td>MAP string 1 val                       </td> <td>679    </td> <td>5931   </td> <td>6028   </td> <td>9096   </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>116</td> <td>MAP string 2 val                       </td> <td>1562   </td> <td>6643   </td> <td>6877   </td> <td>12943  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>117</td> <td>MAP string 3 val                       </td> <td>1836   </td> <td>7673   </td> <td>7832   </td> <td>12825  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>118</td> <td>MAP string 4 val                       </td> <td>2510   </td> <td>8429   </td> <td>8622   </td> <td>17267  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>119</td> <td>MAP string 1 val -nocase               </td> <td>3497   </td> <td>10259  </td> <td>10381  </td> <td>17685  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>120</td> <td>MAP string 2 val -nocase               </td> <td>6218   </td> <td>14570  </td> <td>15024  </td> <td>27379  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>121</td> <td>MAP string 3 val -nocase               </td> <td>8364   </td> <td>19344  </td> <td>18973  </td> <td>35569  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>122</td> <td>MAP string 4 val -nocase               </td> <td>10135  </td> <td>21861  </td> <td>22132  </td> <td>39660  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>123</td> <td>MAP regsub 1 val                       </td> <td>3702   </td> <td>3954   </td> <td>4303   </td> <td>9663   </td> <td>1830   </td> <td>4430   </td> <td>3684   </td></tr>
<tr><td>124</td> <td>MAP regsub 2 val                       </td> <td>16066  </td> <td>16981  </td> <td>18176  </td> <td>41500  </td> <td>4184   </td> <td>9394   </td> <td>11576  </td></tr>
<tr><td>125</td> <td>MAP regsub 3 val                       </td> <td>21671  </td> <td>23258  </td> <td>24817  </td> <td>52315  </td> <td>6075   </td> <td>11441  </td> <td>12456  </td></tr>
<tr><td>126</td> <td>MAP regsub 4 val                       </td> <td>26657  </td> <td>29335  </td> <td>31350  </td> <td>67973  </td> <td>8659   </td> <td>15319  </td> <td>13884  </td></tr>
<tr><td>127</td> <td>MAP regsub 1 val -nocase               </td> <td>3686   </td> <td>3913   </td> <td>4332   </td> <td>9463   </td> <td>2766   </td> <td>4729   </td> <td>4488   </td></tr>
<tr><td>128</td> <td>MAP regsub 2 val -nocase               </td> <td>15821  </td> <td>17024  </td> <td>18134  </td> <td>40735  </td> <td>5881   </td> <td>9546   </td> <td>11911  </td></tr>
<tr><td>129</td> <td>MAP regsub 3 val -nocase               </td> <td>20987  </td> <td>23228  </td> <td>24747  </td> <td>52639  </td> <td>8625   </td> <td>12501  </td> <td>14437  </td></tr>
<tr><td>130</td> <td>MAP regsub 4 val -nocase               </td> <td>26227  </td> <td>29397  </td> <td>31314  </td> <td>66937  </td> <td>11664  </td> <td>14510  </td> <td>16818  </td></tr>
<tr><td>131</td> <td>MAP string, no match                   </td> <td>926    </td> <td>7712   </td> <td>8028   </td> <td>14020  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>132</td> <td>MAP string -nocase, no match           </td> <td>6726   </td> <td>18725  </td> <td>18933  </td> <td>35683  </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>133</td> <td>MAP regsub, no match                   </td> <td>1149   </td> <td>2764   </td> <td>2830   </td> <td>6704   </td> <td>1843   </td> <td>3352   </td> <td>4823   </td></tr>
<tr><td>134</td> <td>MAP regsub -nocase, no match           </td> <td>1151   </td> <td>2785   </td> <td>2890   </td> <td>6609   </td> <td>3563   </td> <td>4499   </td> <td>5249   </td></tr>
<tr><td>135</td> <td>MAP string short                       </td> <td>37     </td> <td>41     </td> <td>39     </td> <td>116    </td> <td>(8.2+) </td> <td>(8.2+) </td> <td>(8.2+) </td></tr>
<tr><td>136</td> <td>MAP regsub short                       </td> <td>164    </td> <td>180    </td> <td>193    </td> <td>308    </td> <td>154    </td> <td>244    </td> <td>432    </td></tr>
<tr><td>137</td> <td>MTHD direct ns proc call               </td> <td>10     </td> <td>6      </td> <td>8      </td> <td>3      </td> <td>7      </td> <td>       </td> <td>       </td></tr>
<tr><td>138</td> <td>MTHD imported ns proc call             </td> <td>11     </td> <td>6      </td> <td>7      </td> <td>5      </td> <td>7      </td> <td>       </td> <td>       </td></tr>
<tr><td>139</td> <td>MTHD interp alias proc call            </td> <td>25     </td> <td>18     </td> <td>18     </td> <td>18     </td> <td>9      </td> <td>       </td> <td>       </td></tr>
<tr><td>140</td> <td>MTHD indirect proc eval                </td> <td>36     </td> <td>29     </td> <td>61     </td> <td>56     </td> <td>72     </td> <td>       </td> <td>       </td></tr>
<tr><td>141</td> <td>MTHD indirect proc eval #2             </td> <td>58     </td> <td>48     </td> <td>57     </td> <td>81     </td> <td>107    </td> <td>       </td> <td>       </td></tr>
<tr><td>142</td> <td>MTHD array stored proc call            </td> <td>14     </td> <td>9      </td> <td>10     </td> <td>22     </td> <td>19     </td> <td>       </td> <td>       </td></tr>
<tr><td>143</td> <td>MTHD switch method call                </td> <td>50     </td> <td>38     </td> <td>83     </td> <td>119    </td> <td>172    </td> <td>       </td> <td>       </td></tr>
<tr><td>144</td> <td>MTHD ns lookup call                    </td> <td>99     </td> <td>81     </td> <td>216    </td> <td>374    </td> <td>376    </td> <td>       </td> <td>       </td></tr>
<tr><td>145</td> <td>MTHD inline call                       </td> <td>5      </td> <td>3      </td> <td>3      </td> <td>2      </td> <td>2      </td> <td>       </td> <td>       </td></tr>
<tr><td>146</td> <td>PROC explicit return                   </td> <td>15     </td> <td>7      </td> <td>8      </td> <td>7      </td> <td>7      </td> <td>11     </td> <td>11     </td></tr>
<tr><td>147</td> <td>PROC implicit return                   </td> <td>11     </td> <td>6      </td> <td>7      </td> <td>4      </td> <td>11     </td> <td>16     </td> <td>15     </td></tr>
<tr><td>148</td> <td>PROC explicit return (2)               </td> <td>12     </td> <td>7      </td> <td>8      </td> <td>13     </td> <td>13     </td> <td>14     </td> <td>10     </td></tr>
<tr><td>149</td> <td>PROC implicit return (2)               </td> <td>10     </td> <td>6      </td> <td>7      </td> <td>10     </td> <td>18     </td> <td>21     </td> <td>24     </td></tr>
<tr><td>150</td> <td>PROC explicit return (3)               </td> <td>10     </td> <td>7      </td> <td>7      </td> <td>4      </td> <td>14     </td> <td>14     </td> <td>25     </td></tr>
<tr><td>151</td> <td>PROC implicit return (3)               </td> <td>10     </td> <td>6      </td> <td>7      </td> <td>3      </td> <td>12     </td> <td>10     </td> <td>18     </td></tr>
<tr><td>152</td> <td>PROC heavily commented                 </td> <td>10     </td> <td>5      </td> <td>6      </td> <td>12     </td> <td>5      </td> <td>629    </td> <td>753    </td></tr>
<tr><td>153</td> <td>PROC do-nothing, no args               </td> <td>8      </td> <td>5      </td> <td>28     </td> <td>38     </td> <td>4      </td> <td>5      </td> <td>2      </td></tr>
<tr><td>154</td> <td>PROC do-nothing, one arg               </td> <td>10     </td> <td>5      </td> <td>6      </td> <td>9      </td> <td>8      </td> <td>15     </td> <td>21     </td></tr>
<tr><td>155</td> <td>PROC local links with global           </td> <td>1579   </td> <td>1569   </td> <td>1626   </td> <td>3586   </td> <td>4533   </td> <td>7955   </td> <td>11505  </td></tr>
<tr><td>156</td> <td>PROC local links with upvar            </td> <td>1287   </td> <td>1166   </td> <td>1387   </td> <td>2806   </td> <td>2922   </td> <td>8371   </td> <td>10317  </td></tr>
<tr><td>157</td> <td>PROC local links with variable         </td> <td>1195   </td> <td>1101   </td> <td>1334   </td> <td>2614   </td> <td>1050   </td> <td>9091   </td> <td>9212   </td></tr>
<tr><td>158</td> <td>READ 595K, gets                        </td> <td>340064 </td> <td>299797 </td> <td>306109 </td> <td>819327 </td> <td>372526 </td> <td>978472 </td> <td>985676 </td></tr>
<tr><td>159</td> <td>READ 595K, read                        </td> <td>77751  </td> <td>97698  </td> <td>97019  </td> <td>227338 </td> <td>2936958</td> <td>3774669</td> <td>3834017</td></tr>
<tr><td>160</td> <td>READ 595K, read & size                 </td> <td>77606  </td> <td>97909  </td> <td>97074  </td> <td>242255 </td> <td>124776 </td> <td>3696432</td> <td>3704813</td></tr>
<tr><td>161</td> <td>READ 3050b, gets                       </td> <td>1869   </td> <td>1641   </td> <td>2052   </td> <td>4118   </td> <td>954    </td> <td>2074   </td> <td>2201   </td></tr>
<tr><td>162</td> <td>READ 3050b, read                       </td> <td>522    </td> <td>494    </td> <td>494    </td> <td>789    </td> <td>748    </td> <td>503    </td> <td>415    </td></tr>
<tr><td>163</td> <td>READ 3050b, read & size                </td> <td>569    </td> <td>534    </td> <td>530    </td> <td>790    </td> <td>410    </td> <td>467    </td> <td>361    </td></tr>
<tr><td>164</td> <td>BREAD 595K, gets                       </td> <td>350077 </td> <td>292326 </td> <td>304961 </td> <td>833500 </td> <td>365165 </td> <td>953379 </td> <td>979961 </td></tr>
<tr><td>165</td> <td>BREAD 595K, read                       </td> <td>50105  </td> <td>50454  </td> <td>50018  </td> <td>228963 </td> <td>2952787</td> <td>3640795</td> <td>3741298</td></tr>
<tr><td>166</td> <td>BREAD 595K, read & size                </td> <td>50303  </td> <td>50486  </td> <td>50140  </td> <td>246365 </td> <td>87019  </td> <td>3685978</td> <td>3688120</td></tr>
<tr><td>167</td> <td>BREAD 3050b, gets                      </td> <td>2097   </td> <td>1777   </td> <td>1774   </td> <td>5220   </td> <td>1062   </td> <td>2208   </td> <td>2178   </td></tr>
<tr><td>168</td> <td>BREAD 3050b, read                      </td> <td>340    </td> <td>347    </td> <td>334    </td> <td>1310   </td> <td>412    </td> <td>458    </td> <td>359    </td></tr>
<tr><td>169</td> <td>BREAD 3050b, read & size               </td> <td>396    </td> <td>389    </td> <td>369    </td> <td>1144   </td> <td>1230   </td> <td>390    </td> <td>495    </td></tr>
<tr><td>170</td> <td>REGEXP literal regexp                  </td> <td>39     </td> <td>37     </td> <td>38     </td> <td>42     </td> <td>31     </td> <td>26     </td> <td>26     </td></tr>
<tr><td>171</td> <td>REGEXP var-based regexp                </td> <td>41     </td> <td>40     </td> <td>40     </td> <td>55     </td> <td>45     </td> <td>30     </td> <td>61     </td></tr>
<tr><td>172</td> <td>REGEXP count all matches               </td> <td>137    </td> <td>139    </td> <td>530    </td> <td>1280   </td> <td>1332   </td> <td>2277   </td> <td>2776   </td></tr>
<tr><td>173</td> <td>REGEXP extract all matches             </td> <td>169    </td> <td>177    </td> <td>616    </td> <td>1790   </td> <td>1129   </td> <td>3068   </td> <td>3620   </td></tr>
<tr><td>174</td> <td>STARTUP time to launch tclsh           </td> <td>21138  </td> <td>20425  </td> <td>18293  </td> <td>85723  </td> <td>102877 </td> <td>70500  </td> <td>90323  </td></tr>
<tr><td>175</td> <td>STR str [string compare]               </td> <td>18     </td> <td>26     </td> <td>24     </td> <td>17     </td> <td>26     </td> <td>199    </td> <td>193    </td></tr>
<tr><td>176</td> <td>STR str [string equal]                 </td> <td>18     </td> <td>25     </td> <td>23     </td> <td>68     </td> <td>38     </td> <td>160    </td> <td>198    </td></tr>
<tr><td>177</td> <td>STR str $a equal ""                    </td> <td>17     </td> <td>26     </td> <td>24     </td> <td>81     </td> <td>52     </td> <td>670    </td> <td>410    </td></tr>
<tr><td>178</td> <td>STR str num == ""                      </td> <td>19     </td> <td>14     </td> <td>24     </td> <td>36     </td> <td>52     </td> <td>338    </td> <td>419    </td></tr>
<tr><td>179</td> <td>STR str $a eq $b                       </td> <td>22     </td> <td>33     </td> <td>31     </td> <td>39     </td> <td>56     </td> <td>231    </td> <td>261    </td></tr>
<tr><td>180</td> <td>STR str $a ne $b                       </td> <td>23     </td> <td>31     </td> <td>30     </td> <td>85     </td> <td>47     </td> <td>226    </td> <td>265    </td></tr>
<tr><td>181</td> <td>STR str $a eq $b (same obj)            </td> <td>22     </td> <td>33     </td> <td>36     </td> <td>161    </td> <td>53     </td> <td>271    </td> <td>338    </td></tr>
<tr><td>182</td> <td>STR str $a ne $b (same obj)            </td> <td>21     </td> <td>33     </td> <td>30     </td> <td>28     </td> <td>57     </td> <td>203    </td> <td>235    </td></tr>
<tr><td>183</td> <td>STR length (==4010)                    </td> <td>15     </td> <td>14     </td> <td>13     </td> <td>678    </td> <td>17     </td> <td>508    </td> <td>867    </td></tr>
<tr><td>184</td> <td>STR index 0                            </td> <td>26     </td> <td>19     </td> <td>19     </td> <td>487    </td> <td>30     </td> <td>522    </td> <td>614    </td></tr>
<tr><td>185</td> <td>STR index 100                          </td> <td>21     </td> <td>24     </td> <td>19     </td> <td>500    </td> <td>43     </td> <td>491    </td> <td>601    </td></tr>
<tr><td>186</td> <td>STR index 500                          </td> <td>21     </td> <td>18     </td> <td>19     </td> <td>483    </td> <td>42     </td> <td>489    </td> <td>493    </td></tr>
<tr><td>187</td> <td>STR index2 0                           </td> <td>21     </td> <td>19     </td> <td>19     </td> <td>494    </td> <td>27     </td> <td>485    </td> <td>583    </td></tr>
<tr><td>188</td> <td>STR index2 100                         </td> <td>20     </td> <td>19     </td> <td>19     </td> <td>470    </td> <td>26     </td> <td>557    </td> <td>459    </td></tr>
<tr><td>189</td> <td>STR index2 500                         </td> <td>21     </td> <td>19     </td> <td>19     </td> <td>484    </td> <td>40     </td> <td>764    </td> <td>468    </td></tr>
<tr><td>190</td> <td>STR first (success)                    </td> <td>19     </td> <td>16     </td> <td>15     </td> <td>21     </td> <td>33     </td> <td>533    </td> <td>519    </td></tr>
<tr><td>191</td> <td>STR first (failure)                    </td> <td>120    </td> <td>56     </td> <td>50     </td> <td>123    </td> <td>117    </td> <td>697    </td> <td>822    </td></tr>
<tr><td>192</td> <td>STR first (total failure)              </td> <td>109    </td> <td>42     </td> <td>28     </td> <td>54     </td> <td>57     </td> <td>545    </td> <td>631    </td></tr>
<tr><td>193</td> <td>STR last (success)                     </td> <td>19     </td> <td>229    </td> <td>224    </td> <td>469    </td> <td>18     </td> <td>815    </td> <td>728    </td></tr>
<tr><td>194</td> <td>STR last (failure)                     </td> <td>90     </td> <td>99     </td> <td>91     </td> <td>185    </td> <td>201    </td> <td>657    </td> <td>859    </td></tr>
<tr><td>195</td> <td>STR last (total failure)               </td> <td>82     </td> <td>90     </td> <td>83     </td> <td>135    </td> <td>151    </td> <td>584    </td> <td>1153   </td></tr>
<tr><td>196</td> <td>STR match, simple (success early)      </td> <td>17     </td> <td>14     </td> <td>13     </td> <td>25     </td> <td>33     </td> <td>503    </td> <td>489    </td></tr>
<tr><td>197</td> <td>STR match, simple (success late)       </td> <td>16     </td> <td>14     </td> <td>13     </td> <td>11     </td> <td>27     </td> <td>619    </td> <td>502    </td></tr>
<tr><td>198</td> <td>STR match, simple (failure)            </td> <td>17     </td> <td>15     </td> <td>13     </td> <td>26     </td> <td>36     </td> <td>421    </td> <td>680    </td></tr>
<tr><td>199</td> <td>STR match, simple (total failure)      </td> <td>16     </td> <td>18     </td> <td>13     </td> <td>17     </td> <td>30     </td> <td>456    </td> <td>378    </td></tr>
<tr><td>200</td> <td>STR match, complex (success early)     </td> <td>17     </td> <td>23     </td> <td>22     </td> <td>33     </td> <td>35     </td> <td>466    </td> <td>448    </td></tr>
<tr><td>201</td> <td>STR match, complex (success late)      </td> <td>145    </td> <td>1020   </td> <td>1040   </td> <td>2173   </td> <td>926    </td> <td>1529   </td> <td>1676   </td></tr>
<tr><td>202</td> <td>STR match, complex (failure)           </td> <td>122    </td> <td>1011   </td> <td>1010   </td> <td>1785   </td> <td>964    </td> <td>1357   </td> <td>1698   </td></tr>
<tr><td>203</td> <td>STR match, complex (total failure)     </td> <td>90     </td> <td>994    </td> <td>994    </td> <td>1844   </td> <td>1216   </td> <td>1725   </td> <td>1602   </td></tr>
<tr><td>204</td> <td>STR range, index 100..200 of 4010      </td> <td>26     </td> <td>21     </td> <td>21     </td> <td>716    </td> <td>25     </td> <td>589    </td> <td>609    </td></tr>
<tr><td>205</td> <td>STR replace, no replacement            </td> <td>79     </td> <td>270    </td> <td>264    </td> <td>570    </td> <td>166    </td> <td>1217   </td> <td>1315   </td></tr>
<tr><td>206</td> <td>STR replace, equal replacement         </td> <td>92     </td> <td>277    </td> <td>257    </td> <td>526    </td> <td>140    </td> <td>1560   </td> <td>1263   </td></tr>
<tr><td>207</td> <td>STR replace, longer replacement        </td> <td>95     </td> <td>270    </td> <td>265    </td> <td>551    </td> <td>103    </td> <td>1563   </td> <td>1309   </td></tr>
<tr><td>208</td> <td>STR repeat, abcdefghij * 10            </td> <td>19     </td> <td>22     </td> <td>22     </td> <td>21     </td> <td>199    </td> <td>997    </td> <td>963    </td></tr>
<tr><td>209</td> <td>STR repeat, abcdefghij * 100           </td> <td>39     </td> <td>72     </td> <td>74     </td> <td>120    </td> <td>1267   </td> <td>8488   </td> <td>9065   </td></tr>
<tr><td>210</td> <td>STR repeat, abcdefghij * 1000          </td> <td>245    </td> <td>565    </td> <td>557    </td> <td>798    </td> <td>12264  </td> <td>81587  </td> <td>86928  </td></tr>
<tr><td>211</td> <td>STR repeat, 4010 chars * 10            </td> <td>314    </td> <td>797    </td> <td>671    </td> <td>1971   </td> <td>1494   </td> <td>11891  </td> <td>7688   </td></tr>
<tr><td>212</td> <td>STR repeat, 4010 chars * 100           </td> <td>7347   </td> <td>18287  </td> <td>18194  </td> <td>47967  </td> <td>69328  </td> <td>105423 </td> <td>107290 </td></tr>
<tr><td>213</td> <td>STR reverse iter1, 100 chars           </td> <td>1285   </td> <td>1628   </td> <td>1425   </td> <td>4104   </td> <td>1871   </td> <td>8459   </td> <td>8704   </td></tr>
<tr><td>214</td> <td>STR reverse iter1, 100 uchars          </td> <td>1264   </td> <td>1768   </td> <td>1436   </td> <td>4448   </td> <td>1864   </td> <td>8250   </td> <td>9034   </td></tr>
<tr><td>215</td> <td>STR reverse iter2, 100 chars           </td> <td>808    </td> <td>1252   </td> <td>1168   </td> <td>3860   </td> <td>2099   </td> <td>8379   </td> <td>8292   </td></tr>
<tr><td>216</td> <td>STR reverse iter2, 100 uchars          </td> <td>807    </td> <td>1259   </td> <td>1096   </td> <td>4086   </td> <td>1602   </td> <td>9513   </td> <td>5431   </td></tr>
<tr><td>217</td> <td>STR reverse recur1, 100 chars          </td> <td>4092   </td> <td>4770   </td> <td>3998   </td> <td>8749   </td> <td>8470   </td> <td>20868  </td> <td>11271  </td></tr>
<tr><td>218</td> <td>STR reverse recur1, 100 uchars         </td> <td>4169   </td> <td>5467   </td> <td>4767   </td> <td>8794   </td> <td>9075   </td> <td>21634  </td> <td>13821  </td></tr>
<tr><td>219</td> <td>STR split, 4010 chars                  </td> <td>2663   </td> <td>2138   </td> <td>8847   </td> <td>23626  </td> <td>18954  </td> <td>4372   </td> <td>3169   </td></tr>
<tr><td>220</td> <td>STR split, 12100 uchars                </td> <td>7207   </td> <td>6395   </td> <td>       </td> <td>       </td> <td>       </td> <td>       </td> <td>       </td></tr>
<tr><td>221</td> <td>STR split iter, 4010 chars             </td> <td>9349   </td> <td>9372   </td> <td>16664  </td> <td>39846  </td> <td>35962  </td> <td>52886  </td> <td>48521  </td></tr>
<tr><td>222</td> <td>STR split iter, 12100 uchars           </td> <td>28171  </td> <td>28299  </td> <td>       </td> <td>       </td> <td>       </td> <td>       </td> <td>       </td></tr>
<tr><td>223</td> <td>STR append                             </td> <td>100    </td> <td>82     </td> <td>71     </td> <td>108    </td> <td>164    </td> <td>1055   </td> <td>1145   </td></tr>
<tr><td>224</td> <td>STR append (1KB + 1KB)                 </td> <td>65     </td> <td>55     </td> <td>49     </td> <td>96     </td> <td>79     </td> <td>236    </td> <td>290    </td></tr>
<tr><td>225</td> <td>STR append (10KB + 1KB)                </td> <td>186    </td> <td>193    </td> <td>196    </td> <td>474    </td> <td>75     </td> <td>215    </td> <td>213    </td></tr>
<tr><td>226</td> <td>STR append (1MB + 2b * 1000)           </td> <td>37786  </td> <td>70498  </td> <td>74635  </td> <td>178639 </td> <td>12391  </td> <td>82339  </td> <td>84345  </td></tr>
<tr><td>227</td> <td>STR append (1MB + 1KB)                 </td> <td>29729  </td> <td>63374  </td> <td>61479  </td> <td>136891 </td> <td>68     </td> <td>215    </td> <td>335    </td></tr>
<tr><td>228</td> <td>STR append (1MB + 1KB * 20)            </td> <td>29635  </td> <td>64566  </td> <td>61865  </td> <td>127033 </td> <td>270    </td> <td>1551   </td> <td>1724   </td></tr>
<tr><td>229</td> <td>STR append (1MB + 1KB * 1000)          </td> <td>66605  </td> <td>94413  </td> <td>101998 </td> <td>177875 </td> <td>10955  </td> <td>78370  </td> <td>81930  </td></tr>
<tr><td>230</td> <td>STR append (1MB + 1MB * 3)             </td> <td>126103 </td> <td>153051 </td> <td>157370 </td> <td>282029 </td> <td>218    </td> <td>248    </td> <td>876    </td></tr>
<tr><td>231</td> <td>STR append (1MB + 1MB * 5)             </td> <td>157407 </td> <td>303871 </td> <td>315407 </td> <td>1051814</td> <td>45     </td> <td>543    </td> <td>342    </td></tr>
<tr><td>232</td> <td>STR append (1MB + (1b + 1K + 1b) * 100)</td> <td>33118  </td> <td>63834  </td> <td>69167  </td> <td>290360 </td> <td>2398   </td> <td>8930   </td> <td>9893   </td></tr>
<tr><td>233</td> <td>STR info locals match                  </td> <td>828    </td> <td>818    </td> <td>993    </td> <td>2025   </td> <td>1518   </td> <td>8071   </td> <td>9043   </td></tr>
<tr><td>234</td> <td>TRACE no trace set                     </td> <td>35     </td> <td>25     </td> <td>26     </td> <td>18     </td> <td>27     </td> <td>42     </td> <td>91     </td></tr>
<tr><td>235</td> <td>TRACE read                             </td> <td>35     </td> <td>26     </td> <td>26     </td> <td>16     </td> <td>59     </td> <td>128    </td> <td>113    </td></tr>
<tr><td>236</td> <td>TRACE write                            </td> <td>35     </td> <td>25     </td> <td>26     </td> <td>16     </td> <td>55     </td> <td>78     </td> <td>78     </td></tr>
<tr><td>237</td> <td>TRACE unset                            </td> <td>35     </td> <td>26     </td> <td>26     </td> <td>16     </td> <td>70     </td> <td>94     </td> <td>112    </td></tr>
<tr><td>238</td> <td>TRACE all set (rwu)                    </td> <td>35     </td> <td>25     </td> <td>25     </td> <td>18     </td> <td>59     </td> <td>77     </td> <td>105    </td></tr>
<tr><td>239</td> <td>UNSET var exists                       </td> <td>14     </td> <td>8      </td> <td>9      </td> <td>8      </td> <td>16     </td> <td>27     </td> <td>37     </td></tr>
<tr><td>240</td> <td>UNSET catch var exists                 </td> <td>16     </td> <td>9      </td> <td>10     </td> <td>52     </td> <td>20     </td> <td>61     </td> <td>58     </td></tr>
<tr><td>241</td> <td>UNSET catch var !exist                 </td> <td>69     </td> <td>64     </td> <td>59     </td> <td>191    </td> <td>120    </td> <td>77     </td> <td>96     </td></tr>
<tr><td>242</td> <td>UNSET info check var exists            </td> <td>19     </td> <td>14     </td> <td>13     </td> <td>69     </td> <td>27     </td> <td>80     </td> <td>78     </td></tr>
<tr><td>243</td> <td>UNSET info check var !exist            </td> <td>16     </td> <td>11     </td> <td>11     </td> <td>6      </td> <td>17     </td> <td>73     </td> <td>64     </td></tr>
<tr><td>244</td> <td>UNSET nocomplain var exists            </td> <td>14     </td> <td>9      </td> <td>10     </td> <td>35     </td> <td>20     </td> <td>52     </td> <td>56     </td></tr>
<tr><td>245</td> <td>UNSET nocomplain var !exist            </td> <td>14     </td> <td>64     </td> <td>59     </td> <td>157    </td> <td>122    </td> <td>90     </td> <td>109    </td></tr>
<tr><td>246</td> <td>VAR access locally set                 </td> <td>14     </td> <td>8      </td> <td>10     </td> <td>18     </td> <td>20     </td> <td>106    </td> <td>67     </td></tr>
<tr><td>247</td> <td>VAR access local proc arg              </td> <td>14     </td> <td>9      </td> <td>10     </td> <td>6      </td> <td>26     </td> <td>88     </td> <td>110    </td></tr>
<tr><td>248</td> <td>VAR access global                      </td> <td>34     </td> <td>25     </td> <td>26     </td> <td>101    </td> <td>61     </td> <td>82     </td> <td>121    </td></tr>
<tr><td>249</td> <td>VAR access upvar                       </td> <td>36     </td> <td>29     </td> <td>30     </td> <td>103    </td> <td>65     </td> <td>97     </td> <td>101    </td></tr>
<tr><td>250</td> <td>VAR set scalar                         </td> <td>10     </td> <td>6      </td> <td>7      </td> <td>4      </td> <td>11     </td> <td>35     </td> <td>74     </td></tr>
<tr><td>251</td> <td>VAR set array element                  </td> <td>18     </td> <td>12     </td> <td>14     </td> <td>9      </td> <td>33     </td> <td>59     </td> <td>35     </td></tr>
<tr><td>252</td> <td>VAR 100 'set's in array                </td> <td>162    </td> <td>133    </td> <td>160    </td> <td>296    </td> <td>292    </td> <td>917    </td> <td>827    </td></tr>
<tr><td>253</td> <td>VAR 'array set' of 100 elems           </td> <td>293    </td> <td>251    </td> <td>264    </td> <td>741    </td> <td>816    </td> <td>1063   </td> <td>993    </td></tr>
</table></p></body></html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































Deleted examples/csv/Benchmark.75p2.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
000,VERSIONS:,1:7.5p1
001,CATCH return ok,17
002,CATCH return error,33
003,CATCH no catch used,9
004,IF if true numeric,61
005,IF elseif true numeric,292
006,IF else true numeric,82
007,IF if true num/num,174
008,IF if false num/num,182
009,IF if false al/num,121
010,IF if true al/al,184
011,IF if false al/al,243
012,IF if true al,76
013,IF elseif true al,154
014,IF else true al,323
015,SWITCH first true,241
016,SWITCH second true,282
017,SWITCH ninth true,284
018,SWITCH default true,292
019,DATA create in a list,29501
020,DATA create in an array,40784
021,DATA access in a list,175028
022,DATA access in an array,39744
023,EVAL cmd eval in list obj var,26
024,EVAL cmd eval as list,52
025,EVAL cmd eval as string,64
026,EVAL cmd and mixed lists,2112
027,EVAL list cmd and mixed lists,2259
028,EVAL list cmd and pure lists,2245
029,EXPR unbraced,365
030,EXPR braced,386
031,EXPR inline,177
032,EXPR one operand,65
033,EXPR ten operands,141
034,EXPR fifty operands,430
035,EXPR incr with incr,45
036,EXPR incr with expr,74
037,FCOPY std: 160010 bytes,26979
038,"STR/LIST length, obj shimmer",2638
039,"LIST length, pure list",1837
040,STR length of a LIST,400
041,"LIST exact search, first item",1693
042,"LIST exact search, middle item",1944
043,"LIST exact search, last item",2009
044,"LIST exact search, non-item",2118
045,"LIST sorted search, first item",1610
046,"LIST sorted search, middle item",2252
047,"LIST sorted search, last item",1784
048,"LIST sorted search, non-item",2057
049,"LIST exact search, untyped item",2218
050,"LIST exact search, typed item",1872
051,"LIST sorted search, typed item",2221
052,LIST sort,9644
053,LIST typed sort,23969
054,LIST remove first element,522
055,LIST remove middle element,677
056,LIST remove last element,675
057,LIST replace first element,978
058,LIST replace middle element,876
059,LIST replace last element,1243
060,LIST replace first el with multiple,612
061,LIST replace middle el with multiple,1123
062,LIST replace last el with multiple,1313
063,LIST replace range,971
064,LIST remove in mixed list,617
065,LIST replace in mixed list,592
066,LIST index first element,375
067,LIST index middle element,536
068,LIST index last element,663
069,LIST insert an item at start,563
070,LIST insert an item at middle,630
071,"LIST insert an item at ""end""",1200
072,"LIST small, early range",383
073,"LIST small, late range",685
074,"LIST large, early range",697
075,"LIST large, late range",551
076,LIST append to list,682
077,LIST join list,3167
078,"LOOP for, iterate list",583297
079,"LOOP foreach, iterate list",12556
080,LOOP for (to 1000),73851
081,LOOP while (to 1000),80404
082,"LOOP for, iterate string",199570
083,"LOOP foreach, iterate string",13206
084,MAP string 1 val,(8.2+)
085,MAP string 2 val,(8.2+)
086,MAP string 3 val,(8.2+)
087,MAP string 4 val,(8.2+)
088,MAP string 1 val -nocase,(8.2+)
089,MAP string 2 val -nocase,(8.2+)
090,MAP string 3 val -nocase,(8.2+)
091,MAP string 4 val -nocase,(8.2+)
092,MAP regsub 1 val,3684
093,MAP regsub 2 val,11576
094,MAP regsub 3 val,12456
095,MAP regsub 4 val,13884
096,MAP regsub 1 val -nocase,4488
097,MAP regsub 2 val -nocase,11911
098,MAP regsub 3 val -nocase,14437
099,MAP regsub 4 val -nocase,16818
100,"MAP string, no match",(8.2+)
101,"MAP string -nocase, no match",(8.2+)
102,"MAP regsub, no match",4823
103,"MAP regsub -nocase, no match",5249
104,MAP string short,(8.2+)
105,MAP regsub short,432
106,PROC explicit return,11
107,PROC implicit return,15
108,PROC explicit return (2),10
109,PROC implicit return (2),24
110,PROC explicit return (3),25
111,PROC implicit return (3),18
112,PROC heavily commented,753
113,"PROC do-nothing, no args",2
114,"PROC do-nothing, one arg",21
115,PROC local links with global,11505
116,PROC local links with upvar,10317
117,PROC local links with variable,9212
118,"READ 595K, gets",985676
119,"READ 595K, read",3834017
120,"READ 595K, read & size",3704813
121,"READ 3050b, gets",2201
122,"READ 3050b, read",415
123,"READ 3050b, read & size",361
124,"BREAD 595K, gets",979961
125,"BREAD 595K, read",3741298
126,"BREAD 595K, read & size",3688120
127,"BREAD 3050b, gets",2178
128,"BREAD 3050b, read",359
129,"BREAD 3050b, read & size",495
130,REGEXP literal regexp,26
131,REGEXP var-based regexp,61
132,REGEXP count all matches,2776
133,REGEXP extract all matches,3620
134,STARTUP time to launch tclsh,90323
135,STR str [string compare],193
136,STR str [string equal],198
137,"STR str $a equal """"",410
138,"STR str num == """"",419
139,STR str $a eq $b,261
140,STR str $a ne $b,265
141,STR str $a eq $b (same obj),338
142,STR str $a ne $b (same obj),235
143,STR length (==4010),867
144,STR index 0,614
145,STR index 100,601
146,STR index 500,493
147,STR index2 0,583
148,STR index2 100,459
149,STR index2 500,468
150,STR first (success),519
151,STR first (failure),822
152,STR first (total failure),631
153,STR last (success),728
154,STR last (failure),859
155,STR last (total failure),1153
156,"STR match, simple (success early)",489
157,"STR match, simple (success late)",502
158,"STR match, simple (failure)",680
159,"STR match, simple (total failure)",378
160,"STR match, complex (success early)",448
161,"STR match, complex (success late)",1676
162,"STR match, complex (failure)",1698
163,"STR match, complex (total failure)",1602
164,"STR range, index 100..200 of 4010",609
165,"STR replace, no replacement",1315
166,"STR replace, equal replacement",1263
167,"STR replace, longer replacement",1309
168,"STR repeat, abcdefghij * 10",963
169,"STR repeat, abcdefghij * 100",9065
170,"STR repeat, abcdefghij * 1000",86928
171,"STR repeat, 4010 chars * 10",7688
172,"STR repeat, 4010 chars * 100",107290
173,"STR reverse iter1, 100 chars",8704
174,"STR reverse iter1, 100 uchars",9034
175,"STR reverse iter2, 100 chars",8292
176,"STR reverse iter2, 100 uchars",5431
177,"STR reverse recur1, 100 chars",11271
178,"STR reverse recur1, 100 uchars",13821
179,"STR split, 4010 chars",3169
180,"STR split, 12000 uchars",9080
181,"STR split iter, 4010 chars",48521
182,"STR split iter, 12000 uchars",156287
183,STR append,1145
184,STR append (1KB + 1KB),290
185,STR append (10KB + 1KB),213
186,STR append (1MB + 2b * 1000),84345
187,STR append (1MB + 1KB),335
188,STR append (1MB + 1KB * 20),1724
189,STR append (1MB + 1KB * 1000),81930
190,STR append (1MB + 1MB * 3),876
191,STR append (1MB + 1MB * 5),342
192,STR append (1MB + (1b + 1K + 1b) * 100),9893
193,STR info locals match,9043
194,TRACE no trace set,91
195,TRACE read,113
196,TRACE write,78
197,TRACE unset,112
198,TRACE all set (rwu),105
199,UNSET var exists,37
200,UNSET catch var exists,58
201,UNSET catch var !exist,96
202,UNSET info check var exists,78
203,UNSET info check var !exist,64
204,UNSET nocomplain var exists,56
205,UNSET nocomplain var !exist,109
206,VAR access locally set,67
207,VAR access local proc arg,110
208,VAR access global,121
209,VAR access upvar,101
210,VAR set scalar,74
211,VAR set array element,35
212,VAR 100 'set's in array,827
213,VAR 'array set' of 100 elems,993

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































Deleted examples/csv/Benchmark.76p2.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
000,VERSIONS:,1:7.6p2
001,CATCH return ok,28
002,CATCH return error,146
003,CATCH no catch used,24
004,IF if true numeric,152
005,IF elseif true numeric,299
006,IF else true numeric,318
007,IF if true num/num,329
008,IF if false num/num,202
009,IF if false al/num,467
010,IF if true al/al,292
011,IF if false al/al,217
012,IF if true al,214
013,IF elseif true al,358
014,IF else true al,292
015,SWITCH first true,391
016,SWITCH second true,340
017,SWITCH ninth true,391
018,SWITCH default true,492
019,DATA create in a list,40180
020,DATA create in an array,53723
021,DATA access in a list,182889
022,DATA access in an array,43232
023,EVAL cmd eval in list obj var,27
024,EVAL cmd eval as list,22
025,EVAL cmd eval as string,26
026,EVAL cmd and mixed lists,3017
027,EVAL list cmd and mixed lists,2936
028,EVAL list cmd and pure lists,2653
029,EXPR unbraced,313
030,EXPR braced,505
031,EXPR inline,321
032,EXPR one operand,47
033,EXPR ten operands,159
034,EXPR fifty operands,708
035,EXPR incr with incr,31
036,EXPR incr with expr,73
037,FCOPY std: 160010 bytes,29538
038,"STR/LIST length, obj shimmer",2585
039,"LIST length, pure list",2023
040,STR length of a LIST,525
041,"LIST exact search, first item",2303
042,"LIST exact search, middle item",1787
043,"LIST exact search, last item",2261
044,"LIST exact search, non-item",2099
045,"LIST sorted search, first item",1862
046,"LIST sorted search, middle item",1623
047,"LIST sorted search, last item",2145
048,"LIST sorted search, non-item",1999
049,"LIST exact search, untyped item",2166
050,"LIST exact search, typed item",2072
051,"LIST sorted search, typed item",1887
052,LIST sort,10959
053,LIST typed sort,28889
054,LIST remove first element,625
055,LIST remove middle element,656
056,LIST remove last element,754
057,LIST replace first element,727
058,LIST replace middle element,1024
059,LIST replace last element,1450
060,LIST replace first el with multiple,702
061,LIST replace middle el with multiple,1088
062,LIST replace last el with multiple,1413
063,LIST replace range,1198
064,LIST remove in mixed list,829
065,LIST replace in mixed list,756
066,LIST index first element,451
067,LIST index middle element,516
068,LIST index last element,622
069,LIST insert an item at start,729
070,LIST insert an item at middle,978
071,"LIST insert an item at ""end""",1779
072,"LIST small, early range",500
073,"LIST small, late range",618
074,"LIST large, early range",511
075,"LIST large, late range",567
076,LIST append to list,737
077,LIST join list,3672
078,"LOOP for, iterate list",662376
079,"LOOP foreach, iterate list",11561
080,LOOP for (to 1000),66896
081,LOOP while (to 1000),69891
082,"LOOP for, iterate string",219770
083,"LOOP foreach, iterate string",15468
084,MAP string 1 val,(8.2+)
085,MAP string 2 val,(8.2+)
086,MAP string 3 val,(8.2+)
087,MAP string 4 val,(8.2+)
088,MAP string 1 val -nocase,(8.2+)
089,MAP string 2 val -nocase,(8.2+)
090,MAP string 3 val -nocase,(8.2+)
091,MAP string 4 val -nocase,(8.2+)
092,MAP regsub 1 val,4430
093,MAP regsub 2 val,9394
094,MAP regsub 3 val,11441
095,MAP regsub 4 val,15319
096,MAP regsub 1 val -nocase,4729
097,MAP regsub 2 val -nocase,9546
098,MAP regsub 3 val -nocase,12501
099,MAP regsub 4 val -nocase,14510
100,"MAP string, no match",(8.2+)
101,"MAP string -nocase, no match",(8.2+)
102,"MAP regsub, no match",3352
103,"MAP regsub -nocase, no match",4499
104,MAP string short,(8.2+)
105,MAP regsub short,244
106,PROC explicit return,11
107,PROC implicit return,16
108,PROC explicit return (2),14
109,PROC implicit return (2),21
110,PROC explicit return (3),14
111,PROC implicit return (3),10
112,PROC heavily commented,629
113,"PROC do-nothing, no args",5
114,"PROC do-nothing, one arg",15
115,PROC local links with global,7955
116,PROC local links with upvar,8371
117,PROC local links with variable,9091
118,"READ 595K, gets",978472
119,"READ 595K, read",3774669
120,"READ 595K, read & size",3696432
121,"READ 3050b, gets",2074
122,"READ 3050b, read",503
123,"READ 3050b, read & size",467
124,"BREAD 595K, gets",953379
125,"BREAD 595K, read",3640795
126,"BREAD 595K, read & size",3685978
127,"BREAD 3050b, gets",2208
128,"BREAD 3050b, read",458
129,"BREAD 3050b, read & size",390
130,REGEXP literal regexp,26
131,REGEXP var-based regexp,30
132,REGEXP count all matches,2277
133,REGEXP extract all matches,3068
134,STARTUP time to launch tclsh,70500
135,STR str [string compare],199
136,STR str [string equal],160
137,"STR str $a equal """"",670
138,"STR str num == """"",338
139,STR str $a eq $b,231
140,STR str $a ne $b,226
141,STR str $a eq $b (same obj),271
142,STR str $a ne $b (same obj),203
143,STR length (==4010),508
144,STR index 0,522
145,STR index 100,491
146,STR index 500,489
147,STR index2 0,485
148,STR index2 100,557
149,STR index2 500,764
150,STR first (success),533
151,STR first (failure),697
152,STR first (total failure),545
153,STR last (success),815
154,STR last (failure),657
155,STR last (total failure),584
156,"STR match, simple (success early)",503
157,"STR match, simple (success late)",619
158,"STR match, simple (failure)",421
159,"STR match, simple (total failure)",456
160,"STR match, complex (success early)",466
161,"STR match, complex (success late)",1529
162,"STR match, complex (failure)",1357
163,"STR match, complex (total failure)",1725
164,"STR range, index 100..200 of 4010",589
165,"STR replace, no replacement",1217
166,"STR replace, equal replacement",1560
167,"STR replace, longer replacement",1563
168,"STR repeat, abcdefghij * 10",997
169,"STR repeat, abcdefghij * 100",8488
170,"STR repeat, abcdefghij * 1000",81587
171,"STR repeat, 4010 chars * 10",11891
172,"STR repeat, 4010 chars * 100",105423
173,"STR reverse iter1, 100 chars",8459
174,"STR reverse iter1, 100 uchars",8250
175,"STR reverse iter2, 100 chars",8379
176,"STR reverse iter2, 100 uchars",9513
177,"STR reverse recur1, 100 chars",20868
178,"STR reverse recur1, 100 uchars",21634
179,"STR split, 4010 chars",4372
180,"STR split, 12000 uchars",15202
181,"STR split iter, 4010 chars",52886
182,"STR split iter, 12000 uchars",162558
183,STR append,1055
184,STR append (1KB + 1KB),236
185,STR append (10KB + 1KB),215
186,STR append (1MB + 2b * 1000),82339
187,STR append (1MB + 1KB),215
188,STR append (1MB + 1KB * 20),1551
189,STR append (1MB + 1KB * 1000),78370
190,STR append (1MB + 1MB * 3),248
191,STR append (1MB + 1MB * 5),543
192,STR append (1MB + (1b + 1K + 1b) * 100),8930
193,STR info locals match,8071
194,TRACE no trace set,42
195,TRACE read,128
196,TRACE write,78
197,TRACE unset,94
198,TRACE all set (rwu),77
199,UNSET var exists,27
200,UNSET catch var exists,61
201,UNSET catch var !exist,77
202,UNSET info check var exists,80
203,UNSET info check var !exist,73
204,UNSET nocomplain var exists,52
205,UNSET nocomplain var !exist,90
206,VAR access locally set,106
207,VAR access local proc arg,88
208,VAR access global,82
209,VAR access upvar,97
210,VAR set scalar,35
211,VAR set array element,59
212,VAR 100 'set's in array,917
213,VAR 'array set' of 100 elems,1063

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































Deleted examples/csv/Benchmark.805.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
000,VERSIONS:,1:8.0.5
001,CATCH return ok,5
002,CATCH return error,204
003,CATCH no catch used,4
004,IF if true numeric,9
005,IF elseif true numeric,11
006,IF else true numeric,11
007,IF if true num/num,9
008,IF if false num/num,9
009,IF if false al/num,17
010,IF if true al/al,169
011,IF if false al/al,60
012,IF if true al,51
013,IF elseif true al,156
014,IF else true al,51
015,SWITCH first true,73
016,SWITCH second true,62
017,SWITCH ninth true,112
018,SWITCH default true,77
019,DATA create in a list,7886
020,DATA create in an array,16792
021,DATA access in a list,7024
022,DATA access in an array,7640
023,EVAL cmd eval in list obj var,84
024,EVAL cmd eval as list,144
025,EVAL cmd eval as string,90
026,EVAL cmd and mixed lists,13914
027,EVAL list cmd and mixed lists,14703
028,EVAL list cmd and pure lists,12611
029,EXPR unbraced,331
030,EXPR braced,92
031,EXPR inline,59
032,EXPR one operand,11
033,EXPR ten operands,20
034,EXPR fifty operands,85
035,EXPR incr with incr,22
036,EXPR incr with expr,13
037,FCOPY std:      160010 bytes,26557
038,KLIST shuffle0 llength 1,367
039,KLIST shuffle0 llength 10,728
040,KLIST shuffle0 llength 100,6484
041,KLIST shuffle0 llength 1000,81157
042,KLIST shuffle0 llength 10000,1161217
043,KLIST shuffle1 llength 1,149
044,KLIST shuffle1 llength 10,634
045,KLIST shuffle1 llength 100,8576
046,KLIST shuffle1 llength 1000,1736049
047,KLIST shuffle1a llength 1,150
048,KLIST shuffle1a llength 10,910
049,KLIST shuffle1a llength 100,9480
050,KLIST shuffle1a llength 1000,95305
051,KLIST shuffle1a llength 10000,1004602
052,KLIST shuffle2 llength 1,229
053,KLIST shuffle2 llength 10,1080
054,KLIST shuffle2 llength 100,9803
055,KLIST shuffle2 llength 1000,116933
056,KLIST shuffle2 llength 10000,1304458
057,KLIST shuffle3 llength 1,170
058,KLIST shuffle3 llength 10,832
059,KLIST shuffle3 llength 100,7632
060,KLIST shuffle3 llength 1000,82985
061,KLIST shuffle3 llength 10000,1732151
062,KLIST shuffle4 llength 1,178
063,KLIST shuffle4 llength 10,876
064,KLIST shuffle4 llength 100,8278
065,KLIST shuffle4 llength 1000,80450
066,KLIST shuffle4 llength 10000,834612
067,"STR/LIST length, obj shimmer",28
068,"LIST length, pure list",18
069,STR length of a LIST,23
070,"LIST exact search, first item",32
071,"LIST exact search, middle item",38
072,"LIST exact search, last item",111
073,"LIST exact search, non-item",220
074,"LIST sorted search, first item",29
075,"LIST sorted search, middle item",40
076,"LIST sorted search, last item",121
077,"LIST sorted search, non-item",257
078,"LIST exact search, untyped item",101
079,"LIST exact search, typed item",111
080,"LIST sorted search, typed item",104
081,LIST sort,7021
082,LIST typed sort,4651
083,LIST remove first element,866
084,LIST remove middle element,876
085,LIST remove last element,879
086,LIST replace first element,917
087,LIST replace middle element,1045
088,LIST replace last element,832
089,LIST replace first el with multiple,938
090,LIST replace middle el with multiple,736
091,LIST replace last el with multiple,740
092,LIST replace range,866
093,LIST remove in mixed list,999
094,LIST replace in mixed list,925
095,LIST index first element,25
096,LIST index middle element,23
097,LIST index last element,17
098,LIST insert an item at start,805
099,LIST insert an item at middle,667
100,"LIST insert an item at ""end""",1013
101,"LIST small, early range",35
102,"LIST small, late range",38
103,"LIST large, early range",108
104,"LIST large, late range",131
105,LIST append to list,1032
106,LIST join list,1453
107,"LOOP for, iterate list",9653
108,"LOOP foreach, iterate list",3553
109,LOOP for (to 1000),4867
110,LOOP while (to 1000),4637
111,"LOOP for, iterate string",14530
112,"LOOP foreach, iterate string",8147
113,MAP string 1 val,(8.2+)
114,MAP string 2 val,(8.2+)
115,MAP string 3 val,(8.2+)
116,MAP string 4 val,(8.2+)
117,MAP string 1 val -nocase,(8.2+)
118,MAP string 2 val -nocase,(8.2+)
119,MAP string 3 val -nocase,(8.2+)
120,MAP string 4 val -nocase,(8.2+)
121,MAP regsub 1 val,1830
122,MAP regsub 2 val,4184
123,MAP regsub 3 val,6075
124,MAP regsub 4 val,8659
125,MAP regsub 1 val -nocase,2766
126,MAP regsub 2 val -nocase,5881
127,MAP regsub 3 val -nocase,8625
128,MAP regsub 4 val -nocase,11664
129,"MAP string, no match",(8.2+)
130,"MAP string -nocase, no match",(8.2+)
131,"MAP regsub, no match",1843
132,"MAP regsub -nocase, no match",3563
133,MAP string short,(8.2+)
134,MAP regsub short,154
135,MTHD direct ns proc call,7
136,MTHD imported ns proc call,7
137,MTHD interp alias proc call,9
138,MTHD indirect proc eval,72
139,MTHD indirect proc eval #2,107
140,MTHD array stored proc call,19
141,MTHD switch method call,172
142,MTHD ns lookup call,376
143,MTHD inline call,2
144,PROC explicit return,7
145,PROC implicit return,11
146,PROC explicit return (2),13
147,PROC implicit return (2),18
148,PROC explicit return (3),14
149,PROC implicit return (3),12
150,PROC heavily commented,5
151,"PROC do-nothing, no args",4
152,"PROC do-nothing, one arg",8
153,PROC local links with global,4533
154,PROC local links with upvar,2922
155,PROC local links with variable,1050
156,"READ 595K, gets",372526
157,"READ 595K, read",2936958
158,"READ 595K, read & size",124776
159,"READ 3050b, gets",954
160,"READ 3050b, read",748
161,"READ 3050b, read & size",410
162,"BREAD 595K, gets",365165
163,"BREAD 595K, read",2952787
164,"BREAD 595K, read & size",87019
165,"BREAD 3050b, gets",1062
166,"BREAD 3050b, read",412
167,"BREAD 3050b, read & size",1230
168,REGEXP literal regexp,31
169,REGEXP var-based regexp,45
170,REGEXP count all matches,1332
171,REGEXP extract all matches,1129
172,STARTUP time to launch tclsh,102877
173,STR str [string compare],26
174,STR str [string equal],38
175,"STR str $a equal """"",52
176,"STR str num == """"",52
177,STR str $a eq $b,56
178,STR str $a ne $b,47
179,STR str $a eq $b (same obj),53
180,STR str $a ne $b (same obj),57
181,STR length (==4010),17
182,STR index 0,30
183,STR index 100,43
184,STR index 500,42
185,STR index2 0,27
186,STR index2 100,26
187,STR index2 500,40
188,STR first (success),33
189,STR first (failure),117
190,STR first (total failure),57
191,STR last (success),18
192,STR last (failure),201
193,STR last (total failure),151
194,"STR match, simple (success early)",33
195,"STR match, simple (success late)",27
196,"STR match, simple (failure)",36
197,"STR match, simple (total failure)",30
198,"STR match, complex (success early)",35
199,"STR match, complex (success late)",926
200,"STR match, complex (failure)",964
201,"STR match, complex (total failure)",1216
202,"STR range, index 100..200 of 4010",25
203,"STR replace, no replacement",166
204,"STR replace, equal replacement",140
205,"STR replace, longer replacement",103
206,"STR repeat, abcdefghij * 10",199
207,"STR repeat, abcdefghij * 100",1267
208,"STR repeat, abcdefghij * 1000",12264
209,"STR repeat, 4010 chars * 10",1494
210,"STR repeat, 4010 chars * 100",69328
211,"STR reverse iter1, 100 chars",1871
212,"STR reverse iter1, 100 uchars",1864
213,"STR reverse iter2, 100 chars",2099
214,"STR reverse iter2, 100 uchars",1602
215,"STR reverse recur1, 100 chars",8470
216,"STR reverse recur1, 100 uchars",9075
217,"STR split, 4010 chars",18954
218,"STR split, 12000 uchars",60753
219,"STR split iter, 4010 chars",35962
220,"STR split iter, 12000 uchars",108683
221,STR append,164
222,STR append (1KB + 1KB),79
223,STR append (10KB + 1KB),75
224,STR append (1MB + 2b * 1000),12391
225,STR append (1MB + 1KB),68
226,STR append (1MB + 1KB * 20),270
227,STR append (1MB + 1KB * 1000),10955
228,STR append (1MB + 1MB * 3),218
229,STR append (1MB + 1MB * 5),45
230,STR append (1MB + (1b + 1K + 1b) * 100),2398
231,STR info locals match,1518
232,TRACE no trace set,27
233,TRACE read,59
234,TRACE write,55
235,TRACE unset,70
236,TRACE all set (rwu),59
237,UNSET var exists,16
238,UNSET catch var exists,20
239,UNSET catch var !exist,120
240,UNSET info check var exists,27
241,UNSET info check var !exist,17
242,UNSET nocomplain var exists,20
243,UNSET nocomplain var !exist,122
244,VAR access locally set,20
245,VAR access local proc arg,26
246,VAR access global,61
247,VAR access upvar,65
248,VAR set scalar,11
249,VAR set array element,33
250,VAR 100 'set's in array,292
251,VAR 'array set' of 100 elems,816
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































Deleted examples/csv/Benchmark.811.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
000,VERSIONS:,1:8.1.1
001,CATCH return ok,4
002,CATCH return error,54
003,CATCH no catch used,13
004,IF if true numeric,7
005,IF elseif true numeric,20
006,IF else true numeric,15
007,IF if true num/num,22
008,IF if false num/num,13
009,IF if false al/num,29
010,IF if true al/al,51
011,IF if false al/al,51
012,IF if true al,42
013,IF elseif true al,89
014,IF else true al,71
015,SWITCH first true,58
016,SWITCH second true,65
017,SWITCH ninth true,73
018,SWITCH default true,73
019,DATA create in a list,12925
020,DATA create in an array,12827
021,DATA access in a list,10386
022,DATA access in an array,6966
023,EVAL cmd eval in list obj var,40
024,EVAL cmd eval as list,88
025,EVAL cmd eval as string,79
026,EVAL cmd and mixed lists,21937
027,EVAL list cmd and mixed lists,19014
028,EVAL list cmd and pure lists,21974
029,EXPR unbraced,23
030,EXPR braced,53
031,EXPR inline,68
032,EXPR one operand,9
033,EXPR ten operands,13
034,EXPR fifty operands,71
035,EXPR incr with incr,16
036,EXPR incr with expr,11
037,FCOPY std:      160010 bytes,25104
038,FCOPY binary:   160010 bytes,25211
039,FCOPY encoding: 160010 bytes,25972
040,KLIST shuffle0 llength 1,271
041,KLIST shuffle0 llength 10,901
042,KLIST shuffle0 llength 100,8229
043,KLIST shuffle0 llength 1000,92480
044,KLIST shuffle0 llength 10000,1214997
045,KLIST shuffle1 llength 1,163
046,KLIST shuffle1 llength 10,718
047,KLIST shuffle1 llength 100,9243
048,KLIST shuffle1 llength 1000,1762135
049,KLIST shuffle1a llength 1,172
050,KLIST shuffle1a llength 10,768
051,KLIST shuffle1a llength 100,8986
052,KLIST shuffle1a llength 1000,84798
053,KLIST shuffle1a llength 10000,861405
054,KLIST shuffle2 llength 1,196
055,KLIST shuffle2 llength 10,938
056,KLIST shuffle2 llength 100,8904
057,KLIST shuffle2 llength 1000,95513
058,KLIST shuffle2 llength 10000,1176566
059,KLIST shuffle3 llength 1,217
060,KLIST shuffle3 llength 10,786
061,KLIST shuffle3 llength 100,7161
062,KLIST shuffle3 llength 1000,87353
063,KLIST shuffle3 llength 10000,1789387
064,KLIST shuffle4 llength 1,202
065,KLIST shuffle4 llength 10,837
066,KLIST shuffle4 llength 100,8572
067,KLIST shuffle4 llength 1000,82985
068,KLIST shuffle4 llength 10000,874454
069,"STR/LIST length, obj shimmer",905
070,"LIST length, pure list",21
071,STR length of a LIST,529
072,"LIST exact search, first item",17
073,"LIST exact search, middle item",46
074,"LIST exact search, last item",90
075,"LIST exact search, non-item",212
076,"LIST sorted search, first item",16
077,"LIST sorted search, middle item",42
078,"LIST sorted search, last item",84
079,"LIST sorted search, non-item",201
080,"LIST exact search, untyped item",80
081,"LIST exact search, typed item",77
082,"LIST sorted search, typed item",93
083,LIST sort,6723
084,LIST typed sort,4737
085,LIST remove first element,806
086,LIST remove middle element,692
087,LIST remove last element,689
088,LIST replace first element,722
089,LIST replace middle element,693
090,LIST replace last element,963
091,LIST replace first el with multiple,819
092,LIST replace middle el with multiple,691
093,LIST replace last el with multiple,813
094,LIST replace range,744
095,LIST remove in mixed list,833
096,LIST replace in mixed list,1054
097,LIST index first element,16
098,LIST index middle element,16
099,LIST index last element,13
100,LIST insert an item at start,775
101,LIST insert an item at middle,684
102,"LIST insert an item at ""end""",670
103,"LIST small, early range",42
104,"LIST small, late range",28
105,"LIST large, early range",54
106,"LIST large, late range",81
107,LIST append to list,917
108,LIST join list,1818
109,"LOOP for, iterate list",13766
110,"LOOP foreach, iterate list",3750
111,LOOP for (to 1000),4639
112,LOOP while (to 1000),4551
113,"LOOP for, iterate string",141594
114,"LOOP foreach, iterate string",9099
115,MAP string 1 val,9096
116,MAP string 2 val,12943
117,MAP string 3 val,12825
118,MAP string 4 val,17267
119,MAP string 1 val -nocase,17685
120,MAP string 2 val -nocase,27379
121,MAP string 3 val -nocase,35569
122,MAP string 4 val -nocase,39660
123,MAP regsub 1 val,9663
124,MAP regsub 2 val,41500
125,MAP regsub 3 val,52315
126,MAP regsub 4 val,67973
127,MAP regsub 1 val -nocase,9463
128,MAP regsub 2 val -nocase,40735
129,MAP regsub 3 val -nocase,52639
130,MAP regsub 4 val -nocase,66937
131,"MAP string, no match",14020
132,"MAP string -nocase, no match",35683
133,"MAP regsub, no match",6704
134,"MAP regsub -nocase, no match",6609
135,MAP string short,116
136,MAP regsub short,308
137,MTHD direct ns proc call,3
138,MTHD imported ns proc call,5
139,MTHD interp alias proc call,18
140,MTHD indirect proc eval,56
141,MTHD indirect proc eval #2,81
142,MTHD array stored proc call,22
143,MTHD switch method call,119
144,MTHD ns lookup call,374
145,MTHD inline call,2
146,PROC explicit return,7
147,PROC implicit return,4
148,PROC explicit return (2),13
149,PROC implicit return (2),10
150,PROC explicit return (3),4
151,PROC implicit return (3),3
152,PROC heavily commented,12
153,"PROC do-nothing, no args",38
154,"PROC do-nothing, one arg",9
155,PROC local links with global,3586
156,PROC local links with upvar,2806
157,PROC local links with variable,2614
158,"READ 595K, gets",819327
159,"READ 595K, read",227338
160,"READ 595K, read & size",242255
161,"READ 3050b, gets",4118
162,"READ 3050b, read",789
163,"READ 3050b, read & size",790
164,"BREAD 595K, gets",833500
165,"BREAD 595K, read",228963
166,"BREAD 595K, read & size",246365
167,"BREAD 3050b, gets",5220
168,"BREAD 3050b, read",1310
169,"BREAD 3050b, read & size",1144
170,REGEXP literal regexp,42
171,REGEXP var-based regexp,55
172,REGEXP count all matches,1280
173,REGEXP extract all matches,1790
174,STARTUP time to launch tclsh,85723
175,STR str [string compare],17
176,STR str [string equal],68
177,"STR str $a equal """"",81
178,"STR str num == """"",36
179,STR str $a eq $b,39
180,STR str $a ne $b,85
181,STR str $a eq $b (same obj),161
182,STR str $a ne $b (same obj),28
183,STR length (==4010),678
184,STR index 0,487
185,STR index 100,500
186,STR index 500,483
187,STR index2 0,494
188,STR index2 100,470
189,STR index2 500,484
190,STR first (success),21
191,STR first (failure),123
192,STR first (total failure),54
193,STR last (success),469
194,STR last (failure),185
195,STR last (total failure),135
196,"STR match, simple (success early)",25
197,"STR match, simple (success late)",11
198,"STR match, simple (failure)",26
199,"STR match, simple (total failure)",17
200,"STR match, complex (success early)",33
201,"STR match, complex (success late)",2173
202,"STR match, complex (failure)",1785
203,"STR match, complex (total failure)",1844
204,"STR range, index 100..200 of 4010",716
205,"STR replace, no replacement",570
206,"STR replace, equal replacement",526
207,"STR replace, longer replacement",551
208,"STR repeat, abcdefghij * 10",21
209,"STR repeat, abcdefghij * 100",120
210,"STR repeat, abcdefghij * 1000",798
211,"STR repeat, 4010 chars * 10",1971
212,"STR repeat, 4010 chars * 100",47967
213,"STR reverse iter1, 100 chars",4104
214,"STR reverse iter1, 100 uchars",4448
215,"STR reverse iter2, 100 chars",3860
216,"STR reverse iter2, 100 uchars",4086
217,"STR reverse recur1, 100 chars",8749
218,"STR reverse recur1, 100 uchars",8794
219,"STR split, 4010 chars",23626
220,"STR split, 12000 uchars",74910
221,"STR split iter, 4010 chars",39846
222,"STR split iter, 12000 uchars",122753
223,STR append,108
224,STR append (1KB + 1KB),96
225,STR append (10KB + 1KB),474
226,STR append (1MB + 2b * 1000),178639
227,STR append (1MB + 1KB),136891
228,STR append (1MB + 1KB * 20),127033
229,STR append (1MB + 1KB * 1000),177875
230,STR append (1MB + 1MB * 3),282029
231,STR append (1MB + 1MB * 5),1051814
232,STR append (1MB + (1b + 1K + 1b) * 100),290360
233,STR info locals match,2025
234,TRACE no trace set,18
235,TRACE read,16
236,TRACE write,16
237,TRACE unset,16
238,TRACE all set (rwu),18
239,UNSET var exists,8
240,UNSET catch var exists,52
241,UNSET catch var !exist,191
242,UNSET info check var exists,69
243,UNSET info check var !exist,6
244,UNSET nocomplain var exists,35
245,UNSET nocomplain var !exist,157
246,VAR access locally set,18
247,VAR access local proc arg,6
248,VAR access global,101
249,VAR access upvar,103
250,VAR set scalar,4
251,VAR set array element,9
252,VAR 100 'set's in array,296
253,VAR 'array set' of 100 elems,741
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted examples/csv/Benchmark.823.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
000,VERSIONS:,1:8.2.3
001,CATCH return ok,7
002,CATCH return error,275
003,CATCH no catch used,7
004,IF if true numeric,13
005,IF elseif true numeric,16
006,IF else true numeric,16
007,IF if true num/num,281
008,IF if false num/num,13
009,IF if false al/num,20
010,IF if true al/al,26
011,IF if false al/al,25
012,IF if true al,25
013,IF elseif true al,338
014,IF else true al,42
015,SWITCH first true,103
016,SWITCH second true,153
017,SWITCH ninth true,238
018,SWITCH default true,46
019,DATA create in a list,15014
020,DATA create in an array,19172
021,DATA access in a list,15346
022,DATA access in an array,14156
023,EVAL cmd eval in list obj var,52
024,EVAL cmd eval as list,49
025,EVAL cmd eval as string,54
026,EVAL cmd and mixed lists,32485
027,EVAL list cmd and mixed lists,40366
028,EVAL list cmd and pure lists,40115
029,EXPR unbraced,502
030,EXPR braced,29
031,EXPR inline,40
032,EXPR one operand,158
033,EXPR ten operands,97
034,EXPR fifty operands,45
035,EXPR incr with incr,10
036,EXPR incr with expr,9
037,FCOPY std:      160010 bytes,46300
038,FCOPY binary:   160010 bytes,41776
039,FCOPY encoding: 160010 bytes,44598
040,KLIST shuffle0 llength 1,554
041,KLIST shuffle0 llength 10,1592
042,KLIST shuffle0 llength 100,13565
043,KLIST shuffle0 llength 1000,164223
044,KLIST shuffle0 llength 10000,2073612
045,KLIST shuffle1 llength 1,367
046,KLIST shuffle1 llength 10,1371
047,KLIST shuffle1 llength 100,12737
048,KLIST shuffle1 llength 1000,1770024
049,KLIST shuffle1a llength 1,94
050,KLIST shuffle1a llength 10,404
051,KLIST shuffle1a llength 100,3833
052,KLIST shuffle1a llength 1000,39248
053,KLIST shuffle1a llength 10000,408005
054,KLIST shuffle2 llength 1,108
055,KLIST shuffle2 llength 10,481
056,KLIST shuffle2 llength 100,4250
057,KLIST shuffle2 llength 1000,45651
058,KLIST shuffle2 llength 10000,527055
059,KLIST shuffle3 llength 1,102
060,KLIST shuffle3 llength 10,376
061,KLIST shuffle3 llength 100,3413
062,KLIST shuffle3 llength 1000,37667
063,KLIST shuffle3 llength 10000,844383
064,KLIST shuffle4 llength 1,100
065,KLIST shuffle4 llength 10,416
066,KLIST shuffle4 llength 100,3758
067,KLIST shuffle4 llength 1000,38186
068,KLIST shuffle4 llength 10000,398724
069,"STR/LIST length, obj shimmer",2333
070,"LIST length, pure list",13
071,STR length of a LIST,12
072,"LIST exact search, first item",14
073,"LIST exact search, middle item",27
074,"LIST exact search, last item",50
075,"LIST exact search, non-item",121
076,"LIST sorted search, first item",12
077,"LIST sorted search, middle item",26
078,"LIST sorted search, last item",49
079,"LIST sorted search, non-item",122
080,"LIST exact search, untyped item",51
081,"LIST exact search, typed item",49
082,"LIST sorted search, typed item",50
083,LIST sort,3293
084,LIST typed sort,2660
085,LIST remove first element,363
086,LIST remove middle element,358
087,LIST remove last element,360
088,LIST replace first element,346
089,LIST replace middle element,353
090,LIST replace last element,346
091,LIST replace first el with multiple,372
092,LIST replace middle el with multiple,351
093,LIST replace last el with multiple,347
094,LIST replace range,343
095,LIST remove in mixed list,2195
096,LIST replace in mixed list,2184
097,LIST index first element,13
098,LIST index middle element,13
099,LIST index last element,13
100,LIST insert an item at start,366
101,LIST insert an item at middle,370
102,"LIST insert an item at ""end""",349
103,"LIST small, early range",16
104,"LIST small, late range",16
105,"LIST large, early range",24
106,"LIST large, late range",21
107,LIST append to list,396
108,LIST join list,1066
109,"LOOP for, iterate list",5372
110,"LOOP foreach, iterate list",1952
111,LOOP for (to 1000),3065
112,LOOP while (to 1000),3065
113,"LOOP for, iterate string",9637
114,"LOOP foreach, iterate string",3955
115,MAP string 1 val,6028
116,MAP string 2 val,6877
117,MAP string 3 val,7832
118,MAP string 4 val,8622
119,MAP string 1 val -nocase,10381
120,MAP string 2 val -nocase,15024
121,MAP string 3 val -nocase,18973
122,MAP string 4 val -nocase,22132
123,MAP regsub 1 val,4303
124,MAP regsub 2 val,18176
125,MAP regsub 3 val,24817
126,MAP regsub 4 val,31350
127,MAP regsub 1 val -nocase,4332
128,MAP regsub 2 val -nocase,18134
129,MAP regsub 3 val -nocase,24747
130,MAP regsub 4 val -nocase,31314
131,"MAP string, no match",8028
132,"MAP string -nocase, no match",18933
133,"MAP regsub, no match",2830
134,"MAP regsub -nocase, no match",2890
135,MAP string short,39
136,MAP regsub short,193
137,MTHD direct ns proc call,8
138,MTHD imported ns proc call,7
139,MTHD interp alias proc call,18
140,MTHD indirect proc eval,61
141,MTHD indirect proc eval #2,57
142,MTHD array stored proc call,10
143,MTHD switch method call,83
144,MTHD ns lookup call,216
145,MTHD inline call,3
146,PROC explicit return,8
147,PROC implicit return,7
148,PROC explicit return (2),8
149,PROC implicit return (2),7
150,PROC explicit return (3),7
151,PROC implicit return (3),7
152,PROC heavily commented,6
153,"PROC do-nothing, no args",28
154,"PROC do-nothing, one arg",6
155,PROC local links with global,1626
156,PROC local links with upvar,1387
157,PROC local links with variable,1334
158,"READ 595K, gets",306109
159,"READ 595K, read",97019
160,"READ 595K, read & size",97074
161,"READ 3050b, gets",2052
162,"READ 3050b, read",494
163,"READ 3050b, read & size",530
164,"BREAD 595K, gets",304961
165,"BREAD 595K, read",50018
166,"BREAD 595K, read & size",50140
167,"BREAD 3050b, gets",1774
168,"BREAD 3050b, read",334
169,"BREAD 3050b, read & size",369
170,REGEXP literal regexp,38
171,REGEXP var-based regexp,40
172,REGEXP count all matches,530
173,REGEXP extract all matches,616
174,STARTUP time to launch tclsh,18293
175,STR str [string compare],24
176,STR str [string equal],23
177,"STR str $a equal """"",24
178,"STR str num == """"",24
179,STR str $a eq $b,31
180,STR str $a ne $b,30
181,STR str $a eq $b (same obj),36
182,STR str $a ne $b (same obj),30
183,STR length (==4010),13
184,STR index 0,19
185,STR index 100,19
186,STR index 500,19
187,STR index2 0,19
188,STR index2 100,19
189,STR index2 500,19
190,STR first (success),15
191,STR first (failure),50
192,STR first (total failure),28
193,STR last (success),224
194,STR last (failure),91
195,STR last (total failure),83
196,"STR match, simple (success early)",13
197,"STR match, simple (success late)",13
198,"STR match, simple (failure)",13
199,"STR match, simple (total failure)",13
200,"STR match, complex (success early)",22
201,"STR match, complex (success late)",1040
202,"STR match, complex (failure)",1010
203,"STR match, complex (total failure)",994
204,"STR range, index 100..200 of 4010",21
205,"STR replace, no replacement",264
206,"STR replace, equal replacement",257
207,"STR replace, longer replacement",265
208,"STR repeat, abcdefghij * 10",22
209,"STR repeat, abcdefghij * 100",74
210,"STR repeat, abcdefghij * 1000",557
211,"STR repeat, 4010 chars * 10",671
212,"STR repeat, 4010 chars * 100",18194
213,"STR reverse iter1, 100 chars",1425
214,"STR reverse iter1, 100 uchars",1436
215,"STR reverse iter2, 100 chars",1168
216,"STR reverse iter2, 100 uchars",1096
217,"STR reverse recur1, 100 chars",3998
218,"STR reverse recur1, 100 uchars",4767
219,"STR split, 4010 chars",8847
220,"STR split, 12000 uchars",27293
221,"STR split iter, 4010 chars",16664
222,"STR split iter, 12000 uchars",52115
223,STR append,71
224,STR append (1KB + 1KB),49
225,STR append (10KB + 1KB),196
226,STR append (1MB + 2b * 1000),74635
227,STR append (1MB + 1KB),61479
228,STR append (1MB + 1KB * 20),61865
229,STR append (1MB + 1KB * 1000),101998
230,STR append (1MB + 1MB * 3),157370
231,STR append (1MB + 1MB * 5),315407
232,STR append (1MB + (1b + 1K + 1b) * 100),69167
233,STR info locals match,993
234,TRACE no trace set,26
235,TRACE read,26
236,TRACE write,26
237,TRACE unset,26
238,TRACE all set (rwu),25
239,UNSET var exists,9
240,UNSET catch var exists,10
241,UNSET catch var !exist,59
242,UNSET info check var exists,13
243,UNSET info check var !exist,11
244,UNSET nocomplain var exists,10
245,UNSET nocomplain var !exist,59
246,VAR access locally set,10
247,VAR access local proc arg,10
248,VAR access global,26
249,VAR access upvar,30
250,VAR set scalar,7
251,VAR set array element,14
252,VAR 100 'set's in array,160
253,VAR 'array set' of 100 elems,264
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted examples/csv/Benchmark.833.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
000,VERSIONS:,1:8.3.3
001,CATCH return ok,6
002,CATCH return error,64
003,CATCH no catch used,6
004,IF if true numeric,11
005,IF elseif true numeric,15
006,IF else true numeric,15
007,IF if true num/num,12
008,IF if false num/num,12
009,IF if false al/num,20
010,IF if true al/al,26
011,IF if false al/al,25
012,IF if true al,25
013,IF elseif true al,39
014,IF else true al,40
015,SWITCH first true,42
016,SWITCH second true,39
017,SWITCH ninth true,44
018,SWITCH default true,38
019,DATA create in a list,4083
020,DATA create in an array,4916
021,DATA access in a list,3546
022,DATA access in an array,3223
023,EVAL cmd eval in list obj var,22
024,EVAL cmd eval as list,21
025,EVAL cmd eval as string,50
026,EVAL cmd and mixed lists,3546
027,EVAL list cmd and mixed lists,3591
028,EVAL list cmd and pure lists,582
029,EXPR unbraced,167
030,EXPR braced,25
031,EXPR inline,30
032,EXPR one operand,6
033,EXPR ten operands,13
034,EXPR fifty operands,43
035,EXPR incr with incr,11
036,EXPR incr with expr,7
037,FCOPY std:      160010 bytes,10242
038,FCOPY binary:   160010 bytes,9892
039,FCOPY encoding: 160010 bytes,9831
040,KLIST shuffle0 llength 1,127
041,KLIST shuffle0 llength 10,413
042,KLIST shuffle0 llength 100,3552
043,KLIST shuffle0 llength 1000,41766
044,KLIST shuffle0 llength 10000,533804
045,KLIST shuffle1 llength 1,85
046,KLIST shuffle1 llength 10,333
047,KLIST shuffle1 llength 100,5238
048,KLIST shuffle1 llength 1000,1194146
049,KLIST shuffle1a llength 1,100
050,KLIST shuffle1a llength 10,368
051,KLIST shuffle1a llength 100,3625
052,KLIST shuffle1a llength 1000,37340
053,KLIST shuffle1a llength 10000,380522
054,KLIST shuffle2 llength 1,99
055,KLIST shuffle2 llength 10,375
056,KLIST shuffle2 llength 100,3625
057,KLIST shuffle2 llength 1000,37028
058,KLIST shuffle2 llength 10000,433771
059,KLIST shuffle3 llength 1,98
060,KLIST shuffle3 llength 10,335
061,KLIST shuffle3 llength 100,2883
062,KLIST shuffle3 llength 1000,33237
063,KLIST shuffle3 llength 10000,777699
064,KLIST shuffle4 llength 1,102
065,KLIST shuffle4 llength 10,374
066,KLIST shuffle4 llength 100,3250
067,KLIST shuffle4 llength 1000,32119
068,KLIST shuffle4 llength 10000,330472
069,"STR/LIST length, obj shimmer",2767
070,"LIST length, pure list",13
071,STR length of a LIST,12
072,"LIST exact search, first item",11
073,"LIST exact search, middle item",25
074,"LIST exact search, last item",48
075,"LIST exact search, non-item",110
076,"LIST sorted search, first item",12
077,"LIST sorted search, middle item",26
078,"LIST sorted search, last item",52
079,"LIST sorted search, non-item",111
080,"LIST exact search, untyped item",47
081,"LIST exact search, typed item",48
082,"LIST sorted search, typed item",46
083,LIST sort,3578
084,LIST typed sort,2943
085,LIST remove first element,296
086,LIST remove middle element,291
087,LIST remove last element,293
088,LIST replace first element,289
089,LIST replace middle element,286
090,LIST replace last element,283
091,LIST replace first el with multiple,304
092,LIST replace middle el with multiple,310
093,LIST replace last el with multiple,282
094,LIST replace range,282
095,LIST remove in mixed list,374
096,LIST replace in mixed list,352
097,LIST index first element,10
098,LIST index middle element,10
099,LIST index last element,11
100,LIST insert an item at start,298
101,LIST insert an item at middle,266
102,"LIST insert an item at ""end""",254
103,"LIST small, early range",19
104,"LIST small, late range",18
105,"LIST large, early range",29
106,"LIST large, late range",30
107,LIST append to list,401
108,LIST join list,1072
109,"LOOP for, iterate list",5198
110,"LOOP foreach, iterate list",1845
111,LOOP for (to 1000),2674
112,LOOP while (to 1000),2942
113,"LOOP for, iterate string",9440
114,"LOOP foreach, iterate string",2249
115,MAP string 1 val,5931
116,MAP string 2 val,6643
117,MAP string 3 val,7673
118,MAP string 4 val,8429
119,MAP string 1 val -nocase,10259
120,MAP string 2 val -nocase,14570
121,MAP string 3 val -nocase,19344
122,MAP string 4 val -nocase,21861
123,MAP regsub 1 val,3954
124,MAP regsub 2 val,16981
125,MAP regsub 3 val,23258
126,MAP regsub 4 val,29335
127,MAP regsub 1 val -nocase,3913
128,MAP regsub 2 val -nocase,17024
129,MAP regsub 3 val -nocase,23228
130,MAP regsub 4 val -nocase,29397
131,"MAP string, no match",7712
132,"MAP string -nocase, no match",18725
133,"MAP regsub, no match",2764
134,"MAP regsub -nocase, no match",2785
135,MAP string short,41
136,MAP regsub short,180
137,MTHD direct ns proc call,6
138,MTHD imported ns proc call,6
139,MTHD interp alias proc call,18
140,MTHD indirect proc eval,29
141,MTHD indirect proc eval #2,48
142,MTHD array stored proc call,9
143,MTHD switch method call,38
144,MTHD ns lookup call,81
145,MTHD inline call,3
146,PROC explicit return,7
147,PROC implicit return,6
148,PROC explicit return (2),7
149,PROC implicit return (2),6
150,PROC explicit return (3),7
151,PROC implicit return (3),6
152,PROC heavily commented,5
153,"PROC do-nothing, no args",5
154,"PROC do-nothing, one arg",5
155,PROC local links with global,1569
156,PROC local links with upvar,1166
157,PROC local links with variable,1101
158,"READ 595K, gets",299797
159,"READ 595K, read",97698
160,"READ 595K, read & size",97909
161,"READ 3050b, gets",1641
162,"READ 3050b, read",494
163,"READ 3050b, read & size",534
164,"BREAD 595K, gets",292326
165,"BREAD 595K, read",50454
166,"BREAD 595K, read & size",50486
167,"BREAD 3050b, gets",1777
168,"BREAD 3050b, read",347
169,"BREAD 3050b, read & size",389
170,REGEXP literal regexp,37
171,REGEXP var-based regexp,40
172,REGEXP count all matches,139
173,REGEXP extract all matches,177
174,STARTUP time to launch tclsh,20425
175,STR str [string compare],26
176,STR str [string equal],25
177,"STR str $a equal """"",26
178,"STR str num == """"",14
179,STR str $a eq $b,33
180,STR str $a ne $b,31
181,STR str $a eq $b (same obj),33
182,STR str $a ne $b (same obj),33
183,STR length (==4010),14
184,STR index 0,19
185,STR index 100,24
186,STR index 500,18
187,STR index2 0,19
188,STR index2 100,19
189,STR index2 500,19
190,STR first (success),16
191,STR first (failure),56
192,STR first (total failure),42
193,STR last (success),229
194,STR last (failure),99
195,STR last (total failure),90
196,"STR match, simple (success early)",14
197,"STR match, simple (success late)",14
198,"STR match, simple (failure)",15
199,"STR match, simple (total failure)",18
200,"STR match, complex (success early)",23
201,"STR match, complex (success late)",1020
202,"STR match, complex (failure)",1011
203,"STR match, complex (total failure)",994
204,"STR range, index 100..200 of 4010",21
205,"STR replace, no replacement",270
206,"STR replace, equal replacement",277
207,"STR replace, longer replacement",270
208,"STR repeat, abcdefghij * 10",22
209,"STR repeat, abcdefghij * 100",72
210,"STR repeat, abcdefghij * 1000",565
211,"STR repeat, 4010 chars * 10",797
212,"STR repeat, 4010 chars * 100",18287
213,"STR reverse iter1, 100 chars",1628
214,"STR reverse iter1, 100 uchars",1768
215,"STR reverse iter2, 100 chars",1252
216,"STR reverse iter2, 100 uchars",1259
217,"STR reverse recur1, 100 chars",4770
218,"STR reverse recur1, 100 uchars",5467
219,"STR split, 4010 chars",2138
220,"STR split, 12100 uchars",6395
221,"STR split iter, 4010 chars",9372
222,"STR split iter, 12100 uchars",28299
223,STR append,82
224,STR append (1KB + 1KB),55
225,STR append (10KB + 1KB),193
226,STR append (1MB + 2b * 1000),70498
227,STR append (1MB + 1KB),63374
228,STR append (1MB + 1KB * 20),64566
229,STR append (1MB + 1KB * 1000),94413
230,STR append (1MB + 1MB * 3),153051
231,STR append (1MB + 1MB * 5),303871
232,STR append (1MB + (1b + 1K + 1b) * 100),63834
233,STR info locals match,818
234,TRACE no trace set,25
235,TRACE read,26
236,TRACE write,25
237,TRACE unset,26
238,TRACE all set (rwu),25
239,UNSET var exists,8
240,UNSET catch var exists,9
241,UNSET catch var !exist,64
242,UNSET info check var exists,14
243,UNSET info check var !exist,11
244,UNSET nocomplain var exists,9
245,UNSET nocomplain var !exist,64
246,VAR access locally set,8
247,VAR access local proc arg,9
248,VAR access global,25
249,VAR access upvar,29
250,VAR set scalar,6
251,VAR set array element,12
252,VAR 100 'set's in array,133
253,VAR 'array set' of 100 elems,251
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted examples/csv/Benchmark.84a3.csv.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
000,VERSIONS:,1:8.4a3
001,CATCH return ok,11
002,CATCH return error,70
003,CATCH no catch used,10
004,IF if true numeric,17
005,IF elseif true numeric,20
006,IF else true numeric,20
007,IF if true num/num,17
008,IF if false num/num,17
009,IF if false al/num,27
010,IF if true al/al,31
011,IF if false al/al,31
012,IF if true al,32
013,IF elseif true al,47
014,IF else true al,46
015,SWITCH first true,63
016,SWITCH second true,58
017,SWITCH ninth true,67
018,SWITCH default true,62
019,DATA create in a list,4883
020,DATA create in an array,5388
021,DATA access in a list,4028
022,DATA access in an array,3507
023,EVAL cmd eval in list obj var,26
024,EVAL cmd eval as list,24
025,EVAL cmd eval as string,60
026,EVAL cmd and mixed lists,3347
027,EVAL list cmd and mixed lists,3403
028,EVAL list cmd and pure lists,543
029,EXPR unbraced,153
030,EXPR braced,29
031,EXPR inline,31
032,EXPR one operand,11
033,EXPR ten operands,18
034,EXPR fifty operands,48
035,EXPR incr with incr,16
036,EXPR incr with expr,11
037,FCOPY std:      160010 bytes,10069
038,FCOPY binary:   160010 bytes,9932
039,FCOPY encoding: 160010 bytes,9818
040,KLIST shuffle0 llength 1,144
041,KLIST shuffle0 llength 10,457
042,KLIST shuffle0 llength 100,3986
043,KLIST shuffle0 llength 1000,44083
044,KLIST shuffle0 llength 10000,563245
045,KLIST shuffle1 llength 1,84
046,KLIST shuffle1 llength 10,358
047,KLIST shuffle1 llength 100,6374
048,KLIST shuffle1 llength 1000,1190696
049,KLIST shuffle1a llength 1,110
050,KLIST shuffle1a llength 10,474
051,KLIST shuffle1a llength 100,4667
052,KLIST shuffle1a llength 1000,47818
053,KLIST shuffle1a llength 10000,474513
054,KLIST shuffle2 llength 1,104
055,KLIST shuffle2 llength 10,440
056,KLIST shuffle2 llength 100,3762
057,KLIST shuffle2 llength 1000,39573
058,KLIST shuffle2 llength 10000,474558
059,KLIST shuffle3 llength 1,104
060,KLIST shuffle3 llength 10,380
061,KLIST shuffle3 llength 100,3408
062,KLIST shuffle3 llength 1000,38716
063,KLIST shuffle3 llength 10000,945771
064,KLIST shuffle4 llength 1,114
065,KLIST shuffle4 llength 10,431
066,KLIST shuffle4 llength 100,3871
067,KLIST shuffle4 llength 1000,40201
068,KLIST shuffle4 llength 10000,393369
069,"STR/LIST length, obj shimmer",2390
070,"LIST length, pure list",18
071,STR length of a LIST,15
072,"LIST exact search, first item",19
073,"LIST exact search, middle item",69
074,"LIST exact search, last item",132
075,"LIST exact search, non-item",314
076,"LIST sorted search, first item",23
077,"LIST sorted search, middle item",24
078,"LIST sorted search, last item",24
079,"LIST sorted search, non-item",23
080,"LIST exact search, untyped item",131
081,"LIST exact search, typed item",128
082,"LIST sorted search, typed item",19
083,LIST sort,3299
084,LIST typed sort,2739
085,LIST remove first element,317
086,LIST remove middle element,325
087,LIST remove last element,318
088,LIST replace first element,310
089,LIST replace middle element,316
090,LIST replace last element,316
091,LIST replace first el with multiple,333
092,LIST replace middle el with multiple,319
093,LIST replace last el with multiple,319
094,LIST replace range,294
095,LIST remove in mixed list,389
096,LIST replace in mixed list,377
097,LIST index first element,18
098,LIST index middle element,17
099,LIST index last element,17
100,LIST insert an item at start,291
101,LIST insert an item at middle,269
102,"LIST insert an item at ""end""",257
103,"LIST small, early range",23
104,"LIST small, late range",23
105,"LIST large, early range",37
106,"LIST large, late range",40
107,LIST append to list,409
108,LIST join list,1053
109,"LOOP for, iterate list",6616
110,"LOOP foreach, iterate list",1919
111,LOOP for (to 1000),2566
112,LOOP while (to 1000),2568
113,"LOOP for, iterate string",6456
114,"LOOP foreach, iterate string",2240
115,MAP string 1 val,679
116,MAP string 2 val,1562
117,MAP string 3 val,1836
118,MAP string 4 val,2510
119,MAP string 1 val -nocase,3497
120,MAP string 2 val -nocase,6218
121,MAP string 3 val -nocase,8364
122,MAP string 4 val -nocase,10135
123,MAP regsub 1 val,3702
124,MAP regsub 2 val,16066
125,MAP regsub 3 val,21671
126,MAP regsub 4 val,26657
127,MAP regsub 1 val -nocase,3686
128,MAP regsub 2 val -nocase,15821
129,MAP regsub 3 val -nocase,20987
130,MAP regsub 4 val -nocase,26227
131,"MAP string, no match",926
132,"MAP string -nocase, no match",6726
133,"MAP regsub, no match",1149
134,"MAP regsub -nocase, no match",1151
135,MAP string short,37
136,MAP regsub short,164
137,MTHD direct ns proc call,10
138,MTHD imported ns proc call,11
139,MTHD interp alias proc call,25
140,MTHD indirect proc eval,36
141,MTHD indirect proc eval #2,58
142,MTHD array stored proc call,14
143,MTHD switch method call,50
144,MTHD ns lookup call,99
145,MTHD inline call,5
146,PROC explicit return,15
147,PROC implicit return,11
148,PROC explicit return (2),12
149,PROC implicit return (2),10
150,PROC explicit return (3),10
151,PROC implicit return (3),10
152,PROC heavily commented,10
153,"PROC do-nothing, no args",8
154,"PROC do-nothing, one arg",10
155,PROC local links with global,1579
156,PROC local links with upvar,1287
157,PROC local links with variable,1195
158,"READ 595K, gets",340064
159,"READ 595K, read",77751
160,"READ 595K, read & size",77606
161,"READ 3050b, gets",1869
162,"READ 3050b, read",522
163,"READ 3050b, read & size",569
164,"BREAD 595K, gets",350077
165,"BREAD 595K, read",50105
166,"BREAD 595K, read & size",50303
167,"BREAD 3050b, gets",2097
168,"BREAD 3050b, read",340
169,"BREAD 3050b, read & size",396
170,REGEXP literal regexp,39
171,REGEXP var-based regexp,41
172,REGEXP count all matches,137
173,REGEXP extract all matches,169
174,STARTUP time to launch tclsh,21138
175,STR str [string compare],18
176,STR str [string equal],18
177,"STR str $a equal """"",17
178,"STR str num == """"",19
179,STR str $a eq $b,22
180,STR str $a ne $b,23
181,STR str $a eq $b (same obj),22
182,STR str $a ne $b (same obj),21
183,STR length (==4010),15
184,STR index 0,26
185,STR index 100,21
186,STR index 500,21
187,STR index2 0,21
188,STR index2 100,20
189,STR index2 500,21
190,STR first (success),19
191,STR first (failure),120
192,STR first (total failure),109
193,STR last (success),19
194,STR last (failure),90
195,STR last (total failure),82
196,"STR match, simple (success early)",17
197,"STR match, simple (success late)",16
198,"STR match, simple (failure)",17
199,"STR match, simple (total failure)",16
200,"STR match, complex (success early)",17
201,"STR match, complex (success late)",145
202,"STR match, complex (failure)",122
203,"STR match, complex (total failure)",90
204,"STR range, index 100..200 of 4010",26
205,"STR replace, no replacement",79
206,"STR replace, equal replacement",92
207,"STR replace, longer replacement",95
208,"STR repeat, abcdefghij * 10",19
209,"STR repeat, abcdefghij * 100",39
210,"STR repeat, abcdefghij * 1000",245
211,"STR repeat, 4010 chars * 10",314
212,"STR repeat, 4010 chars * 100",7347
213,"STR reverse iter1, 100 chars",1285
214,"STR reverse iter1, 100 uchars",1264
215,"STR reverse iter2, 100 chars",808
216,"STR reverse iter2, 100 uchars",807
217,"STR reverse recur1, 100 chars",4092
218,"STR reverse recur1, 100 uchars",4169
219,"STR split, 4010 chars",2663
220,"STR split, 12100 uchars",7207
221,"STR split iter, 4010 chars",9349
222,"STR split iter, 12100 uchars",28171
223,STR append,100
224,STR append (1KB + 1KB),65
225,STR append (10KB + 1KB),186
226,STR append (1MB + 2b * 1000),37786
227,STR append (1MB + 1KB),29729
228,STR append (1MB + 1KB * 20),29635
229,STR append (1MB + 1KB * 1000),66605
230,STR append (1MB + 1MB * 3),126103
231,STR append (1MB + 1MB * 5),157407
232,STR append (1MB + (1b + 1K + 1b) * 100),33118
233,STR info locals match,828
234,TRACE no trace set,35
235,TRACE read,35
236,TRACE write,35
237,TRACE unset,35
238,TRACE all set (rwu),35
239,UNSET var exists,14
240,UNSET catch var exists,16
241,UNSET catch var !exist,69
242,UNSET info check var exists,19
243,UNSET info check var !exist,16
244,UNSET nocomplain var exists,14
245,UNSET nocomplain var !exist,14
246,VAR access locally set,14
247,VAR access local proc arg,14
248,VAR access global,34
249,VAR access upvar,36
250,VAR set scalar,10
251,VAR set array element,18
252,VAR 100 'set's in array,162
253,VAR 'array set' of 100 elems,293
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted examples/csv/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Here are some applications for handling and manipulating CSV files in
various ways. Provided are:
=======================================================================

csv2html ?-sep sepchar? ?-title string? file...

	Reads CSV data from the files and returns it as a HTML table
	on stdout.

=======================================================================

csvsort ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|-

	Like "sort", but for CSV files. Sorts after the specified
	column. Input and output are from and to a file or stdin
	and stdout (Any combination is possible).

	Options:

	-sep	specifies the separator character used in the input file.
		Default is comma.

	-n	If specified integer sorting is used.
	-f	If specified floating point sorting is used.
		(-n and -f exclude each other. If both are used the
		last option decides the mode).

	-r	If specified reverse sorting is used (largest first)

	-skip	If specified that number of rows is skipped at the beginning,
		i.e. excluded from sorting. This is to allow sorting of
		CSV files with header lines.

=======================================================================

csvcut  ?-sep sepchar? LIST file...

	Like "cut", but for CSV files. Print selected parts of CSV
	records from each FILE to standard output.

	LIST is a comma separated list of column specifications. The
	allowed forms are:

	N	numeric specification of single column
	N-M	range specification, both parts numberic,
		N < M required.
	-M	See N-M, N defaults to 0.
	N-	See N-M, M defaults to last column

	If there are no files or file = "-" read from stdin.

=======================================================================

csvuniq ?-sep sepchar? column file.in|- file.out|-

	Like "uniq", but for CSV files. Uniq's the specified column.
	Writes the first record it encounters for a value. Input and
	output are from and to a file or stdin and stdout (Any
	combination is possible).

	Options:

	-sep	specifies the separator character used in the input file.
		Default is comma.

=======================================================================

csvjoin ?-sep sepchar? ?-outer? keycol1 file1.in keycol2 file2.in file.out|-

	Joins the two CSV inputtables using the specified columns as
	keys to compare and associate. The result will contain all
	columns from both files with the exception of the second key
	column (the result needs only one key column, the other is
	identical by definition and therefore superfluous).

	Options:

	-sep	specifies the separator character used in the input file.
		Default is comma.

	-outer	Flag, perform outer join. Means that if the key is
		missing in file2 a record is nevertheless written,
		extended with empty values.

=======================================================================
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































Deleted examples/csv/bench_join.

1
2
3
4
5
6
7
8
9
10
11

./csvcut '1-' Benchmark.833.csv  > tmp.csv ; ./csvjoin -outer 1 Benchmark.84a3.csv 0 tmp.csv tmp1.csv
./csvcut '1-' Benchmark.823.csv  > tmp.csv ; ./csvjoin -outer 1 tmp1.csv           0 tmp.csv tmp2.csv
./csvcut '1-' Benchmark.811.csv  > tmp.csv ; ./csvjoin -outer 1 tmp2.csv           0 tmp.csv tmp1.csv
./csvcut '1-' Benchmark.805.csv  > tmp.csv ; ./csvjoin -outer 1 tmp1.csv           0 tmp.csv tmp2.csv
./csvcut '1-' Benchmark.76p2.csv > tmp.csv ; ./csvjoin -outer 1 tmp2.csv           0 tmp.csv tmp1.csv
./csvcut '1-' Benchmark.75p2.csv > tmp.csv ; ./csvjoin -outer 1 tmp1.csv           0 tmp.csv Bench.csv

rm -f tmp.csv tmp1.csv tmp2.csv

./csv2html -title 'Core Benchmark Results' Bench.csv > Bench.html
<
<
<
<
<
<
<
<
<
<
<






















Deleted examples/csv/csv2html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
#!/bin/sh
# use -*- tcl -*- \
exec tclsh "$0" "$@"
# Generate HTML table from CSV data

package require csv
package require cmdline
package require report
package require struct

# ----------------------------------------------------
# csv2html ?-sep sepchar? file...
#
# Argument processing and checks.

set sepChar ,
set title   "Title"
set usage "Usage: $argv0 ?-sep sepchar? ?-title string? file..."

while {[set ok [cmdline::getopt argv {sep.arg title.arg} opt val]] > 0} {
    #puts stderr "= $opt $val"
    switch -exact -- $opt {
	sep   {set sepChar $val}
	title {set title   $val}
    }
}
if {($ok < 0) || ([llength $argv] < 1)} {
    #puts stderr "A >>$ok<< >>[llength $argv]<<"
    puts stderr $usage
    exit -1
}

set files $argv

if {[llength $files] == 0} {
    set files -
}

# ----------------------------------------------------
# Actual processing, uses the following information from the
# commandline:
#
# files   - name of the files to read
# indices - preprocessed indices
# sepChar - separator character

::report::defstyle html {} {
    set c  [columns]
    set cl $c ; incr cl -1
    data set "<tr> [split [string repeat " " $cl] ""] </tr>"
    for {set col 0} {$col < $c} {incr col} {
	pad $col left  "<td>"
	pad $col right "</td>"
    }
    return
}

set stdin 1
set first 1

struct::matrix::matrix m

foreach f $files {
    if {![string compare $f -]} {
	if {!$stdin} {
	    puts stderr "Cannot use - (stdin) more than once"
	    exit -1
	}
	set in stdin
	set stdin 0
    } else {
	set in [open $f r]
    }

    if {$first} {
	set first 0
	if {[gets $in line] < 0} {
	    continue
	}
	set data [::csv::split $line $sepChar]

	m add columns [llength $data]
	m add row $data
    }

    csv::read2matrix $in m $sepChar

    if {[string compare $f -]} {
	close $in
    }
}

# And writing the accumulated results

report::report r [m columns] style html

puts stdout "<html><head><title>$title</title></head><body>"
puts stdout "<h1>$title</h1>"
puts stdout "<p><table border=1>"
r printmatrix2channel m stdout
#m format 2chan r stdout
puts stdout "</table></p></body></html>"
r destroy

exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































Deleted examples/csv/csvcut.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
#!/bin/sh
# use -*- tcl -*- \
exec tclsh "$0" "$@"
# Cut and reorder fields in a CSV file.

package require csv
package require cmdline

# ----------------------------------------------------
# csvcut ?-sep sepchar? LIST file...
#
# Argument processing and checks.

set sepChar ,
set usage "Usage: $argv0 ?-sep sepchar? LIST file...\n\tLIST=idx,...\n\tidx in \{n, -m, n-, n-m\}"

while {[set ok [cmdline::getopt argv {sep.arg} opt val]] > 0} {
    #puts stderr "= $opt $val"
    switch -exact -- $opt {
	sep  {set sepChar $val}
    }
}
if {($ok < 0) || ([llength $argv] < 2)} {
    #puts stderr "A >>$ok<< >>[llength $argv]<<"
    puts stderr $usage
    exit -1
}

set indices [split [lindex $argv 0] ,]
set files   [lrange $argv 1 end]

if {[llength $indices] == 0} {
    #puts stderr >>$indices<<
    #puts stderr B
    puts stderr $usage
    exit -1    
}

set idx [list]
foreach i $indices {
    if {[regexp -- {[0-9]+-[0-9]+} $i]} {
	foreach {f t} [split $i -] break
	lappend idx [list $f $t]
    } elseif {[regexp -- {[0-9]+-} $i]} {
	foreach {f t} [split $i -] break
	lappend idx [list $f end]
    } elseif {[regexp -- {-[0-9]+} $i]} {
	foreach {f t} [split $i -] break
	lappend idx [list 0 $t]
    } elseif {[regexp -- {[0-9]+} $i]} {
	lappend idx [list $i $i]
    } else {
	#puts stderr >>$idx<<
	#puts stderr C
	puts stderr $usage
	exit -1
    }
}
set indices $idx

if {[llength $files] == 0} {
    set files -
}

# ----------------------------------------------------
# Actual processing, uses the following information from the
# commandline:
#
# files   - name of the files to read
# indices - preprocessed indices
# sepChar - separator character

set stdin 1
foreach f $files {
    if {![string compare $f -]} {
	if {!$stdin} {
	    puts stderr "Cannot use - (stdin) more than once"
	    exit -1
	}
	set in stdin
	set stdin 0
    } else {
	set in [open $f r]
    }

    while {![eof $in]} {
	if {[gets $in line] < 0} {
	    continue
	}
	set data [::csv::split $line $sepChar]

	set dataOut [list]

	foreach i $indices {
	    foreach {f t} $i break
	    eval lappend dataOut [lrange $data $f $t]
	}
	puts stdout [::csv::join $dataOut $sepChar]
    }
    if {[string compare $f -]} {
	close $in
    }
}

exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































Deleted examples/csv/csvdiff.

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

package require csv
package require cmdline

# ----------------------------------------------------
# csvdiff ?-sep sepchar? ?-key LIST? file1 file2
#
# Argument processing and checks.

set sepChar ,
set usage   "Usage: $argv0 ?-n? ?-sep sepchar? ?-key LIST? file1 file2\n\tLIST=idx,...\n\tidx in \{n, -m, n-, n-m\}"
set keySpec "0-"

# lineout = boolean flag, indicates if linenumbers has to be written
# as part of the output (1) or not (0). Defaults to 0.

set lineout 0
while {[set ok [cmdline::getopt argv {sep.arg key.arg n} opt val]] > 0} {
    #puts stderr "= $opt $val"
    switch -exact -- $opt {
	sep   {set sepChar $val}
	key   {set keySpec $val}
	n     {set lineout 1}
    }
}
if {($ok < 0) || ([llength $argv] != 2)} {
    puts stderr $usage
    exit -1
}

foreach {fileA fileB} $argv break


if {[llength $keySpec] == 0} {
    #puts stderr >>$keySpec<<
    #puts stderr B
    puts stderr $usage
    exit -1    
}

set idx [list]
foreach i $keySpec {
    if {[regexp -- {[0-9]+-[0-9]+} $i]} {
	foreach {f t} [split $i -] break
	lappend idx [list $f $t]
    } elseif {[regexp -- {[0-9]+-} $i]} {
	foreach {f t} [split $i -] break
	lappend idx [list $f end]
    } elseif {[regexp -- {-[0-9]+} $i]} {
	foreach {f t} [split $i -] break
	lappend idx [list 0 $t]
    } elseif {[regexp -- {[0-9]+} $i]} {
	lappend idx [list $i $i]
    } else {
	#puts stderr >>$idx<<
	#puts stderr C
	puts stderr $usage
	exit -1
    }
}
set keySpec $idx


set inA [open $fileA r]
set inB [open $fileB r]

# ----------------------------------------------------
# Actual processing, uses the following information from the
# commandline:
#
# inA     - channel for input A
# inB     - channel for input B
# sepChar - separator character

# We read file2 completely and then go through the records of
# file1. For any record we don't find we write a "deleted" record. If
# we find the matching record we remove it from the internal
# storage. In a second sweep through the internal array we write
# "added" records for the remaining data as that was not in file1 but
# is in file2.

proc keyof {data} {
    global keySpec
    set key [list]
    foreach i $keySpec {
	foreach {f t} $i break
	eval lappend key [lrange $data $f $t]
    }
    return $key
}



set order [list]
array set map {}
set linenum 0
while {![eof $inB]} {
    if {[gets $inB line] < 0} {
	continue
    }
    incr linenum
    set  data [::csv::split $line $sepChar]
    set  key  [keyof $data]

    if {[info exist map($key)]} {
	puts stderr "warning: $key occurs multiple times in $fileB (lines $linenum and $map($key))"
    }
    set map($key) $linenum
    lappend order $data
}
close $inB

set linenum 0

if {$lineout} {
    array set lmap {}
}

while {![eof $inA]} {
    if {[gets $inA line] < 0} {
	continue
    }
    incr linenum
    set  data [::csv::split $line $sepChar]
    set  key  [keyof $data]

    if {$lineout} {set lmap($key) $linenum}

    if {[info exists map($key)]} {
	if {$map($key) < 0} {
	    puts stderr "warning: $key occurs multiple times\
		    in $fileA (lines $linenum and [expr {-$map($key)}]"
	} else {
	    set map($key) [expr {-$linenum}]
	}
	continue
    }

    if {$lineout} {
	puts stdout [::csv::join [linsert $data 0 - $linenum] $sepChar]
    } else {
	puts stdout [::csv::join [linsert $data 0 -] $sepChar]
    }
}
close $inA

foreach data $order {
    set key [keyof $data]
    if {$map($key) > 0} {
	if {$lineout} {
	    puts stdout [::csv::join [linsert $data 0 + $lmap($key)] $sepChar]
	} else {
	    puts stdout [::csv::join [linsert $data 0 +] $sepChar]
	}
    }
}

exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































Deleted examples/csv/csvjoin.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
#!/bin/sh
# use -*- tcl -*- \
exec tclsh "$0" "$@"
# Join two CSV files by key

package require csv
package require cmdline

# ----------------------------------------------------
# csvuniq ?-sep sepchar? keycol1 file1.in keycol2 file2.in file.out|-
#
# Argument processing and checks.

set sepChar ,
set outer 0

set usage "Usage: $argv0 ?-sep sepchar? ?-outer? key1 file1.in key2 file2.in file.out|-"

while {[set ok [cmdline::getopt argv {sep.arg outer} opt val]] > 0} {
    #puts stderr "= $opt $val"
    switch -exact -- $opt {
	sep   {set sepChar $val}
	outer {set outer 1}
    }
}
if {($ok < 0) || ([llength $argv] != 5)} {
    puts stderr $usage
    exit -1
}

foreach {keyA inA keyB inB out} $argv break

if {
    ![string is integer $keyA] ||
    ($keyA < 0)                ||
    ![string is integer $keyB] ||
    ($keyB < 0)                ||
    ![string compare $inA  ""] ||
    ![string compare $inB  ""] ||
    ![string compare $out ""]
} {
    puts stderr $usage
    exit -1    
}

if {![string compare $out -]} {
    set out stdout
} else {
    set out [open $out w]
}

set inA [open $inA r]
set inB [open $inB r]

# ----------------------------------------------------
# Actual processing, uses the following information from the
# commandline:
#
# inA     - channel for input A
# inB     - channel for input B
# out     - channel for output
# sepChar - separator character
# keyA    - key column in A
# keyB    - key column in B

# 1. Read input B completely into an array indexed by the contents of
#    the key column. Store only the non-key information of input
#    B. Note that B may contain several lines having the same key.
#
# 2. Read input A line by line and match its key information against
#    the array. If there is no match ignore the record, else join the
#    record with all records from the array and write the resulting
#    records into the output.

set bwidth 0

array set map {}
while {![eof $inB]} {
    if {[gets $inB line] < 0} {
	continue
    }

    set data [::csv::split $line $sepChar]
    set key  [lindex   $data $keyB]
    set data [lreplace $data $keyB $keyB]

    if {[info exists map($key)]} {
	lappend map($key) $data
    } else {
	set map($key) [list $data]
    }
    set bwidth [llength $data]
}
close $inB

while {![eof $inA]} {
    if {[gets $inA line] < 0} {
	continue
    }
    set data [::csv::split $line $sepChar]
    set key  [lindex   $data $keyA]

    if {[info exists map($key)]} {
	foreach record $map($key) {
	    set res $data
	    eval lappend res $record
	    puts $out [::csv::join $res $sepChar]
	}
    } elseif {$outer} {
	# Nothing was found, but an outer join was requested too =>
	# append 'bwidth' empty cells to the data and write the new
	# record.

	for {set i 0} {$i < $bwidth} {incr i} {
	    lappend data {}
	}

	puts $out [::csv::join $data $sepChar]
    }
}

exit ; # automatically closes the channels
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































Deleted examples/csv/csvsort.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
#!/bin/sh
# use -*- tcl -*- \
exec tclsh "$0" "$@"
# Sort CSV data by a column

package require csv
package require cmdline

# ----------------------------------------------------
# csvsort ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|-
#
# Argument processing and checks.

set sepChar ,
set sortmode ascii
set order    increasing
set reverse  0
set skip     0

set usage "Usage: $argv0 ?-sep sepchar? ?-f? ?-n? ?-r? ?-skip cnt? column file.in|- file.out|-"

while {[set ok [cmdline::getopt argv {sep.arg f n r skip.arg} opt val]] > 0} {
    #puts stderr "= $opt $val"
    switch -exact -- $opt {
	sep  {set sepChar $val}
	n    {set sortmode integer}
	f    {set sortmode real}
	r    {set order    decreasing}
	skip {set skip    $val}
    }
}
if {($ok < 0) || ([llength $argv] != 3)} {
    puts stderr $usage
    exit -1
}

foreach {sortCol in out} $argv break

if {
    ![string is integer $sortCol] ||
    ($sortCol < 0)                ||
    ![string compare $in  ""]     ||
    ![string compare $out ""]
} {
    puts stderr $usage
    exit -1    
}

if {![string compare $in -]} {
    set in stdin
} else {
    set in [open $in r]
}
if {![string compare $out -]} {
    set out stdout
} else {
    set out [open $out w]
}

# ----------------------------------------------------
# Actual processing, uses the following information from the
# commandline:
#
# in      - channel for input
# out     - channel for output
# sepChar - separator character
# sortCol - column to sort after
# sortmode - Sort integer (1) or string (0)
# reverse - Sort ascending (0) or descending (1)
# skip    - Skip that many lines at the beginning.

set data [list]

while {![eof $in]} {
    if {[gets $in line] < 0} {
	continue
    }
    if {$skip > 0} {
	puts $out $line
	incr skip -1
	continue
    }
    lappend data [::csv::split $line $sepChar]
}

#puts stderr $sortmode,$order

set data [lsort -index $sortCol -$order -$sortmode $data]

foreach item $data {
    puts $out [::csv::join $item $sepChar]
}

exit ; # automatically closes the channels

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































Deleted examples/csv/csvuniq.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
#!/bin/sh
# use -*- tcl -*- \
exec tclsh "$0" "$@"
# Make CSV data the specified column unique.

package require csv
package require cmdline

# ----------------------------------------------------
# csvuniq ?-sep sepchar? column file.in|- file.out|-
#
# Argument processing and checks.

set sepChar ,

set usage "Usage: $argv0 ?-sep sepchar? column file.in|- file.out|-"

while {[set ok [cmdline::getopt argv {sep.arg} opt val]] > 0} {
    #puts stderr "= $opt $val"
    switch -exact -- $opt {
	sep  {set sepChar $val}
    }
}
if {($ok < 0) || ([llength $argv] != 3)} {
    puts stderr $usage
    exit -1
}

foreach {uniCol in out} $argv break

if {
    ![string is integer $uniCol] ||
    ($uniCol < 0)                ||
    ![string compare $in  ""]     ||
    ![string compare $out ""]
} {
    puts stderr $usage
    exit -1    
}

if {![string compare $in -]} {
    set in stdin
} else {
    set in [open $in r]
}
if {![string compare $out -]} {
    set out stdout
} else {
    set out [open $out w]
}

# ----------------------------------------------------
# Actual processing, uses the following information from the
# commandline:
#
# in      - channel for input
# out     - channel for output
# sepChar - separator character
# uniCol  - column to make unique

set last ""
set first 1

while {![eof $in]} {
    if {[gets $in line] < 0} {
	continue
    }

    set data [::csv::split $line $sepChar]

    if {$first} {
	set first 0
	set last  [lindex $data $uniCol]
	puts $out [::csv::join $data $sepChar]
    } elseif {[string compare $last [lindex $data $uniCol]] != 0} {
	set last  [lindex $data $uniCol]
	puts $out [::csv::join $data $sepChar]
    } ; # else {no change in column, ignore record}
}

exit ; # automatically closes the channels
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































Deleted examples/dns/tk_sample.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
# tk-sample.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# Derived from Neil Madden's browser sig :)
#
# Note that this doesn't work for sites using virtual hosting and is dubious for
# multi-homed sites too. This is only to illustrate the resolver usage. What we
# should be doing is connecting a socket to the resolved address and then requesting
# the original URL. Useless if there is a proxy between you as well.
#
# $Id: tk_sample.tcl,v 1.1 2002/03/02 01:54:21 patthoyts Exp $

package require Tkhtml
package require http
package require dns

set Sample(URL) http://mini.net/tcl/976.html
set Sample(nameserver) localhost

# Description:
#  Construct a simple web browser interface.
#
proc gui {} {
    frame .f -bd 0 -relief flat
    label .f.l1 -text "Nameserver" -underline 0
    entry .f.e1 -textvariable ::Sample(nameserver)
    label .f.l2 -text "URL" -underline 0
    entry .f.e2 -textvariable ::Sample(URL)
    button .f.b -text Go -underline 0 -command {get $::Sample(URL)}
    button .f.x -text Exit -underline 1 -command {bye}
    
    scrollbar .v -orient v -command {.h yv}
    html .h -yscrollcommand {.v set}
    
    pack .f.l1 -side left -fill y
    pack .f.e1 -side left -fill both -expand 1
    pack .f.x -side right -fill y
    pack .f.b -side right -fill y
    pack .f.l2 -side left -fill y
    pack .f.e2 -side right -fill both -expand 1

    pack .f -side top -fill x
    pack .v -side right -fill y
    pack .h -fill both -expand 1
    
    bind .h.x <1> {eval get [.h href %x %y]}
}

proc bye {} {
    destroy .f .v .h
}

proc bgerror {args} {
}

# Description:
#  Rewrite the URL by looking up the domain name and replacing with the 
#  IP address.
#
proc resolve {url} {
    global Sample
    if {![catch {array set URL [uri::split $url]} msg]} {
        set tok [dns::resolve $URL(host) -server $Sample(nameserver)]
        if {[dns::status $tok] == "ok"} {
            set URL(host) [dns::address $tok]
            set url [eval uri::join [array get URL]]
        }
        dns::cleanup $tok
    }
    log::log debug "resolved to $url"
    return $url
}

# Description:
#  Fetch an HTTP URL and display.
#
proc get {url} {
    global Sample
    set url [resolve $url]
    set Sample(URL) $url
    set tok [http::geturl $url -headers $::auth]
    .h clear
    .h parse [http::data $tok]
    http::cleanup $tok
    .h configure -base $url
}

gui
get $::Sample(URL)
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































Deleted examples/doctools/doctools.idx.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
[index_begin tcllib/doctools {Documentation tools}]
 [key HTML]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
  [manpage mpexpand mpexpand]
 [key TMML]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
  [manpage mpexpand mpexpand]
 [key conversion]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
  [manpage mpexpand mpexpand]
 [key documentation]
  [manpage doctools {doctools package}]
  [manpage dtformatter {doctools formatter}]
 [key index]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtocformat {doctoc format}]
 [key interface]
  [manpage didxengine {docidx engine}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
 [key manpage]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
  [manpage mpexpand mpexpand]
 [key markup]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
  [manpage mpexpand mpexpand]
 [key nroff]
  [manpage didxengine {docidx engine}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtformatter {doctools formatter}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
  [manpage mpexpand mpexpand]
 [key {table of contents}]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
 [key toc]
  [manpage didxformat {docidx format}]
  [manpage doctools {doctools package}]
  [manpage dtformat {doctools format}]
  [manpage dtocengine {doctoc engine}]
  [manpage dtocformat {doctoc format}]
[index_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































Deleted examples/doctools/doctools.toc.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
[toc_begin tcllib/doctools {Documentation tools}]
[division_start {Basic format}]
[item dtformat    dtformat     {doctools format specification}]
[item dtformatter dtformatter  {doctools engine interface}]
[item doctools    doctools     {Package to handle doctools input and engines}]
[division_end]
[division_start {Table of Contents}]
[item dtocformat    dtocformat    {doctoc format specification}]
[item dtocformatter dtocformatter {doctoc engine interface}]
[item doctoc        doctoc        {Package to handle doctoc input and engines}]
[division_end]
[division_start {Indices}]
[item dtidxformat    dtidxformat    {docindex format specification}]
[item dtidxformatter dtidxformatter {docindex engine interface}]
[item docindex       docindex       {Package to handle docindex input and engines}]
[division_end]
[division_start {Test}]
[division_start {Test2}]
[item dtidxformat    dtidxformat    {docindex format specification}]
[division_end]
[division_start {Test3}]
[item dtidxformatter dtidxformatter {docindex engine interface}]
[division_end]
[division_end]
[division_start {Test}]
[division_start {Test2}]
[item AAAAAAA  AA    AA]
[division_end]
[division_start {Test3}]
[item BBBBBBB  BB    BB]
[division_end]
[division_end]
[division_start {Test4}]
[item CCCCCCC  CC    CC]
[division_end]
[toc_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































Deleted examples/ftp/ChangeLog.

1
2
3
4
2002-02-14  Andreas Kupries  <[email protected]>

	* hpupdate.tcl: Frink run.

<
<
<
<








Deleted examples/ftp/README.

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

Example #1 - Directory Mirror	(mirror.tcl)
-----------------------------

The script mirror.tcl is used to mirror a complete remote directory
structure. It creates an exact copy of this structure on the locale
machine. Three parameters needs to be modified to work properly, 
the hostname of the remote server, the username and the password 
for login. 


Example #2 - Software Update	(newer.tcl)
----------------------------

The script newer.tcl is used to detect whether a new release of
Brent Welch's phantastic tcl-httpd is present at scriptics ftp
server. If ftp::Newer detects a newer file then it causes the
upload process and sends me (as root) an email to inform about. 
The file name for the remote copy of tclhttpd may have changed,
and the script needs a local copy of tclhttpd's source to do
the comparison.

Example #3 - Homepage Update	(hpupdate.tcl)
----------------------------

Quite a few people must have to keep permanent updating their
homepages on a ISP server. hpupdate.tcl is a tk-program for
the interactive comparsion of the homepage directory on the local
computer with the same directories on the remote homepage server. 

It is based on File Transfer Protocol. This process can be automated
easily by hpupdate. It makes it quick and easy to keep the track of
new/old or changed files.

Brief overview: 

     - FTP connection to remote server
     - Processing subdirectories 
     - Display of summary used and selected disk space 
     - Automatically all superfluous directories/files of remote
       homepage server will be deleted 
     - Automatically all new/updated files will be uploaded 
     - Tested under Linux, should also run without problems under
       Windows 95/NT and on Macintosh computers 

Example #4 - TkCon command line ftp client
------------------------------------------

Loading the ftp Library Package into Jeffrey Hobbs' TkCon rovides
a simple ftp command line utility with command history. TkCon is a
replacement for the standard console that comes with Tk. It must be
started with the "package" option: 

      tkcon -package ftp

to load ftp automatically. TkCon is available at

	http://www.purl.org/net/hobbs/tcl/script/tkcon
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































Deleted examples/ftp/ftpdemo.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
#!/bin/sh
# the next line restarts using wish \
exec wish8.3 "$0" "$@"
#
#   - simple tcl/tk test script for FTP library package -
#
#   Required:	tcl/tk8.3
#
#   Created:	07/97 
#   Changed:	07/00 
#   Version:    1.1
#
#   Copyright (C) 1997,1998 Steffen Traeger
#	EMAIL:	[email protected]
#	URL:	http://home.t-online.de/home/Steffen.Traeger
#
#   This program is free software; you can redistribute it and/or 
#   modify it. 
#   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.
#
########################################################################

package require Tcl 8
package require Tk
package require ftp 2.0

# set palette under X
if { [string range [winfo server .] 0 0] == "X" } {
	option add *background			LightGray
	tk_setPalette LightGray
	option add *Text.foreground		black
	option add *Text.background		[option get . selectBackground Listbox]
	option add *Listbox.background		[option get . selectBackground Listbox]
	option add *Listbox.selectBackground 	[option get . insertBackground Listbox]
	option add *Listbox.selectForeground  	white    
	option add *Entry.background		[option get . selectBackground Listbox]
	option add *Entry.selectBackground 	[option get . insertBackground Listbox]
	option add *Entry.selectForeground  	white
	option add *borderWidth			2
} else {
	option add *Checkbutton.borderWidth	0
	option add *Radiobutton.borderWidth	0

}   

# main window
wm title . "ftp Test"
wm iconname . ftptest
wm minsize . 1 1

# split area
frame .msg -bd 1 -relief raised
  pack .msg -in . -side top -fill both -expand 1
frame .op -bd 1 -relief raised
  pack .op -in . -side top -fill x
frame .but -bd 1 -relief raised
  pack .but -in . -side top -fill both -expand 1
  
####################################################################
# Frame 1
#
# Options
frame .op.f -bd 3
  pack .op.f -in .op -side top -fill x
  
### options   
frame .op.f.f1 -bd 3
  pack .op.f.f1 -in .op.f -side left -fill both
label .op.f.f1.l -bd 2 -text "Server Options: " -relief flat -anchor w
  pack .op.f.f1.l -in .op.f.f1 -side top -fill x

frame .op.f.f1.server -bd 2
  pack .op.f.f1.server -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.server.l -text "Host: " -width 10 -relief flat -anchor w
  pack .op.f.f1.server.l -in .op.f.f1.server -side left -fill x
entry .op.f.f1.server.e -width 20
  pack .op.f.f1.server.e -in .op.f.f1.server -side left -fill x

frame .op.f.f1.port -bd 2
  pack .op.f.f1.port -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.port.l -text "Port: " -width 10 -relief flat -anchor w
  pack .op.f.f1.port.l -in .op.f.f1.port -side left -fill x
entry .op.f.f1.port.e -width 5
  pack .op.f.f1.port.e -in .op.f.f1.port -side left -fill x

frame .op.f.f1.username -bd 2
  pack .op.f.f1.username -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.username.l -text "Username: " -width 10 -relief flat -anchor w
  pack .op.f.f1.username.l -in .op.f.f1.username -side left -fill x
entry .op.f.f1.username.e -width 10
  pack .op.f.f1.username.e -in .op.f.f1.username -side left -fill x

frame .op.f.f1.password -bd 2
  pack .op.f.f1.password -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.password.l -text "Password: " -width 10 -relief flat -anchor w
  pack .op.f.f1.password.l -in .op.f.f1.password -side left -fill x
entry .op.f.f1.password.e -width 10 -show "*"
  pack .op.f.f1.password.e -in .op.f.f1.password -side left -fill x

frame .op.f.f1.directory -bd 2
  pack .op.f.f1.directory -in .op.f.f1 -side top -fill x -padx 15
label .op.f.f1.directory.l -text "Directory: " -width 10 -relief flat -anchor w
  pack .op.f.f1.directory.l -in .op.f.f1.directory -side left -fill x
entry .op.f.f1.directory.e -width 20
  pack .op.f.f1.directory.e -in .op.f.f1.directory -side left -fill x

# Separator
frame .op.f.sep1 -bd 1 -relief sunken
  pack .op.f.sep1 -in .op.f -fill y -side left -pady 2 -padx 4
frame .op.f.sep1.f -bd 1 -relief flat
  pack .op.f.sep1.f -in .op.f.sep1 -fill y -side left

frame .op.f.f2 -bd 3
  pack .op.f.f2 -in .op.f -side left -fill both -ipadx 15  
### transfer mode  
label .op.f.f2.l2 -borderwidth 2 -anchor w -text "Transfer mode:" 
  pack .op.f.f2.l2 -in .op.f.f2 -side top -fill x
radiobutton .op.f.f2.active -anchor w -text "Active" -variable test(mode) -value "active"
  pack .op.f.f2.active -in .op.f.f2 -side top -fill x -padx 15
radiobutton .op.f.f2.passive -anchor w -text "Passive" -variable test(mode) -value "passive"
  pack .op.f.f2.passive -in .op.f.f2 -side top -fill x -padx 15

####################################################################
# Frame 2 
#
### debugging  
label .op.f.f2.l1 -borderwidth 2 -anchor w -text "Debugging:" 
  pack .op.f.f2.l1 -in .op.f.f2 -side top -fill x 
checkbutton .op.f.f2.debug -anchor w -text "Debug" -variable ftp::DEBUG
  pack .op.f.f2.debug -in .op.f.f2 -side top -fill x  -padx 15
checkbutton .op.f.f2.verbose -anchor w -text "Verbose" -variable ftp::VERBOSE
  pack .op.f.f2.verbose -in .op.f.f2 -side top -fill x -padx 15

#Iterations
frame .op.f.f2.loops -bd 2
  pack .op.f.f2.loops -in .op.f.f2 -side top -fill x -pady 2
label .op.f.f2.loops.l -borderwidth 2 -text "Iterations: " -relief flat -anchor w
  pack .op.f.f2.loops.l -in .op.f.f2.loops -side left -fill x
entry .op.f.f2.loops.e -borderwidth 2 -width 5
  pack .op.f.f2.loops.e -in .op.f.f2.loops -side left -fill x

# Separator
frame .op.f.sep2 -bd 1 -relief sunken
  pack .op.f.sep2 -in .op.f -fill y -side left -pady 2 -padx 4
frame .op.f.sep2.f -bd 1 -relief flat
  pack .op.f.sep2.f -in .op.f.sep2 -fill y -side left

####################################################################
# Frame 3
#
frame .op.f.f3 -bd 3
  pack .op.f.f3 -in .op.f -side left -fill both -expand 1 -ipadx 15

label .op.f.f3.l1  -anchor w -width 10 -text "Variable trace:" 
  pack .op.f.f3.l1 -in .op.f.f3 -side top -fill x 

frame .op.f.f3.v0 -bd 0
  pack .op.f.f3.v0 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v0.name  -anchor w -text "iterations = " 
  pack .op.f.f3.v0.name  -in .op.f.f3.v0 -side left -fill x 
label .op.f.f3.v0.value -anchor w -textvariable test(loop)
  pack .op.f.f3.v0.value -in .op.f.f3.v0 -side top -fill x
frame .op.f.f3.v1 -bd 0
  pack .op.f.f3.v1 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v1.name  -anchor w -text "errors = " 
  pack .op.f.f3.v1.name  -in .op.f.f3.v1 -side left -fill x 
label .op.f.f3.v1.value -anchor w -textvariable test(errors)
  pack .op.f.f3.v1.value -in .op.f.f3.v1 -side top -fill x
frame .op.f.f3.v2 -bd 0
  pack .op.f.f3.v2 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v2.name  -anchor w -text "after queues = " 
  pack .op.f.f3.v2.name  -in .op.f.f3.v2 -side left -fill x 
label .op.f.f3.v2.value -anchor w -textvariable test(after) 
  pack .op.f.f3.v2.value -in .op.f.f3.v2 -side top -fill x
frame .op.f.f3.v4 -bd 0
  pack .op.f.f3.v4 -in .op.f.f3 -side top -fill x -pady 2 -padx 15
label .op.f.f3.v4.name  -anchor w -text "open channels:" 
  pack .op.f.f3.v4.name  -in .op.f.f3.v4 -side top -fill x 
label .op.f.f3.v4.value -anchor w -textvariable test(open) 
  pack .op.f.f3.v4.value -in .op.f.f3.v4 -side top -fill x -padx 8

#####################################################################################
# Messages
frame .msg.f -bd 3
  pack .msg.f -in .msg -side top -fill both -expand 1

frame .msg.f.f1 -bd 2 -relief groove 
  pack .msg.f.f1 -in .msg.f -side left -fill both -padx 2 -pady 2
label .msg.f.f1.l -text "Test commands: " -relief flat -anchor w
  pack .msg.f.f1.l -in .msg.f.f1 -side top -fill x -padx 4 -pady 2

### Test commands   
set idlist {}  
foreach {id text} { 	quote "System Info"\
			list "List" \
			nlist "NList" \
			dir "Cd, MkDir, RmDir" \
			afile "ASCII Put/Get" \
			bfile "Binary Put/Ret" \
			ren "Rename" \
			append "Append" \
			new "Newer"  \
			reget "Reget" \
			notfound "file not found"} {
	checkbutton .msg.f.f1.$id -anchor w -text $text -variable test($id)
  	  pack .msg.f.f1.$id -in .msg.f.f1 -side top -fill x -padx 16
  	set test($id) 1
  	lappend idlist $id
}
button .msg.f.f1.plus -text "+ all" -command "foreach i {$idlist} {set test(\$i) 1}"
  pack .msg.f.f1.plus -in .msg.f.f1 -side left -fill x -padx 16 -pady 8
button .msg.f.f1.minus -text  "- all" -command "foreach i {$idlist} {set test(\$i) 0}"
  pack .msg.f.f1.minus -in .msg.f.f1 -side left -fill x -pady 8

frame .msg.f.f2 -bd 2 -relief groove 
  pack .msg.f.f2 -in .msg.f -side left -fill both -pady 2

label .msg.f.f2.label -text "Messages:" -anchor w
  pack .msg.f.f2.label -in .msg.f.f2 -side top -fill x -padx 2
scrollbar .msg.f.f2.yscroll -command ".msg.f.f2.text yview" 
  pack .msg.f.f2.yscroll -in .msg.f.f2 -side right -fill y
scrollbar .msg.f.f2.xscroll -relief sunken -orient horizontal -command ".msg.f.f2.text xview" 
  pack .msg.f.f2.xscroll -in .msg.f.f2 -side bottom -fill x
text .msg.f.f2.text -relief sunken -setgrid 1 -wrap none -height 20 -width 80 -bg white -fg black\
	-state disabled  -xscrollcommand ".msg.f.f2.xscroll set" \
	-yscrollcommand ".msg.f.f2.yscroll set"
  pack .msg.f.f2.text -in .msg.f.f2 -side left  -expand 1 -fill both
.msg.f.f2.text tag configure error -foreground red
.msg.f.f2.text tag configure data -foreground brown
.msg.f.f2.text tag configure control -foreground blue
.msg.f.f2.text tag configure header -foreground white -background black

#####################################################################################
# Buttons
frame .but.f -bd 3
  pack .but.f -in .but -side top -fill both -expand 1

frame .but.f.f1 -bd 3 
  pack .but.f.f1 -in .but.f -side top -fill x -padx 15 -pady 6
button .but.f.f1.start -text "Start Test" -width 12 -state normal -command "StartTest" 
   pack .but.f.f1.start -side left -fill x  -padx 15 
button .but.f.f1.stop -text "Stop Test" -width 12 -state disabled -command "StopTest" 
   pack .but.f.f1.stop -side left -fill x  -padx 15 
button .but.f.f1.close -text "Quit" -width 12 -state normal -command "destroy ." 
   pack .but.f.f1.close -side right -fill x  -padx 15 
button .but.f.f1.save -text "Save Options" -width 12 -state normal -command "SaveConfig" 
   pack .but.f.f1.save -side right -fill x  -padx 15 

################ procedures ####################################################################

# overwrite default ftp display message procedure
namespace eval ftp {
proc DisplayMsg {s msg {state ""}} {
global test
	.msg.f.f2.text configure -state normal
	
	# change state from "error" to "" for procedure test_9notfound
	if { ($state == "error") && [info exist test(proc)] && ($test(proc) == "test_99notfound") } {
		set state ""
	}
	
	switch -exact -- $state {
	  data		{.msg.f.f2.text insert end "$msg\n" data}
	  control	{.msg.f.f2.text insert end "$msg\n" control}
	  error		{.msg.f.f2.text insert end "$msg\n" error; incr test(errors)}
	  header	{.msg.f.f2.text insert end "$msg\n" header}
	  default 	{.msg.f.f2.text insert end "$msg\n"}
	}
	.msg.f.f2.text configure -state disabled
	.msg.f.f2.text see end
	update idletasks
}}

# new tracing open command
rename open ftpopen
proc open {args} {
global test
	set rc [eval ftpopen $args]
	if {[lsearch -exact $test(open) $rc] == "-1"} {
		lappend test(open) $rc
	}
#puts "open: $test(open)"
	return $rc
}	

# new tracing close command
rename close ftpclose
proc close {args} {
global test
	set rc [eval ftpclose $args]
	set index [lsearch -exact $test(open) $args]
	if {$index != "-1"} {
		set test(open) [lreplace $test(open) $index $index]
	} 
#puts "close: $test(open)"
	return $rc
}	

# new tracing socket command
rename socket ftpsocket
proc socket {args} {
global test
	set rc [eval ftpsocket $args]
	if {[lsearch -exact $test(open) $rc] == "-1"} {
		lappend test(open) $rc
	} 
#puts "socket: $test(open)"
	return $rc
}	


# new tracing InitDataConn command
namespace eval ftp {
rename InitDataConn ftpInitDataConn 
proc InitDataConn {args} {
global test
	set rc [eval ftpInitDataConn  $args]
	set s [lindex $args 0]
	if {[lsearch -exact $test(open) $s] == "-1"} {
		lappend test(open) $s
	} 
#puts "InitDataConn: $test(open)"
	return $rc
}}

# progress bar for put/get operations 
proc ProgressBar {state {bytes 0} {total {}} {filename {}}} {
global progress
	set w .progress
	switch -exact -- $state {
	  init	{
		set progress(percent) "0%"
		set progress(total) $total
		set progress(left) 0
 		toplevel $w -bd 0 -class Progressbar
		wm transient $w .
		wm title $w Progress
        	wm iconname $w Progress
		wm resizable $w 0 0
		focus $w
		
		frame $w.frame -bd 4
	  	  pack $w.frame -side top -fill both
		label $w.frame.label -text "Transfering $filename..." -relief flat -anchor w -bd 1
	  	  pack $w.frame.label -in $w.frame -side top -fill x -padx 10 -pady 5
		frame $w.frame.bar -bd 1 -relief sunken -bg #ffffff
	  	  pack $w.frame.bar -in $w.frame -side left -padx 10 -pady 5
		frame $w.frame.bar.dummy -bd 0 -width 250 -height 0
	  	  pack $w.frame.bar.dummy -in $w.frame.bar -side top -fill x
		frame $w.frame.bar.pbar -bd 0 -width 0 -height 20
	  	  pack $w.frame.bar.pbar -in $w.frame.bar -side left
		label $w.frame.proz -textvariable progress(percent) -width 5 -relief flat -anchor e -bd 1
	  	  pack $w.frame.proz -in $w.frame -side right -padx 10 -pady 5

		wm withdraw $w
		update idletasks
		set x [expr {[winfo x .] + ([winfo width .] / 2) - ([winfo reqwidth $w] / 2)}]
		set y [expr {[winfo y .] + ([winfo height .] / 2) - ([winfo reqheight $w] / 2)}]
		wm geometry $w +$x+$y
		update idletasks
		wm deiconify $w
		update idletasks
 	  }

	  update {
 		if {![winfo exist $w]} {return}  
		set cur_width 250
		catch {
			set progress(percent) "[expr {round($bytes) * 100 / $progress(total)}]%";
			set cur_width [expr {round($bytes * 250 / $progress(total))}]
		} msg
		$w.frame.bar.pbar configure -width $cur_width -bg #000080
		update idletasks
	  }

	  done 	{
	  	unset progress
		destroy $w
		update
	  }
	  default {
	      error "Unknown state \"$state\""
	  }
	}
}

#
# 1.) list -  returns a long list
#
proc test_10list {loop} {
global test

	# check if enabled
	if {!$test(list)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.1 (long directory listing)  ***" header
	set remote_list [ftp::List $test(conn)]		
	ftp::DisplayMsg $test(conn) "[llength $remote_list] directory lines!"
}

#
# 2.) nlist - returns a sorted short list
#
proc test_20nlist {loop} {
global test

	# check if enabled
	if {!$test(nlist)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.2 (short directory listing) ***" header
	set remote_list [ftp::NList $test(conn)]
	ftp::DisplayMsg $test(conn) "[llength $remote_list] directory entries!" 
}


#
# 3.) directory commands (cd, mkdir, rmdir)
#	- creates a remote directory foo
#	- changes to this directory
#	- changes back to parent directory
#	- removes a remote directory foo
#
proc test_30dir {loop} {
global test

	# check if enabled
	if {!$test(dir)} {return}
	ftp::DisplayMsg $test(conn) "*** TEST $loop.3 (directory commands cd,mkdir,rmdir) ***" header
	ftp::Pwd $test(conn)
	ftp::MkDir $test(conn) foo$test(pid)
	ftp::Cd $test(conn) foo$test(pid)
	ftp::Pwd $test(conn)
	ftp::Cd $test(conn) ..
	ftp::Pwd $test(conn)
	ftp::RmDir $test(conn) foo$test(pid)
}

#
# 4.) ascii put/get and delete
#	- go to ascii mode
#	- store a file to remote site
#	- retrieve the same file from remote site
#	- delete a file on remote site
#	- compare the size of both files
#	  (file sizes should be equal or only the "\r" difference 
#	   between DOS/WINDOWS <> UNIX
#
proc test_40afile {loop} {
global test

	# check if enabled
	if {!$test(afile)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.4 (put/get ascii files) ***" header
	set ascii_file ftpdemo.tcl
	set lsize [file size $ascii_file]
	ftp::Type $test(conn) ascii	
	ftp::Put $test(conn) $ascii_file ignore$test(pid).tmp

	# FileSize only works proper in binary mode
	ftp::Type $test(conn) binary
	set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp]
	ftp::Type $test(conn) ascii	
	ftp::Get $test(conn) ignore$test(pid).tmp
	ftp::Delete $test(conn) ignore$test(pid).tmp

	catch {
	  	ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes"
		ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes"
  		ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes"
		file delete ignore$test(pid).tmp	}

}

#
# 5.) binary put/get
#	- switch to binary mode
#	- store a file to remote site
#	- retrieve the same file from remote site
#	- delete a file on remote site
#	- compare the size of both files
#
proc test_50bfile {loop} {
global test tk_library

	# check if enabled
	if {!$test(bfile)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.5 (put/get binary files) ***" header
	set bin_file $tk_library/demos/images/teapot.ppm
	set lsize [file size $bin_file]
	ftp::Type $test(conn) binary

	# Put with ProgressBar
	#   - ProgressBar init ...
	#   - ProgressBar update ... callback defined in ftp!
	#   - ProgressBar done
	ProgressBar init 0 $lsize teapot.ppm
	ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
	ProgressBar done
	
	# Put with ProgressBar
	set rsize [ftp::FileSize $test(conn) ignore$test(pid).tmp]
	ProgressBar init 0 $rsize ignore$test(pid).tmp
	ftp::Get $test(conn) ignore$test(pid).tmp
	ProgressBar done
	
	ftp::Delete $test(conn) ignore$test(pid).tmp

	catch {
		ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes"
		ftp::DisplayMsg $test(conn) "Stored File:\t$rsize bytes"
		ftp::DisplayMsg $test(conn) "Retrieved File:\t[file size ignore$test(pid).tmp] bytes"
		file delete ignore$test(pid).tmp
	}
	
}

#
# 6.) rename
#	- stores a binary file on remote site and renames it
#
proc test_60ren {loop} {
global test tk_library

	# check if enabled
	if {!$test(ren)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.6 (renaming remote files) ***" header
	set bin_file $tk_library/demos/images/earth.gif
	ftp::Type $test(conn) binary
	ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
	ftp::Rename $test(conn) ignore$test(pid).tmp renamed$test(pid).tmp 
	ftp::Delete $test(conn) renamed$test(pid).tmp	

}
#
# 7.) append
#	- go to ascii mode
#	- store a ascii file to remote site
#	- appends ascci file on remote site and renames it
#	- delete a file on remote site
#	- compare the size of both files 
#	  remote file must have the double size
#	  (file sizes should be equal or only the "\r" difference 
#	   between DOS/WINDOWS <> UNIX
#
proc test_70append {loop} {
global test tk_library

	# check if enabled
	if {!$test(append)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.7 (append ascii file) ***" header
	set ascii_file ftpdemo.tcl
	set lsize [file size $ascii_file]
	ftp::Type $test(conn) ascii	
	ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp
	ftp::Append $test(conn) $ascii_file ignore$test(pid).tmp
	ftp::Get $test(conn) ignore$test(pid).tmp
	ftp::Delete $test(conn) ignore$test(pid).tmp

	catch {
	  	ftp::DisplayMsg $test(conn) "Original File:\t$lsize bytes ( * 2 = [expr {$lsize * 2}])"
  		ftp::DisplayMsg $test(conn) "Appended File:\t[file size ignore$test(pid).tmp] bytes"
		file delete ignore$test(pid).tmp	}

}

#
# 8.) newer
#	- create a local copy of a a file
#	- create a remote copy of a a file
#	- check date entries
#	- transfer only if the specifieid file is newer
#
proc test_80new {loop} {
global test tk_library

	# check if enabled
	if {!$test(new)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.8 (newer) ***" header
	set bin_file $tk_library/demos/images/earth.gif
	ftp::Type $test(conn) binary

	file copy $bin_file ignore$test(pid).tmp
	ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
	set datestr "%m/%d/%Y, %H:%M"

	set out {}
	catch {
	 	append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1]" \n
		append out "Remote File:\t[clock format [ftp::ModTime $test(conn) ignore$test(pid).tmp] -format $datestr -gmt 1]" \n
	}

	ftp::Newer $test(conn) ignore$test(pid).tmp	
	
	catch {	
		append out "Local File:\t[clock format [file mtime ignore$test(pid).tmp] -format $datestr -gmt 1] (after ftp::Newer)" 
	}

	ftp::Delete $test(conn) ignore$test(pid).tmp
	catch {file delete ignore$test(pid).tmp}
	ftp::DisplayMsg $test(conn) $out

}

#
# 9.) reget - reget command
#	- store file to remote site
#	- write 6 bytes to local file
#	- test the reget at position 6
#
proc test_90reget {loop} {
global test tk_library

	# check if enabled
	if {!$test(reget)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.9 (reget command) ***" header
	set bin_file $tk_library/demos/images/earth.gif
	ftp::Type $test(conn) binary
	ftp::Put $test(conn) $bin_file ignore$test(pid).tmp
	set f [open ignore$test(pid).tmp w]
	puts -nonewline $f "123456"
	close $f
	ftp::Reget $test(conn) ignore$test(pid).tmp
	ftp::Delete $test(conn) ignore$test(pid).tmp

	catch {
		ftp::DisplayMsg $test(conn) "Original File:\t\t[file size $bin_file]"
		ftp::DisplayMsg $test(conn) "Transfered  File:\t[file size ignore$test(pid).tmp]"
		file delete ignore$test(pid).tmp
	}
}

##
# 10.) not existing file/directory
#	all command with a not existing file name as parameter
#	- nlist, filesize, modtime, delete, rename, cd, rmdir, put, get, reget, newer
#	- write 6 bytes to local file
#	- test the reget at position 6
#
proc test_99notfound {loop} {
global test tk_library

	# check if enabled
	if {!$test(notfound)} {return}

	ftp::DisplayMsg $test(conn) "*** TEST $loop.10 (not existing file/directory) ***" header
	ftp::NList $test(conn) filenotfound		
	ftp::FileSize $test(conn) filenotfound		
	ftp::ModTime $test(conn) filenotfound		
	ftp::Rename $test(conn) filenotfound filenotfound
	ftp::Delete $test(conn) filenotfound
	ftp::Cd $test(conn) filenotfound
	ftp::RmDir $test(conn) filenotfound
	ftp::Put $test(conn) filenotfound
	ftp::Get $test(conn) filenotfound
	ftp::Reget $test(conn) filenotfound
	ftp::Newer $test(conn) filenotfound
}

# save preferences
proc SaveConfig {} {
global cnf

	set cnf(server) [.op.f.f1.server.e get]
	set cnf(port) [.op.f.f1.port.e get]
	set cnf(username) [.op.f.f1.username.e get]
	set cnf(password) [.op.f.f1.password.e get]
	set cnf(directory) [.op.f.f1.directory.e get]
	set cnf(loops) [.op.f.f2.loops.e get]
	set cnf(debug) $ftp::DEBUG
	set cnf(verbose) $ftp::VERBOSE

	set f [open $cnf(configfile) w]
	puts $f  [array get cnf]	
	close $f
}

# load preferences
proc LoadConfig {} {
global cnf

	# Defaults
	set cnf(server) "xxx"
	set cnf(port) 21
	set cnf(username) "xxx"
	set cnf(password) "xxx"
	set cnf(directory) ""
	set cnf(loops) 1
	set cnf(debug) 0
	set cnf(verbose) 1
	
	if {[file exists $cnf(configfile)]} {
		set f [open $cnf(configfile) r]
		array set cnf [read $f]
		close $f
	}
	
	.op.f.f1.server.e delete 0 end
	.op.f.f1.server.e insert 0 $cnf(server)
	.op.f.f1.port.e delete 0 end
	.op.f.f1.port.e insert 0 $cnf(port)
	.op.f.f1.username.e delete 0 end
	.op.f.f1.username.e insert 0 $cnf(username)
	.op.f.f1.password.e delete 0 end
	.op.f.f1.password.e insert 0 $cnf(password)
	.op.f.f1.directory.e delete 0 end
	.op.f.f1.directory.e insert 0 $cnf(directory)
	.op.f.f2.loops.e delete 0 end
	.op.f.f2.loops.e insert 0 $cnf(loops)
	set ::ftp::DEBUG $cnf(debug)
	set ::ftp::VERBOSE $cnf(verbose)
}

# stop the test
proc StopTest {} {
global test
	set test(break) 1
}

# start the test
proc StartTest {} {
global test

	.but.f.f1.stop configure -state normal
	.but.f.f1.start configure -state disabled
	
	.msg.f.f2.text configure -state normal
	.msg.f.f2.text delete 1.0 end
	.msg.f.f2.text configure -state disabled -fg black

	set loops [.op.f.f2.loops.e get]
	set server [.op.f.f1.server.e get]
	set port [.op.f.f1.port.e get]
	set username [.op.f.f1.username.e get]
	set passwd [.op.f.f1.password.e get]
	set dir [.op.f.f1.directory.e get]

	# open a ftp server connection
	set test(errors) 0
	set test(open) {}
	set test(pid) [pid]
	set start_time [clock seconds]
 	ftp::DisplayMsg "" "*** Test started at [clock format [clock seconds]  -format %d.%m.%Y\ %H:%M:%S ] ..." header
	if {[set conn [ftp::Open $server $username $passwd -port $port -progress {ProgressBar update} -mode $test(mode) -blocksize 8196 -timeout 60]] >= 0} {

		if {$test(quote)} {
			ftp::DisplayMsg $conn [ftp::Quote $conn syst]
    			ftp::DisplayMsg $conn [ftp::Quote $conn site umask 022]
    			ftp::DisplayMsg $conn [ftp::Quote $conn help]
    		}
    		   
    		   
		if { $dir != "" } {
			ftp::Cd $conn $dir
		}
		
    		# begin test loop
    		set test(break) 0
                set test(conn) $conn
    		for {set test(loop) 1} {$test(loop) <= $loops} {incr test(loop)} {
    			if {$test(break)} {break}
			foreach test(proc) [lsort [info proc test*]] {
    				if {$test(break)} {break}
    				
    				# count entries in the after queues
    				set test(after) [after info]

    				# run procedure
				eval $test(proc) $test(loop) 
			}
    		}
    		if {$test(break)} {
    			ftp::DisplayMsg "... user break!" error
    		} else {
			incr test(loop) -1
		}
		
    		ftp::Close $conn
		set stop_time [clock seconds]
		set elapsed [expr {$stop_time - $start_time}]
		if { $elapsed == 0 } { set elapsed 1}
    		ftp::DisplayMsg "" "************************* THE END *************************" header
    		ftp::DisplayMsg "" "=> $loops iterations takes $elapsed seconds" 
 		ftp::DisplayMsg "" "=> $test(errors) error(s) occured" 
	}
	.but.f.f1.stop configure -state disabled
	.but.f.f1.start configure -state normal
}

# Help
proc Help {} {
	.msg.f.f2.text configure -state normal
	.msg.f.f2.text delete 1.0 end
	.msg.f.f2.text insert 1.0 "          **** CONFIGURATION HELP *****
	
Ftp_demo is the simple user interface to the ftp test program. It
checks all ftp commands of the FTP library package against an
existing FTP server. It requires some configuration entries specified
in the form below.

- Host ... Host FTP server on which the connection will be established
- Username ... Users login name at host 
- Password ... Users password at host 
- Directory ... Starting directory when differs from root \"/\"
- Iterations ... Count of interations for the test algorithm (default 1)	

The message window shows all responses from the remote server, as well
as report on data transfer statistics and file sizes. Two switches 
toggles enhanced output:

1. Debug...Enables debugging (return code, state, real FTP commands )
2. Verbose ... Forces to show all responses from the FTP server 

Active or passive file transfer mode is selected in the upper frame.
When ftpdemo uses the active mode it waits for the server to open
a connection to transfer files or get file listings. In passive mode
the server waits for ftpdemo to open a connection to transfer files
or get file listings. Passive mode is normally a requirement when
accessing sites via a firewall.

Press \"Save Options\" to save these options in a configuration file. 
Options will be restored next time you start the ftpdemo program.
Check marked test commands and start test by pressing \"Start test\"
button. Any time the test program can be canceled by pressing the
\"Stop test\" button.
 
NOTE:
-----
THE FTP_DEMO PROGRAM IS A DEVELOPMENT AND DEBUGGING TOOL RATHER THAN
A USEFUL FTP USER INTERFACE. FEEL FREE TO USE IT.


			***"
	.msg.f.f2.text configure -state disabled -fg darkgreen
}

################ main ##########################################################################

# default file transfer mode ... active
set test(mode) active

# Configuration file
set cnf(configfile) "ftpdemo.cnf"
LoadConfig

Help







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/ftp/ftpvalid.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# Author: [Larry W. Virden] [LV], modified Andreas Kupries [AK]
# Version: 3
# Validate the ftp: urls given on the command line.

package require uri
package require ftp

# Should eventually add a command line argument to toggle verbose
#set ftp::VERBOSE 1

if {0} {
    proc ftp::DisplayMsg {s msg {state ""}} {
	upvar ::ftp::ftp$s ftp
	variable VERBOSE

	switch -exact -- $state {
	    data {
		if { $VERBOSE } { puts $msg }
	    }
	    control {
		if { $VERBOSE } { puts $msg }
	    }
	    error {
		if { $VERBOSE } { puts "E: $msg" }
		#error "ERROR: $msg"
	    }
	    default {
		if { $VERBOSE } { puts $msg }
	    }
	}
	return
    }
}

foreach arg $argv {
    array set current [uri::split $arg]

    # parray current

    if {[catch {
	set fdc [ftp::Open $current(host) anonymous [email protected]]
    } returncode]} {
	puts stderr [format "error 1: unable to open %s\n" $current(host)]
	continue
    }
    set ftp_dir  [file dirname $current(path)]
    set ftp_file [file tail    $current(path)]

    if {[catch {
	set result [ftp::Cd $fdc $ftp_dir] } returncode]
    } {
	puts stderr [format "error 2: unable to enter directory %s:%s\n" $current(host) $ftp_dir]
	continue
    }

    if { $result == 0 } {
	puts stderr [format "error 3: failure to enter %s:%s\n" $current(host) $ftp_dir]
	continue
    }

    if {[catch {
	set result [ftp::List $fdc "${ftp_file}*"] } returncode]
    } {
	puts stderr [format "error 4: no match for ${ftp_file}*\n" $current(host) $ftp_dir]
	continue
    }
    if { $result == {} } {
	puts stderr [format "error 5: no match for ${ftp_file}*\n" $current(host) $ftp_dir]
	continue
    }

    ftp::Close $fdc
}

exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































Deleted examples/ftp/hpupdate.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
#!/bin/sh
# the next line restarts using wish \
exec wish8.3 "$0" -- "$@"
#
#  - homepage update program using FTP -
#
#   Required:   tcl/tk8.2
#
#   Created:    12/96 
#   Changed:    7/2000
#   Version:    2.0
#
#   Copyright (C) 1998 Steffen Traeger
#	EMAIL:  [email protected]
#	URL:    http://home.t-online.de/home/Steffen.Traeger
#
#   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 of the License, 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., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################

# load required FTP package library 
package require ftp 2.0
package require Tk
if {![llength [info commands tkButtonInvoke]]} {
    ::tk::unsupported::ExposePrivateCommand tkButtonInvoke
}

# LED Colors
set status(off) "#006666"
set status(on)  "#00ff00"
set ftp(Mode) passive

# set palette under X
if { [string range [winfo server .] 0 0] == "X" } {
	set tk_strictMotif 1
	tk_setPalette LightGray
	option add *font                        {Helvetica 12}
	option add *Text.foreground             black
	option add *Text.background             white
	option add *Listbox.background          white
	option add *Listbox.selectForeground    white  
	option add *Entry.background            white
	option add *Entry.selectBackground      black
	option add *Entry.selectForeground      white
	option add *Scrollbar.width             12
}
	
# main window
wm title . "hpupdate 2.0"
wm iconname . hpupdate
wm minsize . 1 1

# Menue
menu .menu -tearoff 0
menu .menu.file -tearoff 0
.menu add cascade -label "File" -menu .menu.file -underline 0
.menu.file add command -label "Connect" -underline 0 -command {BusyCommand Connect} -accelerator Alt+C
.menu.file add command -label "Disconnect" -underline 1 -state disabled -command {BusyCommand Disconnect} -accelerator Alt+I
.menu.file add separator
.menu.file add command -label "Exit" -underline 0 -command Quit -accelerator Alt+X

#menu .menu.edit -tearoff 0
#.menu add cascade -label "Bearbeiten" -menu .menu.edit -underline 0
#.menu.edit add command -label "Alle L�schen" -underline 0 -state disabled -command {
#	.view.remote.list selection set 0 end; BusyCommand DeleteremoteFiles}
#.menu.edit add command -label "Alle �bertragen" -underline 0 -state disabled -command Quit

menu .menu.view -tearoff 0
.menu add cascade -label "View" -menu .menu.view -underline 0
.menu.view add command -label "Refresh" -underline 0 -command {BusyCommand Refresh} -accelerator Alt+R

menu .menu.options -tearoff 0
.menu add cascade -label "Options" -menu .menu.options -underline 0
.menu.options add command -label "Preferences" -underline 0 -command {BusyCommand Config} -accelerator Alt+P

menu .menu.help -tearoff 0
.menu add cascade -label "Help" -menu .menu.help -underline 0
.menu.help add command -label "Overview" -underline 0 -command {Help overview}
.menu.help add command -label "Installation" -underline 0 -command {Help install}
.menu.help add command -label "Usage" -underline 0 -command {Help usage}
.menu.help add separator
.menu.help add command -label "About" -underline 1 -command {Help about}

. configure -menu .menu

# View area
frame .status -bd 1 -relief flat
  pack .status -in . -side bottom -fill x
frame .view -bd 1 -relief flat
  pack .view -in . -side top -expand 1 -fill both

# Status
frame .status.head -bd 1 -relief sunken
  pack .status.head -in .status -side top -fill x
label .status.head.label -textvariable status(header) -relief raised -anchor w -bd 1
  pack .status.head.label -in .status.head -side left -expand 1 -fill x -ipadx 2 -ipady 2
 
# Connection status
frame .view.conn -bd 1 -relief flat
  pack .view.conn -in .view -side top -fill both -padx 8
frame .view.conn.led1 -bd 2 -relief raised -width 20 -height 10 
  pack .view.conn.led1 -in .view.conn -side left -fill x -padx 3
label .view.conn.lab1 -text "No Connection!" -relief flat -anchor w -bd 1 -font {Helvetica 8}
  pack .view.conn.lab1 -in .view.conn -side left -fill x  -padx 3
checkbutton .view.conn.check -text "syncronize scrollbars" -takefocus 0 -variable ftp(SyncScroll) \
	-command SyncScroll -relief flat -anchor w -bd 2 -font {Helvetica 12}
  pack .view.conn.check -in .view.conn -side right 

# Separator
frame .view.line -bd 1 -height 2 -relief sunken
  pack .view.line -in .view -side top -fill x -padx 8 -pady 5

# Dummy
frame .view.dummy -bd 1 -height 5 -relief flat
  pack .view.dummy -in .view -side bottom -fill x -padx 8 -pady 5

# Remote directory
frame .view.remote -bd 1
  pack .view.remote -in .view -side right -expand 1 -fill both -padx 5
frame .view.remote.status -bd 0
  pack .view.remote.status -in .view.remote -side top -fill x
label .view.remote.status.label -text "Remote: " -anchor w -relief flat -font {Helvetica 12 italic}
  pack .view.remote.status.label -in .view.remote.status -side left
label .view.remote.status.mark -text "" -anchor w -relief flat -font {Helvetica 10}
  pack .view.remote.status.mark -in .view.remote.status -side right
label .view.remote.status.use -text "0K" -anchor w  -relief flat  -fg #0000ff
  pack .view.remote.status.use -in .view.remote.status -side left

frame .view.remote.buttons -bd 1
  pack .view.remote.buttons -in .view.remote -side bottom -fill x
button .view.remote.buttons.delete -text "Delete" -under 0 -state disabled -command {BusyCommand DeleteRemoteFiles}
  pack .view.remote.buttons.delete -in .view.remote.buttons -side top -pady 1m
scrollbar .view.remote.yscroll -relief sunken -takefocus 0 -command ".view.remote.list yview"
  pack .view.remote.yscroll -in .view.remote -side right -fill y
scrollbar .view.remote.xscroll -relief sunken -orient horizontal -takefocus 0 -command ".view.remote.list xview"
  pack .view.remote.xscroll -in .view.remote -side bottom -fill x
listbox .view.remote.list -relief sunken -xscroll ".view.remote.xscroll set" -yscroll ".view.remote.yscroll set" \
	-width 40 -height 24 -font {Courier 12} \
	-exportselection 0 -selectmode multiple -takefocus 0 -selectbackground #ff0000
 pack .view.remote.list -in .view.remote -side left -expand 1 -fill both

# Local directory
frame .view.local -bd 1
  pack .view.local -in .view -side left -expand 1 -fill both -padx 5
frame .view.local.status -bd 0
  pack .view.local.status -in .view.local -side top -fill x
label .view.local.status.label -text "Local: " -anchor w -relief flat -font {Helvetica 12 italic}
  pack .view.local.status.label -in .view.local.status -side left
label .view.local.status.mark -text "" -anchor w -relief flat -font {Helvetica 10}
  pack .view.local.status.mark -in .view.local.status -side right
label .view.local.status.use -text "0K" -anchor w  -relief flat -fg #0000ff
  pack .view.local.status.use -in .view.local.status -side left
 
frame .view.local.buttons -bd 1
  pack .view.local.buttons -in .view.local -side bottom -fill x
button .view.local.buttons.transfer -text "Upload->" -under 0 -state disabled -command UpdateRemoteFiles
  pack .view.local.buttons.transfer -in .view.local.buttons -side top -pady 1m
scrollbar .view.local.yscroll -relief sunken -takefocus 0 -command ".view.local.list yview"
  pack .view.local.yscroll -in .view.local -side right -fill y
scrollbar .view.local.xscroll -relief sunken -orient horizontal -takefocus 0 -command ".view.local.list xview"
  pack .view.local.xscroll -in .view.local -side bottom -fill x
listbox .view.local.list -relief sunken -xscroll ".view.local.xscroll set" -yscroll ".view.local.yscroll set" \
	-width 40 -height 24 -font {Courier 12} \
	-exportselection 0 -selectmode multiple -takefocus 0 -selectbackground #000080
 pack .view.local.list -in .view.local -side left -expand 1 -fill both

# Shows selected files 
bindtags .view.local.list {Listbox . all .view.local.list}
bindtags .view.remote.list {Listbox . all .view.remote.list}
bind .view.local.list <ButtonRelease-1> {Showselected local}
bind .view.remote.list <ButtonRelease-1> {Showselected remote}

# Acc. Keys
bind . <Meta-c> {BusyCommand Connect}
bind . <Meta-i> {BusyCommand Disconnect}
bind . <Meta-r> {BusyCommand Refresh}
bind . <Meta-p> {BusyCommand Config}
bind . <Meta-u> "tkButtonInvoke .view.local.buttons.transfer"
bind . <Meta-d> "tkButtonInvoke .view.remote.buttons.delete"
bind . <Meta-x> Quit

proc SyncY {args} {
	eval .view.local.list yview $args
	eval .view.remote.list yview $args
}

proc SyncX {args} {
	eval .view.local.list xview $args
	eval .view.remote.list xview $args
}

# Syncron Scrollbars
proc SyncScroll {} {
global ftp
	if { $ftp(SyncScroll) == 1} {
		.view.local.yscroll configure -command SyncY
		.view.remote.yscroll configure -command SyncY
		.view.local.xscroll configure -command SyncX
		.view.remote.xscroll configure -command SyncX
	} else {
		.view.local.yscroll configure -command ".view.local.list yview"
		.view.remote.yscroll configure -command ".view.remote.list yview"
		.view.local.xscroll configure -command ".view.local.list xview"
		.view.remote.xscroll configure -command ".view.remote.list xview"
	}
}

# messages
proc ftp::DisplayMsg {s msg {state normal}} {
global status

	switch -- $state {
	  data	        {return}
	  control       {return}
	  normal        {.status.head.label configure -fg black}
	  error         {.status.head.label configure -fg red}
	}	 
	set status(header) $msg
	update idletasks
}

################################################
#
#	Procedures
#
################################################

# hourglass
proc BusyCommand {args} {
	set command $args
	set busy {.menu .view .status}
	set window_list {.menu .view .status}
	while {$window_list != ""} {
		set next {}
		foreach w $window_list {
			set class [winfo class $w]
			set cursor [lindex [$w config -cursor] 4]
			if {[winfo toplevel $w] == $w || $cursor != ""} {
				lappend busy [list $w $cursor]
			}
			set next [concat $next [winfo children $w]]
		}
		set window_list $next
	}
	foreach w $busy {
		catch { grab set [lindex $w 0]}
		catch {[lindex $w 0] config -cursor watch}
	}
	update idletasks
	set error [catch {uplevel eval [list $command]} g]
	foreach w $busy {
		catch {grab release [lindex $w 0]}
		catch {[lindex $w 0] config -cursor [lindex $w 1]}
	}
	if { !$error } {
		return $g
	} else {
		bgerror $g
	}
	return ""
}

# read recursive the remote directory tree
proc GetRemoteTree {{dir ""}} {
global ftp

	foreach i [ftp::List $ftp(conn) $dir] {
		set rc [scan $i "%s %s %s %s %s %s %s %s %s" perm l u g size d1 d2 d3 name]
		if {$rc == "9"} {
		
			if { ($name == ".") || ($name == "..") } {
				continue
			}
		
			set type [string range $perm 0 0]
			if { $dir != "" } {
				regsub {\./} [file join $dir $name] "" name
			}
			switch -- $type {
				d {
					lappend ftp(remoteDirList) $name
					lappend ftp(remoteFileList) "$name"
					lappend ftp(remoteSizeList) $size
					GetRemoteTree $name
				  }

				- {	
					lappend ftp(remoteFileList) "$name"
					lappend ftp(remoteSizeList) $size
				  }

				default {       
					lappend ftp(remoteFileList) "$name"
					lappend ftp(remoteSizeList) $size
				  }
			}
		}	        
	}
}

# read remote directory
proc ReadRemoteDir {} {
global ftp opt

	# connected?
	if {(![info exists ftp(conn)]) ||
            (![info exists ftp::ftp${ftp(conn)}(State)])} {
		.view.remote.list delete 0 end
		return
	}

	focus .view.remote.list
	.view.remote.list delete 0 end
	.view.remote.list insert end "Working..."
	update idletasks

	set ftp(remoteDirList) {}
	set ftp(remoteFileList) {}
	set ftp(remoteSizeList) {}
	GetRemoteTree .

	foreach name $ftp(remoteFileList) {
		if { [string length $name] > $ftp(MaxLength) } {
			set ftp(MaxLength) [string length $name]
		}
	}	

	set max_length $ftp(MaxLength)
	.view.remote.list delete 0 end
	update idletasks
	set index 0
	foreach i $ftp(remoteFileList) {

		set name $i
		set size [lindex $ftp(remoteSizeList) $index ]
		set entry [format "%-${max_length}s %8s" $name $size]
		.view.remote.list insert end $entry

		# If file doesn't exist on local location then mark it to delete
		set index [lsearch -regexp [.view.local.list get 0 end] "^$name "]
		if { $index == "-1" } {
			.view.remote.list selection set end end
		}
		incr index
		
	}

	ShowUsed remote
	Showselected remote
	ReadLocalDir
}

# shine a light 
proc Blink {mode} {
global status
	switch -- $mode {
	  on {
		.view.conn.led1 configure -bg $status(on)
		update idletasks
	  }
	  off {
		.view.conn.led1 configure -bg $status(off)
		update idletasks
	  }
	}
}

# connect to ftp server
proc Connect {} {
global ftp opt
	ftp::DisplayMsg "" " ftp> Trying connect to ftp server..."
	Blink on
	if {[set ftp(conn) [ftp::Open $opt(Server) $opt(Username) $opt(Password) -progress {ProgressBar update} ]] == -1} {
		Blink off
		ShowStatus
		return
	}

	# remote homepage directory
	if {![ftp::Cd $ftp(conn) $opt(remoteDir)]} {
		tk_messageBox -parent . -title INFO -message "Directory $opt(remoteDir) on remote ftp server not found!" -type ok
		Disconnect
		return
	}

	ftp::DisplayMsg $ftp(conn) "Connected to ftp service on $opt(Server)!" 
	ReadRemoteDir
	.view.local.buttons.transfer configure -state normal
	.view.remote.buttons.delete configure -state normal
	.menu.file entryconfigure 0 -state disabled
	.menu.file entryconfigure 1 -state normal
	ShowStatus
}

# Remove connection to file server
proc Disconnect {} {
global ftp

	# connected?
	if {([info exists ftp(conn)]) &&
            ([info exists ftp::ftp${ftp(conn)}(State)])} {
		ftp::Close $ftp(conn)
		ftp::DisplayMsg "" "Connection closed!"
	}
        if {[info exists ftp(conn)]} {
            unset ftp(conn)
        }
	set ftp(remoteSizeList) {}
	.view.remote.list delete 0 end
	.view.local.buttons.transfer configure -state disabled
	.view.remote.buttons.delete configure -state disabled
	.menu.file entryconfigure 0 -state normal
	.menu.file entryconfigure 1 -state disabled
	ShowStatus
	ShowUsed remote
	Showselected remote
}

# Display connection status
proc ShowStatus {} {
global status
	if {([info exists ftp(conn)]) &&
            ([info exists ftp::ftp${ftp(conn)}(State)])} {
		.view.conn.led1 configure -bg $status(on) 
		.view.conn.lab1 configure -text "connected"
		update idletasks
	} else {
		.view.conn.led1 configure -bg $status(off)
		.view.conn.lab1 configure -text "not connected"
		update idletasks
	}
}

# display used directory size 
proc ShowUsed {mode} {
global ftp
	set sum 0
	foreach i $ftp(${mode}SizeList) {
		incr sum $i
	}

#	if { $sum > [ expr {1024 * 1024}] } {
#	        set color #ff0000
#	} else {
#	        set color #0000ff
#	}

	set color #0000ff
	.view.$mode.status.use configure -text "[expr {round($sum / 1024.0)}] KB" -fg $color
	update idletasks
}

# display selected directory size 
proc Showselected {mode} {
global ftp
	set sum 0
	set count 0
	if { ([info exists ftp(${mode}SizeList)]) && ([llength $ftp(${mode}SizeList)] != 0) } {
		foreach i [.view.$mode.list curselection] {
			incr sum [lindex $ftp(${mode}SizeList) $i]
			incr count
		}
	}
	.view.$mode.status.mark configure -text  "[expr {round($sum / 1024.0)}] KB \[$count\]"
	update idletasks
}


# read recursive the local directory tree
proc GetLocalTree {dir} {
global ftp
	foreach i [lsort [glob -nocomplain $dir/* $dir/.*]] {
		regsub {\./} $i "" i
		if { ([file tail $i] != ".") && ([file tail $i] != "..") } {

			# exist check
			if {![file exists $i]} {
				continue
			}

			if {[file isdirectory $i]} {
				lappend ftp(localFileList) $i
				lappend ftp(localDirList) $i
				GetLocalTree $i
			} else {
				lappend ftp(localFileList) $i
			}
		}
	}
}

# read local directory
proc ReadLocalDir {} {
global opt ftp

	.view.local.list delete 0 end
	.view.local.list insert end "Working..."
	update

	# local homepage directory
	if {![file isdirectory $opt(localDir)]} {
		tk_messageBox -parent . -title INFO -message "Directory $opt(localDir) not found!" -type ok
		return
		
	}

	# read local homepage directory 
	set ftp(localDirList) {}
	set ftp(localFileList) {}
	set ftp(localSizeList) {}
	cd $opt(localDir)
	GetLocalTree .

	foreach name $ftp(localFileList) {
		if { [string length $name] > $ftp(MaxLength) } {
			set ftp(MaxLength) [string length $name]
		}
	}

	set max_length $ftp(MaxLength)
	.view.local.list delete 0 end
	update idletask
	foreach i $ftp(localFileList) {
	
		set name $i
		set size [file size $name]
		set entry [format "%-${max_length}s %8s" $name $size]
		.view.local.list insert end $entry
		lappend ftp(localSizeList) $size
	
		# if updated then mark to upload 
		if { [file mtime $name] > $opt(Timestamp) } {
			.view.local.list selection set end end
		}

		# if not exist at remote machine then mark to upload 
		if {([info exists ftp(conn)]) &&
                    ([info exists ftp::ftp${ftp(conn)}(State)])} {
			set index [lsearch -regexp [.view.remote.list get 0 end] "^$name "]
			if { $index == "-1" } {
				.view.local.list selection set end end
			}
		}
	}
	
	ShowUsed local
	Showselected local
}

# delete files on remote site
proc DeleteRemoteFiles {} {
global ftp

	# connected?
	if {(![info exists ftp(conn)]) ||
            (![info exists ftp::ftp${ftp(conn)}(State)])} {
		tk_messageBox -parent . -title INFO -message "No connection!" -type ok
		return
	}
	# nothing choosed
	if { [.view.remote.list curselection] == {} } {
		return
	}
	# ask user
	set count [llength [.view.remote.list curselection]]
	set rc [tk_messageBox -parent . -title DELETE -message "Do you really want to delete the $count selected file(s)?" -type yesno]
	if { $rc == "no" } {
		return
	}

	# delete selected files
	focus .view.remote.list
	foreach i [lsort -integer -decreasing [.view.remote.list curselection]] {
		set filename [lindex [.view.remote.list get $i] 0]
		.view.remote.list see $i
		.view.remote.list activate $i
		update idletasks

		# file or directory?
		set index [lsearch -exact $ftp(remoteDirList) $filename]
		if { $index == "-1" } {
			set command "ftp::Delete"
		} else {
			set command "ftp::RmDir"
		}
		
		if {[eval $command $ftp(conn) $filename]} {
			.view.remote.list selection clear $i
			update idletasks
			set ftp(remoteSizeList) [lreplace $ftp(remoteSizeList) $i $i 0]
			ShowUsed remote
			Showselected remote
			Showselected local
		} else {
			tk_messageBox -parent . -title ERROR -message \
				"Error deleting $filename!" -icon error -type ok
			continue
		}	
	}
	BusyCommand Refresh
}

# Progress bar displayed in status line
proc ProgressBar {state {bytes 0} {filename ""}} {
global ftp
	set w .progress
	switch -- $state {
	  init	{
		set ftp(Filename) ""
		set ftp(ProgressProz) "0%"
		toplevel $w -bd 0 -class Progressbar
		wm transient $w .
		wm title $w Upload
		wm iconname $w Upload
		wm resizable $w 0 0
		focus $w
		grab $w
		
		frame $w.buttons
		  pack $w.buttons -side bottom -fill x -pady 2m
		button $w.buttons.esc -text "Cancel" -command "set ftp(escaped) 1"
		  pack $w.buttons.esc -in $w.buttons -side top

		frame $w.frame -bd 4
		  pack $w.frame -side top -fill both
		label $w.frame.label -textvariable ftp(Filename) -relief flat -anchor w -bd 1 -font {Helvetica 12}
		  pack $w.frame.label -in $w.frame -side top -fill x -padx 10 -pady 5
		frame $w.frame.line -bd 1 -height 2 -relief sunken
		  pack $w.frame.line -in $w.frame -side bottom -fill x -padx 2 -pady 5
		frame $w.frame.bar -bd 1 -relief sunken -bg #ffffff
		  pack $w.frame.bar -in $w.frame -side left -padx 10 -pady 5
		frame $w.frame.bar.dummy -bd 0 -width 200 -height 0
		  pack $w.frame.bar.dummy -in $w.frame.bar -side top -fill x
		frame $w.frame.bar.pbar -bd 0 -width 0 -height 20
		  pack $w.frame.bar.pbar -in $w.frame.bar -side left
		label $w.frame.proz -textvariable ftp(ProgressProz) -width 5 -relief flat -anchor e -bd 1 -font {Helvetica 12}
		  pack $w.frame.proz -in $w.frame -side right -padx 10 -pady 5

		wm withdraw $w
		update idletasks
		set x [expr {[winfo x .] + ([winfo width .] / 3) - ([winfo reqwidth $w] / 2)}]
		set y [expr {[winfo y .] + ([winfo height .] / 3) - ([winfo reqheight $w] / 2)}]
		wm geometry $w +$x+$y
		wm deiconify $w
		update idletasks
	  }
	  
	  reset { 
	  		set ftp(Filename) "Uploading $filename...."
			set index [lsearch $ftp(localFileList) $filename]
			if { $index != "-1" } {
				set ftp(progress_sum) [lindex $ftp(localSizeList) $index]
				if { $ftp(progress_sum) == 0 } {
					set ftp(progress_sum) 1
				}
			} else {
				set ftp(progress_sum) 1
			}
			ProgressBar update
			update idletasks
	  	}

	  update {
		if {![winfo exists $w]} {return}  
		set ftp(ProgressProz) "[expr {round( $bytes * 100 / $ftp(progress_sum))}]%"
		set cur_width [expr {round($bytes * 200 / $ftp(progress_sum))}]
		$w.frame.bar.pbar configure -width $cur_width -bg #000080
		focus $w.buttons.esc
		update idletasks
		update
	  }

	  done	{
		set ftp(Filename) "Upload successful!"
		$w.buttons.esc configure -text "OK" -command "destroy $w"
		update idletasks
		tkwait window $w
	  }

	  escape {
		destroy $w
		BusyCommand Refresh
	  }  
	
	  error {
		destroy $w
	  }
	}
}

# upload local files to remote site
proc UpdateRemoteFiles {} {
global ftp opt status
	# connected?
	if {(![info exists ftp(conn)]) ||
            (![info exists ftp::ftp${ftp(conn)}(State)]) } {
		tk_messageBox -parent . -title INFO -message "No connection!" -type ok
		return 0
	}
	
	# nothing selected 
	if { [.view.local.list curselection] == {} } {
		return 0
	}
	
	# ask user
	set count [llength [.view.local.list curselection]]
	set rc [tk_messageBox -parent . -title UPLOAD -message "Do you really want to upload the $count selected file(s)?" -type yesno]
	if { $rc == "no" } {
		return 0
	}
	
	# create list of uploading files
	set upload_list {}
	foreach i [.view.local.list curselection] {
		lappend upload_list $i
	}
	
	# empty list?
	if { $upload_list == {} } {
		tk_messageBox -parent . -title INFO -type ok -message "Nothing selected for upload!!"
		return 0
	}
	focus .view.local.list

	# binary type for all files
	ftp::Type $ftp(conn) binary

	# upload files
	set ftp(escaped) 0
	ProgressBar init
	set ftp(ProgressCount) 0
	foreach i $upload_list {
		set filename [lindex [.view.local.list get $i] 0]
		.view.local.list see $i
		.view.local.list activate $i
		update idletasks	

		# file or directory?
		set index [lsearch -exact $ftp(localDirList) $filename]
		if { $index == "-1" } {
			set command "ftp::Put"
		} else {
		
			# directory already exists
			if { [lsearch -exact $ftp(remoteDirList) $filename] != "-1" } {
				continue
			}
			set command "ftp::MkDir"
		}

		ProgressBar reset 0 $filename
		if {[eval $command $ftp(conn) $filename]} {
			incr ftp(ProgressCount)
			if {$ftp(escaped)} {
				ProgressBar escape
				return 1
			}
			.view.local.list selection clear $i
		} else {
			tk_messageBox -parent . -title ERROR -message "Error uploading $filename!" -icon error -type ok
			ProgressBar error
			continue
		}
	}
	
	ProgressBar done

	# new timestamp
	Touch $opt(TsFile)
	set opt(Timestamp) [file mtime $opt(TsFile)]
	Refresh
	set status(header) " last update: [clock format $opt(Timestamp) -format %d.%m.%Y\ %H:%M:%S\ Uhr -gmt 0]"
	return 0
}

# Refresh
proc Refresh {} {
global ftp
	set ftp(MaxLength) 0
	ReadLocalDir
	ReadRemoteDir
	ShowStatus
	update idletasks
}


if {[package vcompare [info tclversion] 8.4] >= 0} {
    proc Touch {filename} {
	file mtime $filename [clock seconds]
    }
} else {
    # update timestamp
    proc Touch {filename} {
	set file [open $filename w]
	puts -nonewline $file ""
	close $file
    }
}


# quit hpupdate
proc Quit {} {
global ftp
	Disconnect
	destroy .
	exit 0
}


# save current configuration
proc SaveConfig {} {
global opt
	set file [open $opt(ConfigFile) w]
	puts $file  [array get opt]     
	close $file
}

# accept new configuraion
proc AcceptConfig {w} {
global opt ftp

	# get ftp server options
	set opt(Server) [$w.mask.server.entry get]
	set opt(Username) [$w.mask.user.entry get]
	set opt(Password) [$w.mask.passwd.entry get]
	set opt(remoteDir) [$w.mask.remote.entry get]
	
	# get local homepage direction
	set dir [$w.mask.local.entry get]
	if { ![file isdirectory $dir] } {
		tk_messageBox -parent . -title ERROR -message "Directory \"$dir\" not found!" -type ok
		return
	}
	set opt(localDir) [$w.mask.local.entry get]
	cd $opt(localDir)
	
	SaveConfig
	tk_messageBox -parent . -title INFO -message "Configuration applied and saved!" -type ok
	destroy $w
}

# ftp configuration
proc Config {} {
global opt

	# new window
	set w .config

	catch {destroy $w}
	toplevel $w -bd 0 -class Config
	wm transient $w .
	wm title $w "options"
	wm iconname $w "options"
	wm transient $w .
	wm minsize $w 10 10

	frame $w.mask -bd 1 -relief raised
	  pack $w.mask -in $w -side top -expand 1 -fill both 
	frame $w.control -bd 1 -relief raised
	  pack $w.control -in $w -side bottom -fill x

	frame $w.mask.server -bd 1
	  pack $w.mask.server -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m
	label $w.mask.server.label -text "ftp server name:" -under 0 -anchor w
	  pack $w.mask.server.label -in $w.mask.server -side top -fill x
	entry $w.mask.server.entry -width 40
	  pack $w.mask.server.entry -in $w.mask.server -expand 1 -side left -fill x

	frame $w.mask.user -bd 1
	  pack $w.mask.user -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m
	label $w.mask.user.label -text "User:" -under 0 -anchor w
	  pack $w.mask.user.label -in $w.mask.user -side top -fill x
	entry $w.mask.user.entry -width 40
	  pack $w.mask.user.entry -in $w.mask.user -expand 1 -side left -fill x

	frame $w.mask.passwd -bd 1
	  pack $w.mask.passwd -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m
	label $w.mask.passwd.label -text "Password:" -under 0 -anchor w
	  pack $w.mask.passwd.label -in $w.mask.passwd -side top -fill x
	entry $w.mask.passwd.entry -show "*" -width 40
	  pack $w.mask.passwd.entry -in $w.mask.passwd -expand 1 -side left -fill x

	frame $w.mask.remote -bd 1
	  pack $w.mask.remote -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m
	label $w.mask.remote.label -text "Remote directory:" -under 0 -anchor w
	  pack $w.mask.remote.label -in $w.mask.remote -side top -fill x
	entry $w.mask.remote.entry -width 40
	  pack $w.mask.remote.entry -in $w.mask.remote -expand 1 -side left -fill x

	frame $w.mask.local -bd 1
	  pack $w.mask.local -in $w.mask -side top -expand 1 -fill both -padx 3m -pady 3m
	label $w.mask.local.label -text "Local directory:" -under 0 -anchor w
	  pack $w.mask.local.label -in $w.mask.local -side top -fill x
	entry $w.mask.local.entry -width 40
	  pack $w.mask.local.entry -in $w.mask.local -expand 1 -side left -fill x

	button $w.control.accept -width 14 -text "Apply & Save" -under 0 -command "AcceptConfig $w"
	  pack $w.control.accept -in $w.control -side left -expand 1 -padx 3m -pady 2m
	button $w.control.quit -width 14 -text "Cancel" -under 0 -command "destroy $w"
	  pack $w.control.quit -in $w.control -side left -expand 1 -padx 3m -pady 2m


	# arrange window
	wm withdraw $w
	update idletasks
	set x [expr {[winfo x .] + ([winfo width .] / 3) - ([winfo reqwidth $w] / 2)}]
	set y [expr {[winfo y .] + ([winfo height .] / 3) - ([winfo reqheight $w] / 2)}]
	wm geometry $w +$x+$y
	wm deiconify $w

	$w.mask.server.entry delete 0 end
	$w.mask.server.entry insert 0 $opt(Server)
	$w.mask.user.entry delete 0 end
	$w.mask.user.entry insert 0 $opt(Username)
	$w.mask.passwd.entry delete 0 end
	$w.mask.passwd.entry insert 0 $opt(Password)
	$w.mask.local.entry delete 0 end
	$w.mask.local.entry insert 0 $opt(localDir)
	$w.mask.remote.entry delete 0 end
	$w.mask.remote.entry insert 0 $opt(remoteDir)

	bind $w <Meta-d> "tkButtonInvoke $w.mask.check.debug"
	bind $w <Meta-v> "tkButtonInvoke $w.mask.check.verbose"
	bind $w <Meta-f> "focus $w.mask.server.entry"
	bind $w <Meta-r> "focus $w.mask.remote.entry"
	bind $w <Meta-l> "focus $w.mask.local.entry"
	bind $w <Meta-s> "tkButtonInvoke $w.control.accept"
	bind $w <Meta-c> "tkButtonInvoke $w.control.cancel"

	focus -force $w.mask.server.entry
	update idletasks
}

proc Usage {} {
	puts "\nusage hpupdate \[-h\] \[directory\]"
	puts "	 -h          help"
	puts "	 directory   local directory"
	puts "	             (default: current directory)\n"
	exit 0
}

# Help
proc Help {mode} {

set help(overview) {
OVERVIEW
---------

In order to simplify the transfer of the files of my homepage to the 
FTP server of my Internet Service Provider, I looked at the end of 
1996 for an useful tool. Linux offered only the 
abilities of the ftp command line utility. As fan of 
Tcl/Tk, my selection immediately fell on "expect",  which was very suitable
to automate interactive processes like FTP sessions. A little bit 
more Tcl source code and hpupdate 0.1 was finished, a script for
automatic updating of my homepage files. 

At the beginning of 1997, I was more intensively occupied with the 
FTP protocol. At the same time I played with Tcl's socket command.
Thus the FTP library package for Tcl7.6 was developed. 
This forms the basis for hpupdate. 

So far, the program runs under Linux with Tcl/Tk 8.0. I have once 
tested it on Windows 3.11 (with Win32s) and Windows 95 and it runs 
perfectly. Today I have no experiences with Windows NT and
Macintosh. Perhaps somebody will be found who will test it in these 
environments. I would like to be informed of your experiences!
Thank you!

	usage:		hpupdate <directoy>
	
			example: hpupdate /home/user/hp

			***
}

set help(install) {
INSTALLATION
------------

The great advantage of hpupdate is its platform independence 
because of using Tcl/Tk.

If you do not have Tcl/Tk 8.0 installed already, at first you must 
install it. Get it from the known locations such as http://tcl.sf.net/
and follow the installation instructions. 

If you have not already installed the ftp library package, you must 
install it. Get it from my homepage and follow the 
installation instructions. 

Start up hpupdate and change the preferred options in option menu.
	
"ftp Server Name" 	- remote FTP server hostname
"User"			- valid username
"Password"		- valid password for user
"Remote Directory"	- remote root for homepage or empty (destination)
"Local Directory"	- local homepage directory (source)


			***
}

set help(usage) {
USAGE
-----

The hpupdate application is divided into 4 areas:

	1.) menu 
	2.) local file list (source)
	3.) remote file list (destination)
	4.) status line

1.) menu

		File / Connect
Opens a connection with the FTP server.
 
		File / Disconnetc
Closes an existing connection with the FTP server.
		
		File / Exit
Quits hpupdate, the connection to the FTP server will be 
closed automatically.

		View / Refresh
Reads new file data and refreshs it in the list.

		Options / Preferences
Interface to saving your login, password, ftp server, etc.
	
		Help / * look there 

2.) local file list 
This list contains the file names and sizes from the local
homepage directory. The file name, date and time-of-day 
of the files are compared with the time stamp of the remote files.
When getting the filename for this list, the date/time entry of each file
is read and compared with the timestamp of the last update.
Files which have a date and/or time newer than the remote file's timestamp
are detected as updated and marked for upload. 
It is also possible to mark/unmark the files manually per mouse click.
The capacity of all files in the directory is displayed in blue. 
Besides this, the capacity of the marked files, as well as the count of files
(in parentheses) are shown.

By pressing the button "Upload", all selected files in  the local 
homepage directory will be transfered to the remote FTP server.

3.) remote file list 
The files at the FTP site appear in this list after connection with
the FTP server. The remote files will be compared with the local files.
Files which are not in the local list are detected as superfluous
and marked for deletion.
It is also possible to mark/unmark files manually per mouse click.
The number of marked files is displayed in an extra frame.
Additionally, the summary disk space is shown. 
The capacity of all files in the directory is displayed in blue. 
Besides this, the capacity of all marked files as well as the count
(in parentheses) is shown.

By pressing the button "Delete", all selected files in the remote homepage
directory will be deleted.

NOTE: Synchronize the scrolling of both lists by pressing the checkbutton 
"sychronize scrollbars ".

4.) status line
The status line shows when the last update of the remote system has taken place.
This display is always updated after every file transfer.
Internally, the file "hpupdate.ts" is provided with a new timestamp.
After this moment, all modified local files are automatically detected
with the next refresh and marked for upload.

Error and status messages for the FTP connection are also displayed in
the status line.

EXTENSION:
The green LED shows the connection status, a lighter green means an
established connection.

			***
}

set help(about) {
  - hpupdate
  homepage update program using FTP 

  Required:   Tcl/Tk8.0x

  Created:    12/96 
  Changed:    04/2002
  Version:    2.1

  Copyright (C) 1997,1998, Steffen Traeger
        EMAIL:  [email protected]
        URL:    http://home.t-online.de/home/Steffen.Traeger
}

	set w .help
	catch {destroy $w}
 	toplevel $w -bd 0 -class Help
	wm transient $w .
	wm title $w "Help - $mode"
        wm iconname $w Hilfe
	wm minsize $w 10 10
	frame $w.buttons -bd 1 -relief flat 
	  pack $w.buttons -side bottom -fill x -pady 2m
	button $w.buttons.close -text "OK" -command "destroy $w"
	  pack $w.buttons.close -side left -expand 1
	frame $w.ftp -bd 1 -relief flat 
	  pack $w.ftp -side top -expand 1 -fill both
	scrollbar $w.ftp.yscroll -command "$w.ftp.text yview" 
	  pack $w.ftp.yscroll -in $w.ftp -side right -fill y
	scrollbar $w.ftp.xscroll -relief sunken -orient horizontal -command "$w.ftp.text xview" 
	  pack $w.ftp.xscroll -in $w.ftp -side bottom -fill x
	text $w.ftp.text -relief sunken -setgrid 1 -wrap none -height 15 -width 60 -bg white -fg black\
		-state normal  -xscrollcommand "$w.ftp.xscroll set" \
		-yscrollcommand "$w.ftp.yscroll set"
	  pack $w.ftp.text -in $w.ftp -side left  -expand 1 -fill both
	wm withdraw $w
	update idletasks
	set x [expr {[winfo x .] + ([winfo width .] / 3) - ([winfo reqwidth $w] / 2)}]
	set y [expr {[winfo y .] + ([winfo height .] / 3) - ([winfo reqheight $w] / 2)}]
 	wm geometry $w +$x+$y
	wm deiconify $w
	$w.ftp.text insert 0.0 $help($mode)
	$w.ftp.text configure -state disabled
	update idletasks

}
##################### main ###################################################

# determine working directory 
if { $argv != "" && $argv != "{}" } {
	if { [lindex $argv 0] == "-h" } {Usage}
	set dir [lindex $argv 0]
	if { [file exists $dir] && [file isdirectory $dir] } {
		set opt(localDir) $dir
	} else {
		puts "Directory \"$dir\" not found!"
		Usage
	}
} else {
	set opt(localDir) [pwd]
}	

# init defaults
set opt(Server) ""
set opt(Username) "anonymous"
set opt(Password) ""
set opt(remoteDir) "."
set opt(ConfigFile)     $env(HOME)/hpupdate.cnf
set opt(TsFile)         $env(HOME)/hpupdate.ts

# load configuration file
if { [file exists $opt(ConfigFile)] } {
	set file [open $opt(ConfigFile) r]
	array set opt [read $file]
	close $file
} 
set ftp::DEBUG 0
set ftp::VERBOSE 0

# to compare older and newer files hpupdate creates
# a new timesstamp on file "hpupdate.ts" after every update
if { ![file exists $opt(TsFile)] } {Touch $opt(TsFile)}
set opt(Timestamp) [file mtime $opt(TsFile)]
set status(header) " last update: [clock format $opt(Timestamp) -format %d.%m.%Y\ %H:%M:%S\ Uhr -gmt 0]"

BusyCommand Refresh

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/ftp/mirror.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#!/bin/sh
# the next line restarts using tclsh \
exec tclsh8.3 "$0" -- "$@"

package require ftp 2.0

# user configuration
set server noname
set username anonymous
set passwd xxxxxx 

# simple progress display
proc ProgressBar {bytes} {
    puts -nonewline stdout "."; flush stdout
}

# recursive file transfer 
proc GetTree {conn {dir ""}} {
    catch {file mkdir $dir}
    foreach line [ftp::List $conn $dir] {
    	set rc [scan $line "%s %s %s %s %s %s %s %s %s %s %s" \
            perm l u g size d1 d2 d3 name link linksource]
	if { ($name == ".") || ($name == "..") } {continue}
        set type [string range $perm 0 0]
        set name [file join $dir $name]
        switch -- $type {
            d {GetTree $name}
            l {catch {exec ln -s $linksource $name} msg}
            - {ftp::Get $conn $name}
        }
    }
}

# main	
if {[set conn [ftp::Open $server $username $passwd -progress ProgressBar]] != -1} {
    GetTree $conn
    ftp::Close $conn
    puts "OK!"
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted examples/ftp/newer.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
#!/bin/sh
# the next line restarts using tclsh \
exec tclsh8.3 "$0" -- "$@"

package require ftp 2.0

if { [set conn [ftp::Open ftp.scriptics.com  anonymous xxxx]] != -1} {
    	if {[ftp::Newer $conn /pub/tcl/httpd/tclhttpd.tar.gz /usr/local/src/tclhttpd.tgz]} {
		exec echo "New httpd arrived!" | mailx -s ANNOUNCE root
	}
	ftp::Close $conn
}

<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted examples/ftpd/ftpd.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
#!/bin/sh 
# FTP daemon
# \
exec tclsh8.3 "$0" ${1+"$@"}

if {[catch {package require ftpd}]} {
    set here [file dirname [info script]]
    source [file join .. $here ftpd.tcl]
}

proc bgerror {args} {
    global errorInfo
    puts stderr "bgerror: [join $args]"
    puts stderr $errorInfo
}

::ftpd::server
vwait forever
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































Deleted examples/ftpd/ftpd.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
#!/bin/sh 
# FTP daemon for testing the ftp client (modules/ftp).
# -*- tcl -*- \
exec tclsh8.3 "$0" ${1+"$@"}

# This ftpd runs on port 7777, uses /tmp as root dir and does not do
# any authentication at all. IOW, do not run this server for longer
# periods of time or you create a security hole on your machine. This
# server is strictly for short testing the implementation of the ftp
# module over short periods of time.

package require ftpd
package require log

proc bgerror {args} {
    global errorInfo
    puts stderr "bgerror: [join $args]"
    puts stderr $errorInfo
}

proc ftplog {level text} {
    if {[string equal $level note]} {set level notice}
    log::log $level $text
}

proc noauth {args} {
    return 1
}

proc fakefs {cmd path args} {
    # Use the standard unix fs, i.e. "::ftpd::fsFile::fs", but rewrite the incoming path
    # to stay in the /tmp directory.

    set path [file join / tmp [file tail $path]]
    eval [linsert $args 0 ::ftpd::fsFile::fs $cmd $path]
}

::ftpd::config -logCmd ftplog -authUsrCmd noauth -authFileCmd noauth -fsCmd fakefs
set ::ftpd::port 7777 ; # Listen on user port

::ftpd::server
vwait forever
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































Deleted examples/ftpd/ftpd.unix.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
#!/bin/sh 
# FTP daemon
# \
exec tclsh8.3 "$0" ${1+"$@"}

if {[catch {package require ftpd}]} {
    set here [file dirname [info script]]
    source [file join .. $here ftpd.tcl]
}

proc bgerror {args} {
    global errorInfo
    puts stderr "bgerror: [join $args]"
    puts stderr $errorInfo
}

::ftpd::config -authUsrCmd ::ftpd::unixAuth
::ftpd::server
vwait forever
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted examples/irc/ChangeLog.

1
2
3
4
5
2003-01-30  David N. Welton  <[email protected]>

	* irc_example.tcl (client::connect): Added some more comments,
	  change the startup features.  Create ChangeLog.

<
<
<
<
<










Deleted examples/irc/irc_example.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
#!/bin/sh
# the next line restarts using tclsh \
	exec tclsh "$0" "$@"

# irc example script, by David N. Welton <[email protected]>
# $Id: irc_example.tcl,v 1.4 2003/01/31 02:52:49 davidw Exp $

# Pick up a nick from the command line, or default to TclIrc.

if { [lindex $argv 0] != "" } {
    set nick [lindex $argv 0]
} else {
    set nick TclIrc
}

# I include these so that it can find both the irc package and the
# logger package that irc needs.

set auto_path "[file join [file dirname [info script]] .. .. modules irc] $auto_path"
set auto_path "[file join [file dirname [info script]] .. .. modules log] $auto_path"
package require irc 0.3

namespace eval client {
    variable channel \#tcl
}

proc client::connect { nick } {
    variable channel
    set cn [::irc::connection irc.freenode.net 6667]
    set ns [namespace qualifiers $cn]

    # Register an event for the PING command that comes from the
    # server.
    $cn registerevent PING {
	network send "PONG [msg]"
	set ::PING 1
    }


    $cn registerevent 376 {
	set ::PING 1
    }

    # Register a default action for commands from the server.
    $cn registerevent defaultcmd {
	puts "[action] [msg]"
    }

    # Register a default action for numeric events from the server.
    $cn registerevent defaultnumeric {
	puts "[action] XXX [target] XXX [msg]"
    }

    # Register a default action for events.
    $cn registerevent defaultevent {
	puts "[action] XXX [who] XXX [target] XXX [msg]"
    }

    # Register a default action for PRIVMSG (either public or to a
    # channel).
    $cn registerevent PRIVMSG {
	puts "[who] says to [target] [msg]"
    }

    $cn registerevent KICK {
	puts "[who] KICKed [target 1] from [target] : [msg]"
    }

    # Connect to the server.
    $cn connect
    $cn user $nick localhost "www.tcl.tk"
    $cn nick $nick
    $cn join $channel

    vwait ::PING
    $cn join $channel
}

# Start things in motion.
client::connect $nick
vwait forever
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































Deleted examples/mime/mbot/README.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
<html><head><title>The README file: The personal.tcl Mailbot</title>
<meta http-equiv="Expires" content="Wed, 14 Aug 2002 20:43:57 +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-weight: bold;
              font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
     A:visited { color: #333333; font-weight: bold;
                 font-family: MS Sans Serif, verdana, charcoal, helvetica, arial, sans-serif }
     A:name { color: #333333; font-weight: bold;
              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 README file</td><td width="33%" bgcolor="#666666" class="header">M. 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 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 personal.tcl Mailbot</span></b></font></div>
<font face="verdana, helvetica, arial, sans-serif" size="2">

<h3>Abstract</h3>

<p>The personal.tcl mailbot implements a highly-specialized
filter for personal messages.
It MUST not be used by people who receive mailing list traffic in
their personal mailboxes.
</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;
PHILOSOPHY<br></b>
<b><a href="#anchor5">2.1</a>&nbsp;
Guest Lists<br></b>
<b><a href="#anchor6">3.</a>&nbsp;
BEHAVIOR<br></b>
<b><a href="#anchor7">3.1</a>&nbsp;
Arguments<br></b>
<b><a href="#actions">3.2</a>&nbsp;
Actions<br></b>
<b><a href="#configFile">3.3</a>&nbsp;
The Configuration File<br></b>
<b><a href="#options">3.3.1</a>&nbsp;
Configuration Options<br></b>
<b><a href="#procs">3.3.2</a>&nbsp;
Configurable Procedures<br></b>
<b><a href="#rfc.references1">&#167;</a>&nbsp;
References<br></b>
<b><a href="#rfc.authors">&#167;</a>&nbsp;
Author's Address<br></b>
<b><a href="#impersonal">A.</a>&nbsp;
Impersonal Mail<br></b>
<b><a href="#impersonal.options">A.1</a>&nbsp;
Configuration Options<br></b>
<b><a href="#options.foldersDirectory">A.1.1</a>&nbsp;
foldersDirectory<br></b>
<b><a href="#options.foldersFile">A.1.2</a>&nbsp;
foldersFile<br></b>
<b><a href="#options.announceMailboxes">A.1.3</a>&nbsp;
announceMailboxes<br></b>
<b><a href="#options.mappingFile">A.1.4</a>&nbsp;
mappingFile<br></b>
<b><a href="#impersonal.procs">A.2</a>&nbsp;
Configurable Procedures<br></b>
<b><a href="#procs.impersonalMail">A.2.1</a>&nbsp;
impersonalMail<br></b>
<b><a href="#procs.processFolder">A.2.2</a>&nbsp;
processFolder<br></b>
<b><a href="#anchor8">B.</a>&nbsp;
An Example configFile<br></b>
<b><a href="#anchor9">C.</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>
<a name="rfc.section.1"></a><h3>1.&nbsp;SYNOPSIS</h3>

<p>Create a <a href="#configFile">configuration file</a>
and add this line to your ".forward" file:
</p></font><pre>
    "| LIB/mbot-1.1/personal.tcl -config FILE -user USER"
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>where "LIB" is where the Tcl library lives,
"FILE" is the name of your configuration file,
and "USER" is your username.
</p>
<a name="rfc.section.1.1"></a><h4><a name="anchor2">1.1</a>&nbsp;Requirements</h4>

<p>This package requires:

<ul class="text">
<li><a href="http://sourceforge.net/projects/tcl/">Tcl version 8.3</a>
or later
</li>
<li><a href="http://sourceforge.net/projects/tcllib/">tcl lib</a>
</li>
<li><a href="http://sourceforge.net/projects/tclx/">TclX version 8.0</a>
or later
</li>
</ul><p>
</p>
<a name="rfc.section.1.2"></a><h4><a name="anchor3">1.2</a>&nbsp;Copyrights</h4>

<p>(c) 1999-2002 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>
<a name="rfc.section.2"></a><h3>2.&nbsp;PHILOSOPHY</h3>

<p>The mailbot's philosophy is simple:

<ul class="text">
<li>The mailbot receives all of your incoming personal mail.
</li>
<li>You ALWAYS copy yourself on every message you send,
so that the mailbot receives all of your outgoing personal mail.
</li>
<li>The mailbot performs six tasks, all optional:

<ul class="text">
<li>makes audit copies of your incoming and outgoing mail;
</li>
<li>performs duplicate supression;
</li>
<li>performs originator supression by rejecting messages from people
who aren't your friends or on a guest list;
</li>
<li>performs content supression by rejecting messages that contain
attachments with extensions on your prohibited list;
</li>
<li>sends a textual synopsis to your PDA; and,
</li>
<li>sends a copy to your remote mailbox.
</li>
</ul><p>
</li>
</ul><p>
</p>
<p>Do NOT use the personal.tcl mailbot if you receive mailing list
traffic in your personal mailbox.
When sending mail to a mailing list,
either:

<ul class="text">
<li>use a "From" address that the personal.tcl mailbot will process as
"impersonal" mail,
(e.g., "[email protected]"); or,
</li>
<li>set the "Reply-To" for the message to the mailing list.
</li>
</ul><p>
Consult <a href="#impersonal">Impersonal Mail</a> for information on how
"impersonal" mail is identified and processed.
</p>
<a name="rfc.section.2.1"></a><h4><a name="anchor5">2.1</a>&nbsp;Guest Lists</h4>

<p>Guest lists are an effective mechanism for cutting back on
excessive mail.

<ul class="text">
<li>when the mailbot receives a message from you,
it adds any recipients it finds to a permanent-guest list;
</li>
<li>when the mailbot receives a message from someone on a guest list,
it adds any recipients it finds to a temporary-guest list; but,
</li>
<li>when the mailbot receives a message from someone not on any guest
list,
they get a rejection notice.
</li>
</ul><p>
Note that in order to promote someone to the permanent-guest list,
you must send them a message (with a copy to yourself).
In most cases,
simply replying to the original message accomplishes this.
Of course,
if you don't want to promote someone to the permanent-guest list,
simply remove that address (or your address) from the list of
recipients in your reply.
</p>
<p>Here are the fine points:

<ul class="text">
<li>rejection notices contain a passphrase that may be used at most
once to bypass the guest list mechanism
(notices also contain the original message to minimize type-in
by the uninvited);
</li>
<li>a flip-flop is used to avoid mail loops; and,
</li>
<li>messages originated by an administrative address (e.g.,
"Postmaster") bypass the guest list mechanism
(unless the message refers to a previously-rejected message,
in which case it is supressed).
</li>
</ul><p>
</p>
<p>The rejection notice should be written carefully to minimize an
extreme negative reaction on the part of the uninvited.
Of course,
by allowing a passphrase,
this provides something of a CQ test for the uninvited --
if someone can't pass the test...
</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>
<a name="rfc.section.3"></a><h3>3.&nbsp;BEHAVIOR</h3>

<a name="rfc.section.3.1"></a><h4><a name="anchor7">3.1</a>&nbsp;Arguments</h4>

<p>The mailbot supports the following command line arguments:

<blockquote class="text"><dl>
<dt>   -config configFile:</dt>
<dd>
specifies the name of the configuration file to use;
</dd>
<dt>   -debug boolean:</dt>
<dd>
enables debug output;
</dd>
<dt>   -file messageFile:</dt>
<dd>
specifies the name of the file containing the message;
</dd>
<dt>   -originator orginatorAddress:</dt>
<dd>
specifies the email-address of the originator of the message; and,
</dd>
<dt>   -user userName:</dt>
<dd>
specifies the user-identity of the recipient.
</dd>
</dl></blockquote><p>
Note that if "-user" is given,
then the working directory is set to userName's home directory before
configFile is sourced,
and the umask is set defensively.
</p>
<p>The default values are:
</p></font><pre>
    personal.tcl -config     .personal-config.tcl   \
                 -debug      0                      \
                 -file       -                      \
                 -originator "derived from message"
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Given the default values,
only "-user" need be specified.
The reason is that if a message is being delivered to multiple local
recipients,
and if any of the ".forward" files are identical in content,
then sendmail may not deliver the message to all of the local
recipients.
</p>
<p>A few other (sendmail related) tips:

<ul class="text">
<li>If sendmail is configured with smrsh,
you'll need to symlink personal.tcl into the
/usr/libexec/sm.bin/ directory.
</li>
<li>Make sure that tclsh8.0 is in the path specified on the third-line
of personal.tcl.
</li>
<li>You should chmod your ".forward" file to 0600.
</li>
</ul><p>
</p>
<a name="rfc.section.3.2"></a><h4><a name="actions">3.2</a>&nbsp;Actions</h4>

<p>The mailbot begins by parsing its arguments,
sourcing configFile,
and then examining the incoming message:

<ol class="text">
<li>If <a href="#options.auditInFile">auditInFile</a> is set,
a copy of the message is 
<a href="#procs.saveMessage">saved</a> there.
</li>
<li>If the message contains a previously-encountered "Message-ID",
processing terminates.
</li>
<li>If the message's originator can not be determined,
a copy of the message is
<a href="#procs.saveMessage">saved</a> in the
<a href="#options.defaultMaildrop">defaultMaildrop</a> and
processing terminates.
</li>
<li>The originator's email-address is examined:

<ol class="text">
<li>If the originator appears to be an
<a href="#procs.adminP">automated administrative process</a>,
and if a previously rejected email-address is found in the message,
processing terminates.
</li>
<li>Otherwise,
if the originator isn't <a href="#procs.ownerP">the user</a>,
or <a href="#procs.friendP">a friend</a>,
or a permanent-access guest,
or a temporary-access guest,
and if <a href="#options.noticeFile">noticeFile</a> is set,
then the message is rejected.
</li>
<li>Otherwise,
each recipient email-address in the message's header is added to a guest
list.
(If the originator is <a href="#procs.ownerP">the user</a>,
the permanent-guest list is used instead of the temporary-guest
list.)
</li>
</ol><p>
</li>
<li>If the originator is the <a href="#procs.ownerP">the user</a>,
then:

<ol class="text">
<li>If <a href="#options.auditOutFile">auditOutFile</a> is set,
<a href="#procs.saveMessage">saved</a> there.
</li>
<li>Regardless, processing terminates.
</li>
</ol><p>
</li>
<li>If <a href="#options.pdaMailboxes">pdaMailboxes</a> is set,
and if any plaintext is contained in the message,
then the plaintext is sent to those email-addresses.
</li>
<li>If <a href="#options.remoteMailboxes">remoteMailboxes</a> is set,
and if the message is successful resent to those email-addresses,
then processing terminates.
</li>
<li>A copy of the message is
<a href="#procs.saveMessage">saved</a> in the
<a href="#options.defaultMaildrop">defaultMaildrop</a> and
processing terminates.
</li>
</ol><p>
</p>
<a name="rfc.section.3.3"></a><h4><a name="configFile">3.3</a>&nbsp;The Configuration File</h4>

<p>There are two kinds of information that may be defined in configFile:
<a href="#options">configuration options</a> and
<a href="#procs">configurable procedures</a>.
</p>
<p>Here's a simple example of a configFile for a user named
"example":
</p></font><pre>
    set options(dataDirectory)   .personal
    set options(defaultMaildrop) /var/mail/example
    set options(logFile)         [file join .personal personal.log]
    set options(noticeFile)      [file join .personal notice.txt]
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<a name="rfc.section.3.3.1"></a><h4><a name="options">3.3.1</a>&nbsp;Configuration Options</h4>

<p>configFile must define 
<a href="#options.dataDirectory">dataDirectory</a>
and
<a href="#options.defaultMaildrop">defaultMaildrop</a>.
All other configuration options are optional.
</p>
<a name="rfc.section.3.3.1.1"></a><h4><a name="options.dataDirectory">3.3.1.1</a>&nbsp;dataDirectory</h4>

<p>The directory where the mailbot keeps its databases.
The subdirectories are:

<blockquote class="text"><dl>
<dt>   badaddrs:</dt>
<dd>the directory of rejected email-addresses
</dd>
<dt>   inaddrs:</dt>
<dd>the directory of originator email-addresses
</dd>
<dt>   msgids:</dt>
<dd>the directory of Message-IDs
</dd>
<dt>   outaddrs:</dt>
<dd>the permanent-guest list
</dd>
<dt>   phrases:</dt>
<dd>the directory of at-most-once passphrases
</dd>
<dt>   tmpaddrs:</dt>
<dd>the temporary-guest list
</dd>
</dl></blockquote><p>
If you want to remove someone from a guest list,
simply go to that directory and delete the corresponding file.
</p>
<a name="rfc.section.3.3.1.2"></a><h4><a name="options.defaultMaildrop">3.3.1.2</a>&nbsp;defaultMaildrop</h4>

<p>The filename where messages are 
<a href="#procs.saveMessage">saved</a> for later viewing by
your user agent.
</p>
<a name="rfc.section.3.3.1.3"></a><h4><a name="options.auditInFile">3.3.1.3</a>&nbsp;auditInFile</h4>

<p>The filename where messages are
<a href="#procs.saveMessage">saved</a> for audit purposes.
</p>
<a name="rfc.section.3.3.1.4"></a><h4><a name="options.auditOutFile">3.3.1.4</a>&nbsp;auditOutFile</h4>

<p>The filename where your outgoing messages are
<a href="#procs.saveMessage">saved</a> for audit purposes.
</p>
<a name="rfc.section.3.3.1.5"></a><h4><a name="options.dropNames">3.3.1.5</a>&nbsp;dropNames</h4>

<p>A list of filename extensions for attachments that automatically
cause the message to be rejected.
</p>
<a name="rfc.section.3.3.1.6"></a><h4><a name="options.friendlyDomains">3.3.1.6</a>&nbsp;friendlyDomains</h4>

<p>A list used by <a href="#procs.friendP">friendP</a> giving
the domain names where your friends live.
</p>
<a name="rfc.section.3.3.1.7"></a><h4><a name="options.friendlyfire">3.3.1.7</a>&nbsp;friendlyfire</h4>

<p>If present and true,
then someone sending a message both to you and someone you've
previously sent mail to,
is considered a friend.
</p>
<a name="rfc.section.3.3.1.8"></a><h4><a name="options.logFile">3.3.1.8</a>&nbsp;logFile</h4>

<p>The filename where the mailbot
<a href="#procs.tclLog">logs</a> its actions.
</p>
<a name="rfc.section.3.3.1.9"></a><h4><a name="options.myMailbox">3.3.1.9</a>&nbsp;myMailbox</h4>

<p>Your preferred email-address with commentary text, e.g.,
</p></font><pre>
    Arlington Hewes &lt;[email protected]>
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<a name="rfc.section.3.3.1.10"></a><h4><a name="options.noticeFile">3.3.1.10</a>&nbsp;noticeFile</h4>

<p>The filename containing the textual notice sent when a message is
rejected.
Note that all occurrances of "%passPhrase%" within this file are
replaced with an at-most-once passphrase allowing the originator to
bypass the mailbot's filtering.
Similarly,
any occurrences of "%subject%" are replaced by the "Subject" of the
incoming message.
</p>
<a name="rfc.section.3.3.1.11"></a><h4><a name="options.pdaMailboxes">3.3.1.11</a>&nbsp;pdaMailboxes</h4>

<p>The email-addresses where a textual synopsis of the incoming message is
sent.
</p>
<a name="rfc.section.3.3.1.12"></a><h4><a name="options.remoteMailboxes">3.3.1.12</a>&nbsp;remoteMailboxes</h4>

<p>The email-addresses where a copy of the incoming message is resent.
</p>
<a name="rfc.section.3.3.2"></a><h4><a name="procs">3.3.2</a>&nbsp;Configurable Procedures</h4>

<p>All of these procedures are defined in personal.tcl.
You may override any of them in configFile.
</p>
<a name="rfc.section.3.3.2.1"></a><h4><a name="procs.adminP">3.3.2.1</a>&nbsp;adminP</h4>
</font><pre>
    proc adminP {local domain}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Returns "1" if the email-address is an automated administrative
process.
</p>
<a name="rfc.section.3.3.2.2"></a><h4><a name="procs.friendP">3.3.2.2</a>&nbsp;friendP</h4>
</font><pre>
    proc friendP {local domain}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Returns "1" if the email-address is from a
<a href="#options.friendlyDomains">friendly domain</a> or
sub-domain.
</p>
<a name="rfc.section.3.3.2.3"></a><h4><a name="procs.ownerP">3.3.2.3</a>&nbsp;ownerP</h4>
</font><pre>
    proc ownerP {local domain}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Returns "1" if the email-address refers to the user
(as determined by looking at
<a href="#options.myMailbox">myMailbox</a>,
<a href="#options.pdaMailboxes">pdaMailboxes</a>, and
<a href="#options.remoteMailboxes">remoteMailboxes</a>.
</p>
<a name="rfc.section.3.3.2.4"></a><h4><a name="procs.saveMessage">3.3.2.4</a>&nbsp;saveMessage</h4>
</font><pre>
    proc saveMessage {inF {outF ""}}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Saves a copy of the message contained in the file inF.
If the destination file,
outF,
isn't specified,
it defaults to the
<a href="#options.defaultMaildrop">defaultMaildrop</a>.
</p>
<a name="rfc.section.3.3.2.5"></a><h4><a name="procs.findPhrase">3.3.2.5</a>&nbsp;findPhrase</h4>
</font><pre>
    proc findPhrase {subject}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Returns "1" if a previously-allocated passphrase is present in the
subject.
If so,
the passphrase is forgotten.
</p>
<a name="rfc.section.3.3.2.6"></a><h4><a name="procs.makePhrase">3.3.2.6</a>&nbsp;makePhrase</h4>
</font><pre>
    proc makePhrase {}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Returns an at-most-once passphrase for use with a rejection notice.
</p>
<a name="rfc.section.3.3.2.7"></a><h4><a name="procs.pruneDir">3.3.2.7</a>&nbsp;pruneDir</h4>
</font><pre>
    proc pruneDir {dir type}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Removes old entries from one of the mailbot's 
<a href="#options.dataDirectory">databases</a>.
The second parameter is one of "addr", "msgid", or "phrase".
</p>
<a name="rfc.section.3.3.2.8"></a><h4><a name="procs.tclLog">3.3.2.8</a>&nbsp;tclLog</h4>
</font><pre>
    proc tclLog {message}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Writes a message to the <a href="#options.logFile">logFile</a>.
</p>
<a name="rfc.references1"><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">
</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:[email protected]">[email protected]</a></td></tr>
</table>

<a name="impersonal"><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>
<a name="rfc.section.A"></a><h3>Appendix A.&nbsp;Impersonal Mail</h3>

<p>If <a href="#procs.impersonalMail">impersonalMail</a>
returns a non-empty string
then the message is processed differently than the algorithm given in
<a href="#actions">Actions</a>.
Specifically:

<ol class="text">
<li>If the message contains a previously-encountered "Message-ID",
processing terminates.
</li>
<li>If the message's originator can not be determined,
processing terminates.
</li>
<li>The value returned by
<a href="#procs.impersonalMail">impersonalMail</a>
is the folder's name and is broken into one or more components
seperated by dots (".").
If there aren't at least two components,
or if any of the components are empty
(e.g., the folder is named "sys..announce"),
then the message is bounced.
</li>
<li>If <a href="#options.mappingFile">mappingFile</a> exists,
that file is examined to see if an entry is present for the folder.
If so,
the message is processed according to the value present,
one of:

<blockquote class="text"><dl>
<dt>     "ignore":</dt>
<dd>the message is silently ignored;
</dd>
<dt>     "bounce":</dt>
<dd>the message is noisily bounced; or,
</dd>
<dt>    otherwise:</dt>
<dd>the message is resent to the address.
</dd>
</dl></blockquote><p>
Regardless,
if an entry was present for the folder,
then processing terminates.
</li>
<li>The message is <a href="#procs.saveMessage">saved</a> 
in a file whose name is constructed by replacing each dot (".") in the
folder name with a directory seperator
(e.g., if the folder is named "sys.announce",
then the file is called "announce" underneath the directory "sys"
underneath the directory identified by
<a href="#options.foldersDirectory">foldersDirectory</a>.
</li>
<li>Finally,
the file identified by <a href="#options.foldersFile">foldersFile</a>
is updated as necessary.
</li>
</ol><p>
</p>
<a name="rfc.section.A.1"></a><h4><a name="impersonal.options">A.1</a>&nbsp;Configuration Options</h4>

<p>If "impersonal" mail is received,
then <a href="#options.foldersFile">foldersFile</a> and
<a href="#options.foldersDirectory">foldersDirectory</a> 
must exist.
</p>
<a name="rfc.section.A.1.1"></a><h4><a name="options.foldersDirectory">A.1.1</a>&nbsp;foldersDirectory</h4>

<p>The directory where the mailbot keeps private folders.
</p>
<a name="rfc.section.A.1.2"></a><h4><a name="options.foldersFile">A.1.2</a>&nbsp;foldersFile</h4>

<p>This file contains one line for each private folder.
</p>
<a name="rfc.section.A.1.3"></a><h4><a name="options.announceMailboxes">A.1.3</a>&nbsp;announceMailboxes</h4>

<p>The email-addresses where an announcement is sent when a new
private folder is created.
</p>
<a name="rfc.section.A.1.4"></a><h4><a name="options.mappingFile">A.1.4</a>&nbsp;mappingFile</h4>

<p>The file consulted by the mailbot to determine how to process
"impersonal" messages.
Each line of the file consists of a folder name and value,
seperated by a colon (":").
There are three reserved values: "bounce", "ignore", and "store".
</p>
<a name="rfc.section.A.2"></a><h4><a name="impersonal.procs">A.2</a>&nbsp;Configurable Procedures</h4>

<p>All of these procedures are defined in personal.tcl.
You may override any of them in configFile.
</p>
<a name="rfc.section.A.2.1"></a><h4><a name="procs.impersonalMail">A.2.1</a>&nbsp;impersonalMail</h4>
</font><pre>
    proc impersonalMail {}
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>If the message is deemed "impersonal",
return the name of a corresponding private folder;
otherwise,
return the empty-string.
</p>
<p>Many mail systems have a mechanism of passing additional
information when performing final delivery using a program.
With modern versions of sendmail,
for example,
if mail is sent to a local user named "user+detail",
then,
in the absense of an alias for either "user+detail" or "user+*",
then the message is delivered to "user".
The trick is to get sendmail to pass the "detail" part to the mailbot.
</p>
<p>At present,
sendmail passes this information only if procmail is your local
mailer.
Here's how I do it:
</p></font><pre>
    *** _alias.c    Tue Dec 29 10:42:25 1998
    --- alias.c     Sat Sep 18 21:51:35 1999
    ***************
    *** 813,818 ****
    --- 813,821 ----
            define('z', user->q_home, e);
            define('u', user->q_user, e);
            define('h', user->q_host, e);
    + 
    +       setuserenv("SUFFIX", user->q_host);
    + 
            if (ForwardPath == NULL)
                    ForwardPath = newstr("\201z/.forward");
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>This makes available an environment variable called
"SUFFIX" which has the "details" part.
The drawback in this approach is that this information is lost if the
message is re-queued for delivery
(what's really needed is an addition to the .forward syntax to allow
macros such as $h to be passed).
</p>
<p>The corresponding impersonalMail procedure is defined as:
</p></font><pre>
    proc impersonalMail {} {
        global env

        return $env(SUFFIX)
    }
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<a name="rfc.section.A.2.2"></a><h4><a name="procs.processFolder">A.2.2</a>&nbsp;processFolder</h4>
</font><pre>
    proc processFolder {folderName mimeT} { return $string }
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>If an entry for the folder exists in the
<a href="#options.mappingFile">mappingFile</a>,
and if the value for that entry is "process",
then this procedure is invoked to return a string indicating what
action to take
(cf., <a href="#impersonal">Impersonal Mail</a>).
</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>
<a name="rfc.section.B"></a><h3>Appendix B.&nbsp;An Example configFile</h3>

<p>Here is the ".forward" file for the user "hewes":
</p></font><pre>
    "|/usr/pkg/lib/mbot-1.1/personal.tcl 
         -config .personal/config.tcl -user hewes"
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>(Of course, it's all on one line.)
</p>
<p>Here is the user's ".personal/config.tcl" file:
</p></font><pre>
    array set options [list                                          \
        dataDirectory     .personal                                  \
        defaultMaildrop   /var/mail/hewes                            \
        auditInFile       [file join .personal INCOMING]             \
        auditOutFile      [file join .personal OUTGOING]             \
        friendlyDomains   [list tcp.int example.com]                 \
        logFile           [file join .personal personal.log]         \
        myMailbox         "Arlington Hewes &lt;[email protected]>"      \
        pdaMailboxes      [email protected]                    \
        noticeFile        [file join .personal notice.txt]           \
        foldersDirectory  [file join .personal folders]              \
        foldersFile       [file join .personal .mailboxlist]         \
        announceMailboxes [email protected]             \
        mappingFile       [file join .personal mapping]              \
        friendlyFire      1                                          \
        dropNames         [list *.bat *.exe *.src *.pif *.wav *.vbs] \
    ]

    proc impersonalMail {} {
        global env

        return $env(SUFFIX)
    }
</pre><font face="verdana, helvetica, arial, sans-serif" size="2">

<p>Note that because
<a href="#options.remoteMailboxes">remoteMailboxes</a> isn't
defined,
personal messages are ultimately stored in the user's
<a href="#options.defaultMaildrop">defaultMaildrop</a>.
</p>
<a name="anchor9"><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>
<a name="rfc.section.C"></a><h3>Appendix C.&nbsp;Acknowledgements</h3>

<p>The original version of this mailbot was written by the author in 1994,
implemented using  the safe-tcl package
(Borenstein and Rose, circa 1993).
</p></font></body></html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/mime/mbot/README.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008


The README file                                                  M. Rose
                                            Dover Beach Consulting, Inc.
                                                           February 2002


                        The personal.tcl Mailbot


Abstract

   The personal.tcl mailbot implements a highly-specialized filter for
   personal messages.  It MUST not be used by people who receive mailing
   list traffic in their personal mailboxes.

Table of Contents

   1.    SYNOPSIS . . . . . . . . . . . . . . . . . . . . . . . . . .  2
   1.1   Requirements . . . . . . . . . . . . . . . . . . . . . . . .  2
   1.2   Copyrights . . . . . . . . . . . . . . . . . . . . . . . . .  2
   2.    PHILOSOPHY . . . . . . . . . . . . . . . . . . . . . . . . .  3
   2.1   Guest Lists  . . . . . . . . . . . . . . . . . . . . . . . .  4
   3.    BEHAVIOR . . . . . . . . . . . . . . . . . . . . . . . . . .  5
   3.1   Arguments  . . . . . . . . . . . . . . . . . . . . . . . . .  5
   3.2   Actions  . . . . . . . . . . . . . . . . . . . . . . . . . .  6
   3.3   The Configuration File . . . . . . . . . . . . . . . . . . .  7
   3.3.1 Configuration Options  . . . . . . . . . . . . . . . . . . .  7
   3.3.2 Configurable Procedures  . . . . . . . . . . . . . . . . . . 10
         References . . . . . . . . . . . . . . . . . . . . . . . . . 12
         Author's Address . . . . . . . . . . . . . . . . . . . . . . 12
   A.    Impersonal Mail  . . . . . . . . . . . . . . . . . . . . . . 13
   A.1   Configuration Options  . . . . . . . . . . . . . . . . . . . 14
   A.1.1 foldersDirectory . . . . . . . . . . . . . . . . . . . . . . 14
   A.1.2 foldersFile  . . . . . . . . . . . . . . . . . . . . . . . . 14
   A.1.3 announceMailboxes  . . . . . . . . . . . . . . . . . . . . . 14
   A.1.4 mappingFile  . . . . . . . . . . . . . . . . . . . . . . . . 14
   A.2   Configurable Procedures  . . . . . . . . . . . . . . . . . . 15
   A.2.1 impersonalMail . . . . . . . . . . . . . . . . . . . . . . . 15
   A.2.2 processFolder  . . . . . . . . . . . . . . . . . . . . . . . 16
   B.    An Example configFile  . . . . . . . . . . . . . . . . . . . 17
   C.    Acknowledgements . . . . . . . . . . . . . . . . . . . . . . 18












Rose                                                            [Page 1]

README                  The personal.tcl Mailbot           February 2002


1. SYNOPSIS

   Create a configuration file (Section 3.3) and add this line to your
   ".forward" file:

       "| LIB/mbot-1.1/personal.tcl -config FILE -user USER"

   where "LIB" is where the Tcl library lives, "FILE" is the name of
   your configuration file, and "USER" is your username.

1.1 Requirements

   This package requires:

   o  Tcl version 8.3 [1] or later

   o  tcl lib [2]

   o  TclX version 8.0 [3] or later


1.2 Copyrights

   (c) 1999-2002 Marshall T.  Rose

   Hold harmless the author, and any lawful use is allowed.

























Rose                                                            [Page 2]

README                  The personal.tcl Mailbot           February 2002


2. PHILOSOPHY

   The mailbot's philosophy is simple:

   o  The mailbot receives all of your incoming personal mail.

   o  You ALWAYS copy yourself on every message you send, so that the
      mailbot receives all of your outgoing personal mail.

   o  The mailbot performs six tasks, all optional:

      *  makes audit copies of your incoming and outgoing mail;

      *  performs duplicate supression;

      *  performs originator supression by rejecting messages from
         people who aren't your friends or on a guest list;

      *  performs content supression by rejecting messages that contain
         attachments with extensions on your prohibited list;

      *  sends a textual synopsis to your PDA; and,

      *  sends a copy to your remote mailbox.

   Do NOT use the personal.tcl mailbot if you receive mailing list
   traffic in your personal mailbox.  When sending mail to a mailing
   list, either:

   o  use a "From" address that the personal.tcl mailbot will process as
      "impersonal" mail, (e.g., "[email protected]"); or,

   o  set the "Reply-To" for the message to the mailing list.

   Consult Appendix A for information on how "impersonal" mail is
   identified and processed.















Rose                                                            [Page 3]

README                  The personal.tcl Mailbot           February 2002


2.1 Guest Lists

   Guest lists are an effective mechanism for cutting back on excessive
   mail.

   o  when the mailbot receives a message from you, it adds any
      recipients it finds to a permanent-guest list;

   o  when the mailbot receives a message from someone on a guest list,
      it adds any recipients it finds to a temporary-guest list; but,

   o  when the mailbot receives a message from someone not on any guest
      list, they get a rejection notice.

   Note that in order to promote someone to the permanent-guest list,
   you must send them a message (with a copy to yourself).  In most
   cases, simply replying to the original message accomplishes this.  Of
   course, if you don't want to promote someone to the permanent-guest
   list, simply remove that address (or your address) from the list of
   recipients in your reply.

   Here are the fine points:

   o  rejection notices contain a passphrase that may be used at most
      once to bypass the guest list mechanism (notices also contain the
      original message to minimize type-in by the uninvited);

   o  a flip-flop is used to avoid mail loops; and,

   o  messages originated by an administrative address (e.g.,
      "Postmaster") bypass the guest list mechanism (unless the message
      refers to a previously-rejected message, in which case it is
      supressed).

   The rejection notice should be written carefully to minimize an
   extreme negative reaction on the part of the uninvited.  Of course,
   by allowing a passphrase, this provides something of a CQ test for
   the uninvited -- if someone can't pass the test...













Rose                                                            [Page 4]

README                  The personal.tcl Mailbot           February 2002


3. BEHAVIOR

3.1 Arguments

   The mailbot supports the following command line arguments:

      -config configFile: specifies the name of the configuration file
      to use;

      -debug boolean: enables debug output;

      -file messageFile: specifies the name of the file containing the
      message;

      -originator orginatorAddress: specifies the email-address of the
      originator of the message; and,

      -user userName: specifies the user-identity of the recipient.

   Note that if "-user" is given, then the working directory is set to
   userName's home directory before configFile is sourced, and the umask
   is set defensively.

   The default values are:

       personal.tcl -config     .personal-config.tcl   \
                    -debug      0                      \
                    -file       -                      \
                    -originator "derived from message"

   Given the default values, only "-user" need be specified.  The reason
   is that if a message is being delivered to multiple local recipients,
   and if any of the ".forward" files are identical in content, then
   sendmail may not deliver the message to all of the local recipients.

   A few other (sendmail related) tips:

   o  If sendmail is configured with smrsh, you'll need to symlink
      personal.tcl into the /usr/libexec/sm.bin/ directory.

   o  Make sure that tclsh8.0 is in the path specified on the third-line
      of personal.tcl.

   o  You should chmod your ".forward" file to 0600.







Rose                                                            [Page 5]

README                  The personal.tcl Mailbot           February 2002


3.2 Actions

   The mailbot begins by parsing its arguments, sourcing configFile, and
   then examining the incoming message:

   1.  If auditInFile (Section 3.3.1.3) is set, a copy of the message is
       saved (Section 3.3.2.4) there.

   2.  If the message contains a previously-encountered "Message-ID",
       processing terminates.

   3.  If the message's originator can not be determined, a copy of the
       message is saved (Section 3.3.2.4) in the defaultMaildrop
       (Section 3.3.1.2) and processing terminates.

   4.  The originator's email-address is examined:

       1.  If the originator appears to be an automated administrative
           process (Section 3.3.2.1), and if a previously rejected
           email-address is found in the message, processing terminates.

       2.  Otherwise, if the originator isn't the user (Section
           3.3.2.3), or a friend (Section 3.3.2.2), or a permanent-
           access guest, or a temporary-access guest, and if noticeFile
           (Section 3.3.1.10) is set, then the message is rejected.

       3.  Otherwise, each recipient email-address in the message's
           header is added to a guest list.  (If the originator is the
           user (Section 3.3.2.3), the permanent-guest list is used
           instead of the temporary-guest list.)

   5.  If the originator is the the user (Section 3.3.2.3), then:

       1.  If auditOutFile (Section 3.3.1.4) is set, saved (Section
           3.3.2.4) there.

       2.  Regardless, processing terminates.

   6.  If pdaMailboxes (Section 3.3.1.11) is set, and if any plaintext
       is contained in the message, then the plaintext is sent to those
       email-addresses.

   7.  If remoteMailboxes (Section 3.3.1.12) is set, and if the message
       is successful resent to those email-addresses, then processing
       terminates.

   8.  A copy of the message is saved (Section 3.3.2.4) in the
       defaultMaildrop (Section 3.3.1.2) and processing terminates.



Rose                                                            [Page 6]

README                  The personal.tcl Mailbot           February 2002


3.3 The Configuration File

   There are two kinds of information that may be defined in configFile:
   configuration options (Section 3.3.1) and configurable procedures
   (Section 3.3.2).

   Here's a simple example of a configFile for a user named "example":

       set options(dataDirectory)   .personal
       set options(defaultMaildrop) /var/mail/example
       set options(logFile)         [file join .personal personal.log]
       set options(noticeFile)      [file join .personal notice.txt]


3.3.1 Configuration Options

   configFile must define dataDirectory (Section 3.3.1.1) and
   defaultMaildrop (Section 3.3.1.2).  All other configuration options
   are optional.

3.3.1.1 dataDirectory

   The directory where the mailbot keeps its databases.  The
   subdirectories are:

      badaddrs: the directory of rejected email-addresses

      inaddrs: the directory of originator email-addresses

      msgids: the directory of Message-IDs

      outaddrs: the permanent-guest list

      phrases: the directory of at-most-once passphrases

      tmpaddrs: the temporary-guest list

   If you want to remove someone from a guest list, simply go to that
   directory and delete the corresponding file.

3.3.1.2 defaultMaildrop

   The filename where messages are saved (Section 3.3.2.4) for later
   viewing by your user agent.

3.3.1.3 auditInFile

   The filename where messages are saved (Section 3.3.2.4) for audit



Rose                                                            [Page 7]

README                  The personal.tcl Mailbot           February 2002


   purposes.

3.3.1.4 auditOutFile

   The filename where your outgoing messages are saved (Section 3.3.2.4)
   for audit purposes.

3.3.1.5 dropNames

   A list of filename extensions for attachments that automatically
   cause the message to be rejected.

3.3.1.6 friendlyDomains

   A list used by friendP (Section 3.3.2.2) giving the domain names
   where your friends live.

3.3.1.7 friendlyfire

   If present and true, then someone sending a message both to you and
   someone you've previously sent mail to, is considered a friend.

3.3.1.8 logFile

   The filename where the mailbot logs (Section 3.3.2.8) its actions.

3.3.1.9 myMailbox

   Your preferred email-address with commentary text, e.g.,

       Arlington Hewes <[email protected]>


3.3.1.10 noticeFile

   The filename containing the textual notice sent when a message is
   rejected.  Note that all occurrances of "%passPhrase%" within this
   file are replaced with an at-most-once passphrase allowing the
   originator to bypass the mailbot's filtering.  Similarly, any
   occurrences of "%subject%" are replaced by the "Subject" of the
   incoming message.

3.3.1.11 pdaMailboxes

   The email-addresses where a textual synopsis of the incoming message
   is sent.





Rose                                                            [Page 8]

README                  The personal.tcl Mailbot           February 2002


3.3.1.12 remoteMailboxes

   The email-addresses where a copy of the incoming message is resent.
















































Rose                                                            [Page 9]

README                  The personal.tcl Mailbot           February 2002


3.3.2 Configurable Procedures

   All of these procedures are defined in personal.tcl.  You may
   override any of them in configFile.

3.3.2.1 adminP

       proc adminP {local domain}

   Returns "1" if the email-address is an automated administrative
   process.

3.3.2.2 friendP

       proc friendP {local domain}

   Returns "1" if the email-address is from a friendly domain (Section
   3.3.1.6) or sub-domain.

3.3.2.3 ownerP

       proc ownerP {local domain}

   Returns "1" if the email-address refers to the user (as determined by
   looking at myMailbox (Section 3.3.1.9), pdaMailboxes (Section
   3.3.1.11), and remoteMailboxes (Section 3.3.1.12).

3.3.2.4 saveMessage

       proc saveMessage {inF {outF ""}}

   Saves a copy of the message contained in the file inF.  If the
   destination file, outF, isn't specified, it defaults to the
   defaultMaildrop (Section 3.3.1.2).

3.3.2.5 findPhrase

       proc findPhrase {subject}

   Returns "1" if a previously-allocated passphrase is present in the
   subject.  If so, the passphrase is forgotten.

3.3.2.6 makePhrase

       proc makePhrase {}

   Returns an at-most-once passphrase for use with a rejection notice.




Rose                                                           [Page 10]

README                  The personal.tcl Mailbot           February 2002


3.3.2.7 pruneDir

       proc pruneDir {dir type}

   Removes old entries from one of the mailbot's databases (Section
   3.3.1.1).  The second parameter is one of "addr", "msgid", or
   "phrase".

3.3.2.8 tclLog

       proc tclLog {message}

   Writes a message to the logFile (Section 3.3.1.8).






































Rose                                                           [Page 11]

README                  The personal.tcl Mailbot           February 2002


References

   [1]  <http://sourceforge.net/projects/tcl/>

   [2]  <http://sourceforge.net/projects/tcllib/>

   [3]  <http://sourceforge.net/projects/tclx/>


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: [email protected]































Rose                                                           [Page 12]

README                  The personal.tcl Mailbot           February 2002


Appendix A. Impersonal Mail

   If impersonalMail (Appendix A.2.1) returns a non-empty string then
   the message is processed differently than the algorithm given in
   Section 3.2.  Specifically:

   1.  If the message contains a previously-encountered "Message-ID",
       processing terminates.

   2.  If the message's originator can not be determined, processing
       terminates.

   3.  The value returned by impersonalMail (Appendix A.2.1) is the
       folder's name and is broken into one or more components seperated
       by dots (".").  If there aren't at least two components, or if
       any of the components are empty (e.g., the folder is named
       "sys..announce"), then the message is bounced.

   4.  If mappingFile (Appendix A.1.4) exists, that file is examined to
       see if an entry is present for the folder.  If so, the message is
       processed according to the value present, one of:

            "ignore": the message is silently ignored;

            "bounce": the message is noisily bounced; or,

           otherwise: the message is resent to the address.

       Regardless, if an entry was present for the folder, then
       processing terminates.

   5.  The message is saved (Section 3.3.2.4) in a file whose name is
       constructed by replacing each dot (".") in the folder name with a
       directory seperator (e.g., if the folder is named "sys.announce",
       then the file is called "announce" underneath the directory "sys"
       underneath the directory identified by foldersDirectory (Appendix
       A.1.1).

   6.  Finally, the file identified by foldersFile (Appendix A.1.2) is
       updated as necessary.











Rose                                                           [Page 13]

README                  The personal.tcl Mailbot           February 2002


A.1 Configuration Options

   If "impersonal" mail is received, then foldersFile (Appendix A.1.2)
   and foldersDirectory (Appendix A.1.1) must exist.

A.1.1 foldersDirectory

   The directory where the mailbot keeps private folders.

A.1.2 foldersFile

   This file contains one line for each private folder.

A.1.3 announceMailboxes

   The email-addresses where an announcement is sent when a new private
   folder is created.

A.1.4 mappingFile

   The file consulted by the mailbot to determine how to process
   "impersonal" messages.  Each line of the file consists of a folder
   name and value, seperated by a colon (":").  There are three reserved
   values: "bounce", "ignore", and "store".



























Rose                                                           [Page 14]

README                  The personal.tcl Mailbot           February 2002


A.2 Configurable Procedures

   All of these procedures are defined in personal.tcl.  You may
   override any of them in configFile.

A.2.1 impersonalMail

       proc impersonalMail {}

   If the message is deemed "impersonal", return the name of a
   corresponding private folder; otherwise, return the empty-string.

   Many mail systems have a mechanism of passing additional information
   when performing final delivery using a program.  With modern versions
   of sendmail, for example, if mail is sent to a local user named
   "user+detail", then, in the absense of an alias for either
   "user+detail" or "user+*", then the message is delivered to "user".
   The trick is to get sendmail to pass the "detail" part to the
   mailbot.

   At present, sendmail passes this information only if procmail is your
   local mailer.  Here's how I do it:

       *** _alias.c    Tue Dec 29 10:42:25 1998
       --- alias.c     Sat Sep 18 21:51:35 1999
       ***************
       *** 813,818 ****
       --- 813,821 ----
               define('z', user->q_home, e);
               define('u', user->q_user, e);
               define('h', user->q_host, e);
       +
       +       setuserenv("SUFFIX", user->q_host);
       +
               if (ForwardPath == NULL)
                       ForwardPath = newstr("\201z/.forward");

   This makes available an environment variable called "SUFFIX" which
   has the "details" part.  The drawback in this approach is that this
   information is lost if the message is re-queued for delivery (what's
   really needed is an addition to the .forward syntax to allow macros
   such as $h to be passed).









Rose                                                           [Page 15]

README                  The personal.tcl Mailbot           February 2002


   The corresponding impersonalMail procedure is defined as:

       proc impersonalMail {} {
           global env

           return $env(SUFFIX)
       }


A.2.2 processFolder

       proc processFolder {folderName mimeT} { return $string }

   If an entry for the folder exists in the mappingFile (Appendix
   A.1.4), and if the value for that entry is "process", then this
   procedure is invoked to return a string indicating what action to
   take (cf., Appendix A).


































Rose                                                           [Page 16]

README                  The personal.tcl Mailbot           February 2002


Appendix B. An Example configFile

   Here is the ".forward" file for the user "hewes":

       "|/usr/pkg/lib/mbot-1.1/personal.tcl
            -config .personal/config.tcl -user hewes"

   (Of course, it's all on one line.)

   Here is the user's ".personal/config.tcl" file:

       array set options [list                                          \
           dataDirectory     .personal                                  \
           defaultMaildrop   /var/mail/hewes                            \
           auditInFile       [file join .personal INCOMING]             \
           auditOutFile      [file join .personal OUTGOING]             \
           friendlyDomains   [list tcp.int example.com]                 \
           logFile           [file join .personal personal.log]         \
           myMailbox         "Arlington Hewes <[email protected]>"      \
           pdaMailboxes      [email protected]                    \
           noticeFile        [file join .personal notice.txt]           \
           foldersDirectory  [file join .personal folders]              \
           foldersFile       [file join .personal .mailboxlist]         \
           announceMailboxes [email protected]             \
           mappingFile       [file join .personal mapping]              \
           friendlyFire      1                                          \
           dropNames         [list *.bat *.exe *.src *.pif *.wav *.vbs] \
       ]

       proc impersonalMail {} {
           global env

           return $env(SUFFIX)
       }

   Note that because remoteMailboxes (Section 3.3.1.12) isn't defined,
   personal messages are ultimately stored in the user's defaultMaildrop
   (Section 3.3.1.2).













Rose                                                           [Page 17]

README                  The personal.tcl Mailbot           February 2002


Appendix C. Acknowledgements

   The original version of this mailbot was written by the author in
   1994, implemented using  the safe-tcl package (Borenstein and Rose,
   circa 1993).














































Rose                                                           [Page 18]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/mime/mbot/README.xml.

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

<date month="February" year="2002" />

<abstract><t>The personal.tcl mailbot implements a highly-specialized
filter for personal messages.
It MUST not be used by people who receive mailing list traffic in
their personal mailboxes.</t></abstract>
</front>

<middle>
<section title="SYNOPSIS">
<figure>
<preamble>Create a <xref target="configFile">configuration file</xref>
and add this line to your ".forward" file:</preamble>
<artwork><![CDATA[
    "| LIB/mbot-1.1/personal.tcl -config FILE -user USER"
]]></artwork>
<postamble>where "LIB" is where the Tcl library lives,
"FILE" is the name of your configuration file,
and "USER" is your username.</postamble>
</figure>

<section title="Requirements">
<t>This package requires:
<list style="symbols">
<t><eref target="http://sourceforge.net/projects/tcl/">Tcl version 8.3</eref>
or later</t>

<t><eref target="http://sourceforge.net/projects/tcllib/">tcl lib</eref></t>

<t><eref target="http://sourceforge.net/projects/tclx/">TclX version 8.0</eref>
or later</t>
</list></t>
</section>

<section title="Copyrights">
<t>(c) 1999-2002 Marshall T. Rose</t>

<t>Hold harmless the author, and any lawful use is allowed.</t>
</section>
</section>

<section title="PHILOSOPHY">
<t>The mailbot's philosophy is simple:
<list style="symbols">
<t>The mailbot receives all of your incoming personal mail.</t>

<t>You ALWAYS copy yourself on every message you send,
so that the mailbot receives all of your outgoing personal mail.</t>

<t>The mailbot performs six tasks, all optional:
<list>
<t>makes audit copies of your incoming and outgoing mail;</t>

<t>performs duplicate supression;</t>

<t>performs originator supression by rejecting messages from people
who aren't your friends or on a guest list;</t>

<t>performs content supression by rejecting messages that contain
attachments with extensions on your prohibited list;</t>

<t>sends a textual synopsis to your PDA; and,</t>

<t>sends a copy to your remote mailbox.</t>
</list></t>
</list></t>

<t>Do NOT use the personal.tcl mailbot if you receive mailing list
traffic in your personal mailbox.
When sending mail to a mailing list,
either:
<list style="symbols">
<t>use a "From" address that the personal.tcl mailbot will process as
"impersonal" mail,
(e.g., "[email protected]"); or,</t>

<t>set the "Reply-To" for the message to the mailing list.</t>
</list>
Consult <xref target="impersonal" /> for information on how
"impersonal" mail is identified and processed.</t>

<vspace blankLines="10000" />

<section title="Guest Lists">
<t>Guest lists are an effective mechanism for cutting back on
excessive mail.
<list style="symbols">
<t>when the mailbot receives a message from you,
it adds any recipients it finds to a permanent-guest list;</t>

<t>when the mailbot receives a message from someone on a guest list,
it adds any recipients it finds to a temporary-guest list; but,</t>

<t>when the mailbot receives a message from someone not on any guest
list,
they get a rejection notice.</t>
</list>
Note that in order to promote someone to the permanent-guest list,
you must send them a message (with a copy to yourself).
In most cases,
simply replying to the original message accomplishes this.
Of course,
if you don't want to promote someone to the permanent-guest list,
simply remove that address (or your address) from the list of
recipients in your reply.</t>

<t>Here are the fine points:
<list style="symbols">
<t>rejection notices contain a passphrase that may be used at most
once to bypass the guest list mechanism
(notices also contain the original message to minimize type-in
by the uninvited);</t>

<t>a flip-flop is used to avoid mail loops; and,</t>

<t>messages originated by an administrative address (e.g.,
"Postmaster") bypass the guest list mechanism
(unless the message refers to a previously-rejected message,
in which case it is supressed).</t>
</list></t>

<t>The rejection notice should be written carefully to minimize an
extreme negative reaction on the part of the uninvited.
Of course,
by allowing a passphrase,
this provides something of a CQ test for the uninvited --
if someone can't pass the test...</t>
</section>
</section>

<section title="BEHAVIOR">
<section title="Arguments">
<t>The mailbot supports the following command line arguments:
<list style="hanging">
<t hangText="   -config configFile:">
specifies the name of the configuration file to use;</t>

<t hangText="   -debug boolean:">
enables debug output;</t>

<t hangText="   -file messageFile:">
specifies the name of the file containing the message;</t>

<t hangText="   -originator orginatorAddress:">
specifies the email-address of the originator of the message; and,</t>

<t hangText="   -user userName:">
specifies the user-identity of the recipient.</t>
</list>
Note that if "-user" is given,
then the working directory is set to userName's home directory before
configFile is sourced,
and the umask is set defensively.</t>

<figure>
<preamble>The default values are:</preamble>
<artwork><![CDATA[
    personal.tcl -config     .personal-config.tcl   \
                 -debug      0                      \
                 -file       -                      \
                 -originator "derived from message"
]]></artwork>
<postamble>Given the default values,
only "-user" need be specified.
The reason is that if a message is being delivered to multiple local
recipients,
and if any of the ".forward" files are identical in content,
then sendmail may not deliver the message to all of the local
recipients.</postamble>
</figure>

<t>A few other (sendmail related) tips:
<list style="symbols">
<t>If sendmail is configured with smrsh,
you'll need to symlink personal.tcl into the
/usr/libexec/sm.bin/ directory.</t>

<t>Make sure that tclsh8.0 is in the path specified on the third-line
of personal.tcl.</t>

<t>You should chmod your ".forward" file to 0600.</t>
</list></t>
</section>

<vspace blankLines="10000" />

<section anchor="actions" title="Actions">
<t>The mailbot begins by parsing its arguments,
sourcing configFile,
and then examining the incoming message:
<list style="numbers">
<t>If <xref target="options.auditInFile">auditInFile</xref> is set,
a copy of the message is 
<xref target="procs.saveMessage">saved</xref> there.</t>

<t>If the message contains a previously-encountered "Message-ID",
processing terminates.</t>

<t>If the message's originator can not be determined,
a copy of the message is
<xref target="procs.saveMessage">saved</xref> in the
<xref target="options.defaultMaildrop">defaultMaildrop</xref> and
processing terminates.</t>

<t>The originator's email-address is examined:
<list>
<t>If the originator appears to be an
<xref target="procs.adminP">automated administrative process</xref>,
and if a previously rejected email-address is found in the message,
processing terminates.</t>

<t>Otherwise,
if the originator isn't <xref target="procs.ownerP">the user</xref>,
or <xref target="procs.friendP">a friend</xref>,
or a permanent-access guest,
or a temporary-access guest,
and if <xref target="options.noticeFile">noticeFile</xref> is set,
then the message is rejected.</t>

<t>Otherwise,
each recipient email-address in the message's header is added to a guest
list.
(If the originator is <xref target="procs.ownerP">the user</xref>,
the permanent-guest list is used instead of the temporary-guest
list.)</t>
</list></t>

<t>If the originator is the <xref target="procs.ownerP">the user</xref>,
then:
<list>
<t>If <xref target="options.auditOutFile">auditOutFile</xref> is set,
<xref target="procs.saveMessage">saved</xref> there.</t>

<t>Regardless, processing terminates.</t>
</list></t>

<t>If <xref target="options.pdaMailboxes">pdaMailboxes</xref> is set,
and if any plaintext is contained in the message,
then the plaintext is sent to those email-addresses.</t>

<t>If <xref target="options.remoteMailboxes">remoteMailboxes</xref> is set,
and if the message is successful resent to those email-addresses,
then processing terminates.</t>

<t>A copy of the message is
<xref target="procs.saveMessage">saved</xref> in the
<xref target="options.defaultMaildrop">defaultMaildrop</xref> and
processing terminates.</t>
</list></t>
</section>

<section anchor="configFile" title="The Configuration File">
<t>There are two kinds of information that may be defined in configFile:
<xref target="options">configuration options</xref> and
<xref target="procs">configurable procedures</xref>.</t>

<figure>
<preamble>Here's a simple example of a configFile for a user named
"example":</preamble>
<artwork><![CDATA[
    set options(dataDirectory)   .personal
    set options(defaultMaildrop) /var/mail/example
    set options(logFile)         [file join .personal personal.log]
    set options(noticeFile)      [file join .personal notice.txt]
]]></artwork>
</figure>

<section anchor="options" title="Configuration Options">
<t>configFile must define 
<xref target="options.dataDirectory">dataDirectory</xref>
and
<xref target="options.defaultMaildrop">defaultMaildrop</xref>.
All other configuration options are optional.</t>

<section anchor="options.dataDirectory" title="dataDirectory">
<t>The directory where the mailbot keeps its databases.
The subdirectories are:
<list style="hanging">
<t hangText="   badaddrs:">the directory of rejected email-addresses</t>

<t hangText="   inaddrs:">the directory of originator email-addresses</t>

<t hangText="   msgids:">the directory of Message-IDs</t>

<t hangText="   outaddrs:">the permanent-guest list</t>

<t hangText="   phrases:">the directory of at-most-once passphrases</t>

<t hangText="   tmpaddrs:">the temporary-guest list</t>
</list>
If you want to remove someone from a guest list,
simply go to that directory and delete the corresponding file.</t>
</section>

<section anchor="options.defaultMaildrop" title="defaultMaildrop">
<t>The filename where messages are 
<xref target="procs.saveMessage">saved</xref> for later viewing by
your user agent.</t>
</section>

<section anchor="options.auditInFile" title="auditInFile">
<t>The filename where messages are
<xref target="procs.saveMessage">saved</xref> for audit purposes.</t>
</section>

<section anchor="options.auditOutFile" title="auditOutFile">
<t>The filename where your outgoing messages are
<xref target="procs.saveMessage">saved</xref> for audit purposes.</t>
</section>

<section anchor="options.dropNames" title="dropNames">
<t>A list of filename extensions for attachments that automatically
cause the message to be rejected.</t>
</section>

<section anchor="options.friendlyDomains" title="friendlyDomains">
<t>A list used by <xref target="procs.friendP">friendP</xref> giving
the domain names where your friends live.</t>
</section>

<section anchor="options.friendlyfire" title="friendlyfire">
<t>If present and true,
then someone sending a message both to you and someone you've
previously sent mail to,
is considered a friend.</t>
</section>

<section anchor="options.logFile" title="logFile">
<t>The filename where the mailbot
<xref target="procs.tclLog">logs</xref> its actions.</t>
</section>

<section anchor="options.myMailbox" title="myMailbox">
<figure>
<preamble>Your preferred email-address with commentary text, e.g.,</preamble>
<artwork><![CDATA[
    Arlington Hewes <[email protected]>
]]></artwork>
</figure>
</section>

<section anchor="options.noticeFile" title="noticeFile">
<t>The filename containing the textual notice sent when a message is
rejected.
Note that all occurrances of "%passPhrase%" within this file are
replaced with an at-most-once passphrase allowing the originator to
bypass the mailbot's filtering.
Similarly,
any occurrences of "%subject%" are replaced by the "Subject" of the
incoming message.</t>
</section>

<section anchor="options.pdaMailboxes" title="pdaMailboxes">
<t>The email-addresses where a textual synopsis of the incoming message is
sent.</t> 
</section>

<section anchor="options.remoteMailboxes" title="remoteMailboxes">
<t>The email-addresses where a copy of the incoming message is resent.</t> 
</section>
</section>

<vspace blankLines="10000" />

<section anchor="procs" title="Configurable Procedures">
<t>All of these procedures are defined in personal.tcl.
You may override any of them in configFile.</t>

<section anchor="procs.adminP" title="adminP">
<figure>
<artwork><![CDATA[
    proc adminP {local domain}
]]></artwork>
</figure>

<t>Returns "1" if the email-address is an automated administrative
process.</t>
</section>

<section anchor="procs.friendP" title="friendP">
<figure>
<artwork><![CDATA[
    proc friendP {local domain}
]]></artwork>
</figure>

<t>Returns "1" if the email-address is from a
<xref target="options.friendlyDomains">friendly domain</xref> or
sub-domain.</t>
</section>

<section anchor="procs.ownerP" title="ownerP">
<figure>
<artwork><![CDATA[
    proc ownerP {local domain}
]]></artwork>
</figure>

<t>Returns "1" if the email-address refers to the user
(as determined by looking at
<xref target="options.myMailbox">myMailbox</xref>,
<xref target="options.pdaMailboxes">pdaMailboxes</xref>, and
<xref target="options.remoteMailboxes">remoteMailboxes</xref>.</t>
</section>

<section anchor="procs.saveMessage" title="saveMessage">
<figure>
<artwork><![CDATA[
    proc saveMessage {inF {outF ""}}
]]></artwork>
</figure>

<t>Saves a copy of the message contained in the file inF.
If the destination file,
outF,
isn't specified,
it defaults to the
<xref target="options.defaultMaildrop">defaultMaildrop</xref>.</t> 
</section>

<section anchor="procs.findPhrase" title="findPhrase">
<figure>
<artwork><![CDATA[
    proc findPhrase {subject}
]]></artwork>
</figure>

<t>Returns "1" if a previously-allocated passphrase is present in the
subject.
If so,
the passphrase is forgotten.</t>
</section>

<section anchor="procs.makePhrase" title="makePhrase">
<figure>
<artwork><![CDATA[
    proc makePhrase {}
]]></artwork>
</figure>

<t>Returns an at-most-once passphrase for use with a rejection notice.</t>
</section>

<section anchor="procs.pruneDir" title="pruneDir">
<figure>
<artwork><![CDATA[
    proc pruneDir {dir type}
]]></artwork>
</figure>

<t>Removes old entries from one of the mailbot's 
<xref target="options.dataDirectory">databases</xref>.
The second parameter is one of "addr", "msgid", or "phrase".</t>
</section>

<section anchor="procs.tclLog" title="tclLog">
<figure>
<artwork><![CDATA[
    proc tclLog {message}
]]></artwork>
</figure>

<t>Writes a message to the <xref target="options.logFile">logFile</xref>.</t>
</section>
</section>
</section>

</section>

</middle>

<back>
<references />

<section anchor="impersonal" title="Impersonal Mail">
<t>If <xref target="procs.impersonalMail">impersonalMail</xref>
returns a non-empty string
then the message is processed differently than the algorithm given in
<xref target="actions" />.
Specifically:
<list style="numbers">
<t>If the message contains a previously-encountered "Message-ID",
processing terminates.</t>

<t>If the message's originator can not be determined,
processing terminates.</t>

<t>The value returned by
<xref target="procs.impersonalMail">impersonalMail</xref>
is the folder's name and is broken into one or more components
seperated by dots (".").
If there aren't at least two components,
or if any of the components are empty
(e.g., the folder is named "sys..announce"),
then the message is bounced.</t>

<t>If <xref target="options.mappingFile">mappingFile</xref> exists,
that file is examined to see if an entry is present for the folder.
If so,
the message is processed according to the value present,
one of:
<list style="hanging">
<t hangText='     "ignore":'>the message is silently ignored;</t>

<t hangText='     "bounce":'>the message is noisily bounced; or,</t>

<t hangText="    otherwise:">the message is resent to the address.</t>
</list>
Regardless,
if an entry was present for the folder,
then processing terminates.</t>

<t>The message is <xref target="procs.saveMessage">saved</xref> 
in a file whose name is constructed by replacing each dot (".") in the
folder name with a directory seperator
(e.g., if the folder is named "sys.announce",
then the file is called "announce" underneath the directory "sys"
underneath the directory identified by
<xref target="options.foldersDirectory">foldersDirectory</xref>.</t>

<t>Finally,
the file identified by <xref target="options.foldersFile">foldersFile</xref>
is updated as necessary.</t>
</list></t>

<vspace blankLines="10000" />

<section anchor="impersonal.options" title="Configuration Options">
<t>If "impersonal" mail is received,
then <xref target="options.foldersFile">foldersFile</xref> and
<xref target="options.foldersDirectory">foldersDirectory</xref> 
must exist.</t>

<section anchor="options.foldersDirectory" title="foldersDirectory">
<t>The directory where the mailbot keeps private folders.</t>
</section>

<section anchor="options.foldersFile" title="foldersFile">
<t>This file contains one line for each private folder.</t>
</section>

<section anchor="options.announceMailboxes" title="announceMailboxes">
<t>The email-addresses where an announcement is sent when a new
private folder is created.</t>
</section>

<section anchor="options.mappingFile" title="mappingFile">
<t>The file consulted by the mailbot to determine how to process
"impersonal" messages.
Each line of the file consists of a folder name and value,
seperated by a colon (":").
There are three reserved values: "bounce", "ignore", and "store".</t>
</section>
</section>

<vspace blankLines="10000" />

<section anchor="impersonal.procs" title="Configurable Procedures">
<t>All of these procedures are defined in personal.tcl.
You may override any of them in configFile.</t>

<section anchor="procs.impersonalMail" title="impersonalMail">
<figure>
<artwork><![CDATA[
    proc impersonalMail {}
]]></artwork>
</figure>

<t>If the message is deemed "impersonal",
return the name of a corresponding private folder;
otherwise,
return the empty-string.</t>

<t>Many mail systems have a mechanism of passing additional
information when performing final delivery using a program.
With modern versions of sendmail,
for example,
if mail is sent to a local user named "user+detail",
then,
in the absense of an alias for either "user+detail" or "user+*",
then the message is delivered to "user".
The trick is to get sendmail to pass the "detail" part to the mailbot.</t>

<figure>
<preamble>At present,
sendmail passes this information only if procmail is your local
mailer.
Here's how I do it:</preamble>
<artwork><![CDATA[
    *** _alias.c    Tue Dec 29 10:42:25 1998
    --- alias.c     Sat Sep 18 21:51:35 1999
    ***************
    *** 813,818 ****
    --- 813,821 ----
            define('z', user->q_home, e);
            define('u', user->q_user, e);
            define('h', user->q_host, e);
    + 
    +       setuserenv("SUFFIX", user->q_host);
    + 
            if (ForwardPath == NULL)
                    ForwardPath = newstr("\201z/.forward");
]]></artwork>
<postamble>This makes available an environment variable called
"SUFFIX" which has the "details" part.
The drawback in this approach is that this information is lost if the
message is re-queued for delivery
(what's really needed is an addition to the .forward syntax to allow
macros such as $h to be passed).</postamble>
</figure>

<figure>
<preamble>The corresponding impersonalMail procedure is defined as:</preamble>
<artwork><![CDATA[
    proc impersonalMail {} {
        global env

        return $env(SUFFIX)
    }
]]></artwork>
</figure>
</section>

<section anchor="procs.processFolder" title="processFolder">
<figure>
<artwork><![CDATA[
    proc processFolder {folderName mimeT} { return $string }
]]></artwork>
</figure>

<t>If an entry for the folder exists in the
<xref target="options.mappingFile">mappingFile</xref>,
and if the value for that entry is "process",
then this procedure is invoked to return a string indicating what
action to take
(cf., <xref target="impersonal" />).</t>
</section>
</section>
</section>

<section title="An Example configFile">
<figure>
<preamble>Here is the ".forward" file for the user "hewes":</preamble>
<artwork><![CDATA[
    "|/usr/pkg/lib/mbot-1.1/personal.tcl 
         -config .personal/config.tcl -user hewes"
]]></artwork>
<postamble>(Of course, it's all on one line.)</postamble>
</figure>

<figure>
<preamble>Here is the user's ".personal/config.tcl" file:</preamble>
<artwork><![CDATA[
    array set options [list                                          \
        dataDirectory     .personal                                  \
        defaultMaildrop   /var/mail/hewes                            \
        auditInFile       [file join .personal INCOMING]             \
        auditOutFile      [file join .personal OUTGOING]             \
        friendlyDomains   [list tcp.int example.com]                 \
        logFile           [file join .personal personal.log]         \
        myMailbox         "Arlington Hewes <[email protected]>"      \
        pdaMailboxes      [email protected]                    \
        noticeFile        [file join .personal notice.txt]           \
        foldersDirectory  [file join .personal folders]              \
        foldersFile       [file join .personal .mailboxlist]         \
        announceMailboxes [email protected]             \
        mappingFile       [file join .personal mapping]              \
        friendlyFire      1                                          \
        dropNames         [list *.bat *.exe *.src *.pif *.wav *.vbs] \
    ]

    proc impersonalMail {} {
        global env

        return $env(SUFFIX)
    }
]]></artwork>
<postamble>Note that because
<xref target="options.remoteMailboxes">remoteMailboxes</xref> isn't
defined,
personal messages are ultimately stored in the user's
<xref target="options.defaultMaildrop">defaultMaildrop</xref>.</postamble>
</figure>
</section>

<section title="Acknowledgements">
<t>The original version of this mailbot was written by the author in 1994,
implemented using  the safe-tcl package
(Borenstein and Rose, circa 1993).</t>
</section>

</back>

</rfc>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/mime/mbot/impersonal.tcl.

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

# impersonal.tcl - export impersonal mail via the web
#
# (c) 1999 Marshall T. Rose
# Hold harmless the author, and any lawful use is allowed.
#


global options


# begin of routines that may be redefined in configFile

proc tclLog {message} {
    global options

    if {([info exists options(debugP)]) && ($options(debugP) > 0)} {
        puts stderr $message
    }

    if {([string first "DEBUG " $message] == 0) \
            || ([catch { set fd [open $options(logFile) \
                                      { WRONLY CREAT APPEND }] }])} {
        return
    }

    regsub -all "\n" $message " " message

    catch { puts -nonewline $fd \
                 [format "%s %-8.8s %06d %s\n" \
                         [clock format [clock seconds] -format "%m/%d %T"] \
                         personal [expr [pid]%65535] $message] }

    catch { close $fd }
}

# end of routines that may be redefined in configFile


proc firstext {mime} {
    array set props [mime::getproperty $mime]

    if {[info exists props(parts)]} {
        foreach part $props(parts) {
            if {[string compare [firstext $part] ""]} {
                return $part
            }
        }
    } else {
        switch -- $props(content) {
            text/plain
                -
            text/html {
                return $mime
            }
        }
    }
}

proc sanitize {text} {
    regsub -all "&" $text {\&amp;} text
    regsub -all "<" $text {\&lt;}  text

    return $text
}

proc cleanup {{message ""} {code 500}} {
    global errorCode errorInfo

    set ecode $errorCode
    set einfo $errorInfo

    if {[string compare $message ""]} {
        tclLog $message

        catch {
            puts stdout "HTTP/1.0 $code Server Error
Content-Type: text/html
Status: 500 Server Error

<html><head><title>Service Problem</title></head>
<body><h1>Service Problem</h1>
<b>Reason:</b> [sanitize $message]"

            if {$code == 505} {
                puts stdout "<br>
<b>Stack:</b>
<pre>[sanitize $einfo]</pre>
<hr></hr>"
            }

            puts stdout "</body></html>"
        }
    }

    flush stdout

    exit 0
}



if {[catch {

    set program impersonal

    package require mbox 1.0
    package require mutl 1.0
    package require smtp 1.1
    package require Tclx 8.0


# move stdin, close stdin/stderr

    dup [set null [open /dev/null { RDWR }]] stderr
    set stdin [dup stdin]
    dup $null stdin
    close $null

    fconfigure $stdin -translation crlf
    fconfigure stdout -translation crlf


# parse arguments and initialize environment

    set program [file tail [file rootname $argv0]]

    set configFile .${program}-config.tcl

    set debugP 0

    set userName ""

    for {set argx 0} {$argx < $argc} {incr argx} {
        set option [lindex $argv $argx]
        if {[incr argx] >= $argc} {
            cleanup "missing argument to $option"
        }
        set value [lindex $argv $argx]

        switch -- $option {
            -config {
                set configFile $value
            }

            -debug {
                set options(debugP) [set debugP [smtp::boolean $value]]
            }

            -user {
                set userName $value
            }

            default {
                cleanup "unknown option $option"
            }
        }
    }

    if {[string compare $userName ""]} {
        if {[catch { id convert user $userName }]} {
            cleanup "userName doesn't exist: $userName"
        }
        if {([catch { file isdirectory ~$userName } result]) \
                || (!$result)} {
            cleanup "userName doesn't have a home directory: $userName"
        }

        umask 0077
        cd ~$userName
    }

    if {![file exists $configFile]} {
        cleanup "configFile file doesn't exist: $configFile"
    }
    source $configFile

    set options(debugP) $debugP

    foreach {k v} [array get options] {
        if {![string compare $v ""]} {
            unset options($k)
        }
    }

    foreach k [list dataDirectory foldersFile foldersDirectory] {
        if {![info exists options($k)]} {
            cleanup "configFile didn't define $k: $configFile"
        }
    }

    if {![file isdirectory $options(dataDirectory)]} {
        file mkdir $options(dataDirectory)
    }


# crack the request

    set request ""
    set eol ""
    while {1} {
        if {[catch { gets $stdin line } result]} {
            cleanup "lost connection"
        }
        if {$result < 0} {
            break
        }

        set gotP 0
        foreach c [split $line ""] {
            if {($c == " ") || ($c == "\t") || [ctype print $c]} {
                if {!$gotP} {
                    append request $eol
                    set gotP 1
                }
                append request $c
            }
        }
        if {!$gotP} {
            break
        }

        set eol "\n"
    }
    set request [string tolower $request]

    set getP 0
    foreach param [split $request "\n"] {
        if {[string first "get " $param] == 0} {
            set getP 1
            if {[catch { lindex [split $param " "] 1 } page]} {
                cleanup "server supports only HTTP/1.0" 501
            }
        }
    }
    if {!$getP} {
        cleanup "server supports only GET" 405
    }

    if {[string first /news? $page] != 0} {
        cleanup "page $page unavailable" 504
    }
    foreach param [split [string range $page 6 end] &] {
        if {[set x [string first = $param]] <= 0} {
            cleanup "page $request unavailable" 504
        }
        set key [string range $param 0 [expr $x-1]]
        set arg($key) [string range $param [expr $x+1] end]
    }

    set expires [mime::parsedatetime -now proper]


# /news?index=newsgroups OR /news?index=recent

    if {![catch { set arg(index) } index]} {
        switch -- $index {
            newsgroups {
                set lastN 0
            }

            recent {
                set lastN -1
            }

            default {
                cleanup "page $request unavailable" 504
            }
        }
        catch { set lastN $arg(lastn) }

        if {[catch { open $options(foldersFile) { RDONLY } } fd]} {
            cleanup $fd 505
        }

        set folders ""
        set suffix [lindex [set prefix [file split \
                                             $options(foldersDirectory)]] \
                           end]
        set prefix [eval [list file join] [lreplace $prefix end end]]

        for {set lineNo 1} {[gets $fd line] >= 0} {incr lineNo} {
            if {[string first $suffix $line] != 0} {
                continue
            }
            set file [file join $prefix $line]

            if {[catch { file stat $file stat } result]} {
                tclLog $result

                continue
            }
            if {![string compare $stat(type) file]} {
                lappend folders [list [eval [list file join] \
                                            [lrange [file split $line] \
                                                    1 end]] \
                                      $stat(mtime)]
            }
        }

        catch {close $fd }

        switch -- $index {
            recent {
                set folders [lsort -integer    -decreasing -index 1 $folders]
            }

            default {
                set folders [lsort -dictionary -increasing -index 0 $folders]
            }
        }

        puts stdout "HTTP/1.0 200
Content-Type: text/html
Pragma: no-cache
Expires: $expires

<html><head><title>newsgroups</title></head><body>
<table cellborder=0 cellpadding=0 cellspacing=0>"

        foreach entry $folders {
            set folder [lindex $entry 0]
            set t [fmtclock [set mtime [lindex $entry 1]] "%m/%d %H:%M"]

            puts stdout "<tr><td><a href=\"news?folder=$folder&lastN=$lastN&mtime=$mtime\">$t</a></td><td width=5></td><td><b>$folder</b></td></tr>"
        }

        puts stdout "</table>
</body></html>"

        cleanup
    }


# /news?folder="whatever"

    if {[catch { set arg(folder) } folder]} {
        cleanup "page $request unavailable" 504
    }

    foreach p [file split $folder] {
        if {(![string compare $p ""]) || ([string first . $p] >= 0)} {
            cleanup "page $request unavailable" 504
        }
    }

    set file [file join $options(foldersDirectory) $folder]
    if {([catch { file type $file } type]) \
            || ([string compare $type file])} {
        cleanup "page $request unavailable" 504
    }
    if {[catch { mbox::initialize -file $file } mbox]} {
        cleanup $mbox 505
    }


# /news?folder="whatever"&lastN="N"

    if {![catch { set arg(lastn) } lastN]} {
        array set props [mbox::getproperty $mbox]

        if {$lastN < 0} {
            set diff [expr -($lastN*86400)]

            set last 0
            for {set msgNo $props(last)} {$msgNo > 0} {incr msgNo -1} {
                if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
                    tclLog $mime

                    continue
                }
                
                if {[catch { lindex [mime::getheader $mime Date] 0 } value]} {
                    set value ""
                }
                if {![catch { mime::parsedatetime $value rclock } rclock]} {
                    if {$rclock < $diff} {
                        if {$last == 0} {
                            set last $msgNo
                        }
                        set first $msgNo
                    }
                    if {$last == 0} {
                        break
                    }
                }
            }
            if {$last > 0} {
                set last $props(last)
            }
        } elseif {[set first \
                       [expr [set last $props(last)]-($lastN+1)]] <= 0} {
            set first 1
        }

        puts stdout "HTTP/1.0 200
Content-Type: text/html
Pragma: no-cache
Expires: $expires

<html><head><title>$folder</title></head><body>"

        if {$last == 0} {
            puts stdout "<b>Empty.</b>
</body></html>"

            cleanup
        }

        puts stdout "<table cellborder=0 cellpadding=0 cellspacing=0>"
        for {set msgNo $last} {$msgNo >= $first} {incr msgNo -1} {
            if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
                tclLog $mime

                continue
            }

            set date ""
            catch {
                set value [lindex [mime::getheader $mime Date] 0]
                append date [format %02d \
                                    [mime::parsedatetime $value mon]]   /  \
                       [format %02d [mime::parsedatetime $value mday]] " " \
                       [format %02d [mime::parsedatetime $value hour]]  :  \
                       [format %02d [mime::parsedatetime $value min]]
            }
            if {![string compare $date ""]} {
                set date "unknown date"
            }

            set from ""
            catch {
                set from [mutl::firstaddress [mime::getheader $mime From]]

                catch { unset aprops }

                array set aprops [lindex [mime::parseaddress $from] 0]
                set from "<a href='mailto:$aprops(local)@$aprops(domain)'>$aprops(friendly)</a>"
            }

            set subject ""
            catch {
                set subject [lindex [mime::getheader $mime Subject] 0]
            }

            puts stdout "<tr><td><a href=\"news?folder=$folder&msgNo=$msgNo\">$date</a></td><td width=5></td><td><b>$from</b></td><td width=5></td><td>$subject</td></tr>"
        }
        puts stdout "</table>
</body></html>"

        cleanup
    }


# /news?folder="whatever"&msgNo="N"

    if {![catch { set arg(msgno) } msgNo]} {
        if {[catch { mbox::getmsgtoken $mbox $msgNo } mime]} {
            cleanup $mime 505
        }

        if {![string compare [set part [firstext $mime]] ""]} {
            set part $mime
        }
        switch -- [set content [mime::getproperty $part content]] {
            text/plain {
                regsub -all "\n\n" [mime::getbody $part] "<p>" body

                set result "<html><head><title>$folder $msgNo</title></head>
<body>$body</body></html>"

            }

            text/html {
                set result [mime::getbody $part]
            }

            default {
                set result "<html><head><title>$folder $msgNo</title></head>
<body>
Message is $content.
</body></html>"
            }
        }

        puts stdout "HTTP/1.0 200
Content-Type: text/html

$result"

        cleanup
    }


    cleanup "page $request unavailable" 504


} result]} {
    global errorCode errorInfo

    set ecode $errorCode
    set einfo $errorInfo

    if {(![catch { info body tclLog } result2]) \
            && ([string compare [string trim $result2] \
                        {catch {puts stderr $string}}])} {
        catch { tclLog $result }
    }

    if {![string first "POSIX EPIPE" $ecode]} {
        exit 0
    }

    catch {
        smtp::sendmessage \
            [mime::initialize \
                 -canonical text/plain \
                 -param  {charset us-ascii} \
                 -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \
            -originator "" \
            -header [list From    [id user]@[info hostname]]       \
            -header [list To      operator@[info hostname]]        \
            -header [list Subject "[info hostname] fatal $program"]
    }

    cleanup $result
}


exit 75
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/mime/mbot/mbox.tcl.

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

#
# TODO:
#
#     mbox::initialize
#         add -pop server option
#         add -imap server option
#         along with -username, -password, and -passback
#
#     mbox::getmsgproperty
#         add support for deleted messages
#
#     mbox::deletemsg token msgNo
#         marks a message for deletion
#
#     mbox::synchronize token ?-commit boolean?
#         commits or rollllbacks changes


package provide mbox 1.0

package require mime 1.1


#
# state variables:
#
#     msgs: serialized array of messages, containing array of:
#           msgNo, mime
#     count: number of messages
#     first: number of initial message
#     last: number of final message
#     value: either "file", or "directory"
#
#     file: file containing mailbox
#     fd: corresponding file descriptor
#     fileA: serialized array of messages, containing array of:
#            msgNo, offset, size
#
#     directory: directory containing mailbox
#     dirA: serialized array of messages, containing array of:
#           msgNo, size
#     

namespace eval mbox {
    variable mbox
    array set mbox { uid 0 }

    namespace export initialize finalize getproperty \
                     getmsgtoken getmsgproperty
}


proc mbox::initialize {args} {
    global errorCode errorInfo

    variable mbox

    set token [namespace current]::[incr mbox(uid)]

    variable $token
    upvar 0 $token state

    if {[set code [catch { eval [list mbox::initializeaux $token] $args } \
                         result]]} {
        set ecode $errorCode
        set einfo $errorInfo

        catch { mbox::finalize $token -subordinates dynamic }

        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    return $token
}


proc mbox::initializeaux {token args} {
    variable $token
    upvar 0 $token state

    set state(msgs) ""
    set state(count) 0
    set state(first) 0
    set state(last) 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 {
            -directory {
                set state(directory) $value
            }

            -file {
                set state(file) $value
            }

            default {
                error "unknown option $option"
            }
        }
    }

    set valueN 0
    foreach value [list directory file] {
        if {[info exists state($value)]} {
            set state(value) $value
            incr valueN
        }
    }
    if {$valueN != 1} {
        error "specify exactly one of -directory, or -file"
    }

    return [mbox::initialize_$state(value) $token]
}


proc mbox::initialize_file {token} {
    variable $token
    upvar 0 $token state

    fconfigure [set state(fd) [open $state(file) { RDONLY }]] \
               -translation binary
    
    array set fileA ""
    set msgNo 0

    if {[gets $state(fd) line] < 0} {
        return $token
    }
    switch -regexp -- $line {
        "^From " {
            set format Mailx
            set preB "From "

            set phase ""
        }

        "\01\01\01\01" {
            set format MMDF
            set preB "\01\01\01\01"
            set postB "\01\01\01\01"

            if {([gets $state(fd) line] >= 0) \
                    && ([string first "From MAILER-DAEMON " $line] == 0)} {
                set phase skip
            } else {
                set phase pre
            }
        }

        default {
            error "unrecognized mailbox format"
        }
    }
    seek $state(fd) 0 start

    while {[gets $state(fd) line] >= 0} {
        switch -- $format/$phase {
            Mailx/ {
                if {[string first $preB $line] == 0} {
                    if {$msgNo > 0} {
                        set fileA($msgNo) [list msgNo $msgNo offset $offset \
                                                size $size]
                    }

                    incr msgNo
                    set offset [tell $state(fd)]
                    set size 0
                } else {
                    incr size [expr [string length $line]+1]
                }
            }

            MMDF/pre {
                if {![string compare $preB $line]} {
                    incr msgNo
                    set offset [tell $state(fd)]
                    set size 0

                    set phase post
                } else {
                    error "invalid mailbox"
                }
            }

            MMDF/post {
                if {![string compare $postB $line]} {
                    set fileA($msgNo) [list msgNo $msgNo offset $offset \
                                            size $size]

                    set phase pre
                } else {
                    incr size [expr [string length $line]+1]
                }
            }

            MMDF/skip {
                if {![string compare $preB $line]} {
                    set phase skip2
                }
            }

            MMDF/skip2 {
                if {![string compare $postB $line]} {
                    set phase pre
                }
            }
        }
    }

    switch -- $format/$phase {
        Mailx/ {
            if {$msgNo > 0} {
                set fileA($msgNo) [list msgNo $msgNo offset $offset \
                                        size $size]
            }
        }

        MMDF/post
            -
        MMDF/skip2 {
            error "incomplete mailbox"
        }
    }

    set state(fileA) [array get fileA]
    if {[set state(last) [set state(count) $msgNo]] > 0} {
        set state(first) 1
    }

    return $token
}


proc mbox::initialize_directory {token} {
    variable $token
    upvar 0 $token state

    array set dirA ""

    set first 0
    set last 0
    foreach file [glob -nocomplain [file join $state(directory) *]] {
        if {(![regexp {^[1-9][0-9]*$} [set msgNo [file tail $file]]]) \
                || ([catch { file size $file } size])} {
            continue
        }

        if {($first == 0) || ($msgNo < $first)} {
            set first $msgNo
        }
        if {$last < $msgNo} {
            set last $msgNo
        }

        set dirA($msgNo) [list msgNo $msgNo size $size]
        incr state(count)
    }

    set state(dirA) [array get dirA]
    if {[set state(last) $last] > 0} {
        set state(first) $first
    }

    return $token
}

proc mbox::finalize {token args} {
    variable $token
    upvar 0 $token state

    array set options [list -subordinates dynamic]
    array set options $args

    switch -- $options(-subordinates) {
        all
            -
        dynamic {
            array set msgs $state(msgs)

            for {set msgNo $state(first)} \
                    {$msgNo <= $state(last)} \
                    {incr msgNo} {
                if {![catch { array set msg $msgs($msgNo) }]} {
                    eval [list mime::finalize $msg(mime)] $args
                }
            }
        }

        none {
        }

        default {
            error "unknown value for -subordinates $options(-subordinates)"
        }
    }

    if {[info exists state(fd)]} {
        catch { close $state(fd) }
    }

    foreach name [array names state] {
        unset state($name)
    }
    unset $token
}


proc mbox::getproperty {token {property ""}} {
    variable $token
    upvar 0 $token state

    switch -- $property {
        "" {
            return [list count    $state(count) \
                         first    $state(first) \
                         last     $state(last)  \
                         messages [mbox::getmessages $token]]
        }

        -names {
            return [list count first last messages]
        }

        count
            -
        first
            -
        last  {
            return $state($property)
        }

        messages {
            return [mbox::getmessages $token]
        }

        default {
            error "unknown property $property"
        }
    }
}


proc mbox::getmessages {token} {
    variable $token
    upvar 0 $token state

    switch -- $state(value) {
        directory {
            array set msgs $state(dirA)
        }

        file {
            array set msgs $state(fileA)
        }
    }

    return [lsort -integer [array names msgs]]
}


proc mbox::getmsgtoken {token msgNo} {
    variable $token
    upvar 0 $token state

    if {($msgNo < $state(first)) || ($msgNo > $state(last))} {
        error "message number out of range: $state(first)..$state(last)"
    }

    array set msgs $state(msgs)
    if {![catch { array set msg $msgs($msgNo) }]} {
        return $msg(mime)
    }

    switch -- $state(value) {
        directory {
            set mime [mime::initialize \
                          -file [file join $state(directory) $msgNo]]
        }

        file {
            array set fileA $state(fileA)
            array set msg $fileA($msgNo)
            set mime [mime::initialize -file $state(file) -root $token \
                          -offset $msg(offset) -count $msg(size)]
        }
    }

    set msgs($msgNo) [list msgNo $msgNo mime $mime]
    set state(msgs) [array get msgs]

    return $mime
}


proc mbox::getmsgproperty {token msgNo {property ""}} {
    variable $token
    upvar 0 $token state

    if {($msgNo < $state(first)) || ($msgNo > $state(last))} {
        error "message number out of range: $state(first)..$state(last)"
    }

    switch -- $state(value) {
        directory {
            array set dirA $state(dirA)
            if {[catch { array set msg $dirA($msgNo) }]} {
                error "message $msgNo doesn't exist"
            }
        }

        file {
            array set fileA $state(fileA)
            array set msg $fileA($msgNo)
        }
    }

    set props [list flags size uidl]

    switch -- $property {
        "" {
            array set properties ""

            foreach prop $props {
                if {[info exists msg($prop)]} {
                    set properties($prop) $msg($prop)
                }
            }

            return [array get properties]
        }

        -names  {
            set names ""
            foreach prop $props {
                if {[info exists msg($prop)]} {
                    lappend names $prop
                }
            }

            return $names
        }

        default {
            if {[lsearch -exact $props $property] < 0} {
                error "unknown property $property"
            }

            return $msg($property)
        }
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/mime/mbot/mutl.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
# mutl.tcl - messaging utilities
#
# (c) 1999 Marshall T. Rose
# Hold harmless the author, and any lawful use is allowed.
#


package provide mutl 1.0


namespace eval mutl {
    namespace export exclfile tmpfile \
                     firstaddress gathertext getheader
}


proc mutl::exclfile {fileN {stayP 0}} {
    global errorCode errorInfo

    for {set i 0} {$i < 10} {incr i} {
        if {![catch { set xd [open $fileN { RDWR CREAT EXCL }] } result]} {
            if {(![set code [catch { puts $xd [expr [pid]%65535]
                                     flush $xd } result]]) \
                    && (!$stayP)} {
                if {![set code [catch { close $xd } result]]} {
                    set xd ""
                }
            }

            if {$code} {
                set ecode $errorCode
                set einfo $errorInfo

                catch { close $xd }

                file delete -- $fileN

                return -code $code -errorinfo $einfo -errorcode $ecode $result
            }

            return $xd
        }
        set ecode $errorCode
        set einfo $errorInfo

        if {(([llength $ecode] != 3) \
                || ([string compare [lindex $ecode 0] POSIX]) \
                || ([string compare [lindex $ecode 1] EEXIST]))} {
            return -code 1 -errorinfo $einfo -errorcode $ecode $result
        }

        after 1000
    }

    error "unable to exclusively open $fileN"
}

proc mutl::tmpfile {prefix {tmpD ""}} {
    global env
    global errorCode errorInfo

    if {(![string compare $tmpD ""]) && ([catch { set tmpD $env(TMP) }])} {
        set tmpD /tmp
    }
    set file [file join $tmpD $prefix]

    append file [expr [pid]%65535]

    for {set i 0} {$i < 10} {incr i} {
        if {![set code [catch { set fd [open $file$i \
                                             { WRONLY CREAT EXCL }] } \
                              result]]} {
            return [list file $file$i fd $fd]
        }
        set ecode $errorCode
        set einfo $errorInfo

        if {(([llength $ecode] != 3) \
                || ([string compare [lindex $ecode 0] POSIX]) \
                || ([string compare [lindex $ecode 1] EEXIST]))} {
            return -code $code -errorinfo $einfo -errorcode $ecode $result
        }
    }

    error "unable to create temporary file"
}

proc mutl::firstaddress {values} {
    foreach value $values {
        foreach addr [mime::parseaddress $value] {
            catch { unset aprops }
            array set aprops $addr

            if {[string compare $aprops(proper) ""]} {
                return $aprops(proper)
            }
        }
    }
}

proc mutl::gathertext {token} {
    array set props [mime::getproperty $token]

    set text ""

    if {[info exists props(parts)]} {
        foreach part $props(parts) {
            append text [mutl::gathertext $part]
        }
    } elseif {![string compare $props(content) text/plain]} {
        set text [mime::getbody $token]
    }

    return $text
}

proc mutl::getheader {token key} {
    if {[catch { mime::getheader $token $key } result]} {
        set result ""
    }

    return $result    
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































Deleted examples/mime/mbot/personal.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
#!/bin/sh
# the next line restarts using tclsh \
PATH=/usr/pkg/bin:/usr/local/bin:/usr/bin:/bin LD_LIBRARY_PATH=/usr/pkg/lib:/usr/local/lib:/usr/lib export PATH LD_LIBRARY_PATH; exec tclsh8.3 "$0" "$@"


# personal.tcl - process personal mail
#
# (c) 1999 Marshall T. Rose
# Hold harmless the author, and any lawful use is allowed.
#
# The original version was written in 1994!
#


global options


# begin of routines that may be redefined in configFile

proc impersonalMail {originator} {}

proc adminP {local domain} {
    set local [string tolower $local]

    foreach lhs [list administrator       \
                      archive-server      \
                      daemon              \
                      failrepter          \
                      faxmaster           \
                      gateway             \
                      listmaster          \
                      listproc            \
                      lotus_mail_exchange \
                      m400                \
                      *mailer*            \
                      *maiser*            \
                      mmdf                \
                      mrgate              \
                      mx-mailer-daemon    \
                      numbers-info-forw   \
                      postman*            \
                      *postmast*          \
                      pp                  \
                      smtp                \
                      sysadmin            \
                      ucx_smtp            \
                      uucp] {
        if {[string match $lhs $local]} {
            return 1
        }
    }

    return 0
}

proc friendP {local domain} {
    global options

    if {![info exists options(friendlyDomains)]} {
        return 0
    }

    set domain [string tolower $domain]

    foreach rhs $options(friendlyDomains) {
        if {(![string compare $rhs $domain]) \
                || ([string match *.$rhs $domain])} {
            return 1
        }
    }

    return 0
}

proc ownerP {local domain} {
    global options

    foreach mailbox {myMailbox pdaMailboxes remoteMailboxes} {
        if {![info exists options($mailbox)]} {
            continue
        }

        foreach addr [mime::parseaddress $options($mailbox)] {
            catch { unset aprops }

            array set aprops $addr
            if {![string compare [string tolower $local@$domain] \
                         [string tolower $aprops(local)@$aprops(domain)]]} {
                return 1
            }
        }
    }

    return 0
}

# the algorithm below is for systems that use the MMDF/MH convention

proc saveMessage {inF {outF ""}} {
    global errorCode errorInfo
    global options

    set inC [open $inF { RDONLY }]

    if {![string compare $outF ""]} {
        set outF $options(defaultMaildrop)
    }
    mutl::exclfile [set lockF $outF.lock]

    set code [catch { set outC [open $outF { WRONLY CREAT APPEND }] } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {!$code} {
        set code [catch {
            puts $outC [set boundary "\001\001\001\001"]
            puts $outC "Delivery-Date: [mime::parsedatetime -now proper]"

            while {[gets $inC line] >= 0} {
                if {[string compare $boundary $line]} {
                    puts $outC $line
                } else {
                    puts $outC "\002\001\001\001"
                }
            }

            puts $outC $boundary
        } result]
        set ecode $errorCode
        set einfo $errorInfo

        if {[catch { close $outC } result2]} {
            tclLog $result2
        }
    }

    file delete -- $lockF

    if {[catch { close $inC } result2]} {
        tclLog $result2
    }

    return -code $code -errorinfo $einfo -errorcode $ecode $result
}

proc findPhrase {subject} {
    global options

    set subject [string toupper $subject]

    foreach file [glob -nocomplain [file join $options(dataDirectory) \
                                         phrases *]] {
        if {[catch { otp_words -mode encode \
                              [base64 -mode decode -- \
                                      [join [split [file tail $file] _] /]] } \
                    phrase]} {
            tclLog "$file: $phrase"
        } elseif {[string first $phrase $subject] >= 0} {
            if {[catch { file delete -- $file } result]} {
                tclLog $result
            }

            return 1
        }
    }

    return 0
}

proc makePhrase {} {
    global options

    if {![file isdirectory \
               [set phraseD [file join $options(dataDirectory) phrases]]]} {
        file mkdir $phraseD
    } else {
        pruneDir $phraseD phrase
    }

    set key [mime::uniqueID]
    set seqno 8
    while {[incr seqno -1] >= 0} {
        set key [otp_md5 -- $key]
    }

    set phraseF [file join $phraseD \
                      [join [split [string trim \
                                           [base64 -mode encode -- $key]] /] _]]
    if {[catch { close [open $phraseF { WRONLY CREAT TRUNC }] } result]} {
        tclLog $result
    }

    return [otp_words -mode encode -- $key]
}

proc pruneDir {dir type} {
    switch -- $type {
        addr {
            set days 14
        }

        msgid {
            set days 28
        }

        phrase {
            set days 7
        }
    }

    set then [expr [clock seconds]-($days*86400)]

    foreach file [glob -nocomplain [file join $dir *]] {
        if {(![catch { file mtime $file } result]) \
                && ($result < $then) \
                && ([catch { file delete -- $file } result])} {
            tclLog $result
        }
    }
}

proc tclLog {message} {
    global options

    if {([info exists options(debugP)]) && ($options(debugP) > 0)} {
        puts stderr $message
    }

    if {([string first "DEBUG " $message] == 0) \
            || ([catch { set fd [open $options(logFile) \
                                      { WRONLY CREAT APPEND }] }])} {
        return
    }

    regsub -all "\n" $message " " message

    catch { puts -nonewline $fd \
                 [format "%s %-8.8s %06d %s\n" \
                         [clock format [clock seconds] -format "%m/%d %T"] \
                         personal [expr [pid]%65535] $message] }

    catch { close $fd }
}

# end of routines that may be redefined in configFile


global deleteFiles

set deleteFiles {}

proc cleanup {{message ""} {status 75}} {
    global deleteFiles

    foreach file $deleteFiles {
        if {[catch { file delete -- $file } result]} {
            tclLog $result
        }
    }

    if {[string compare $message ""]} {
        tclLog $message
        exit $status
    }

    exit 0
}

proc dofolder {folder inF} {
    global options

    catch { unset aprops }

    array set aprops [lindex [mime::parseaddress $folder] 0]
    set folder [join [split $aprops(local) /] _]

    if {[set folderN [llength [set folderL [split $folder .]]]] <= 1} {
        cleanup "invalid folder: $folder"
    }

    foreach f $folderL {
        if {![string compare $f ""]} {
            cleanup "invalid folder: $folder" 67
        }
    }

    if {![file isdirectory \
               [set articleD [eval [list file join \
                                         $options(foldersDirectory)] \
                                   [lrange $folderL 0 \
                                           [expr $folderN-2]]]]]} {
        file mkdir $articleD
    }
    if {![file exists [set articleF [file join $articleD \
                                          [lindex $folderL \
                                                  [expr $folderN-1]]]]]} {
        set newP 1
    } else {
        set newP 0
    }

    set fd [open $options(foldersFile) { RDWR CREAT }]
    set fl "\n[read $fd]"

    set dir [lindex [file split $options(foldersDirectory)] end]
    if {[string first "\n$dir\n" $fl] < 0} {
        puts $fd $dir
    }
    foreach f $folderL {
        set dir [file join $dir $f]
        if {[string first "\n$dir\n" $fl] < 0} {
            puts $fd $dir
        }
    }

    close $fd

    if {[catch { saveMessage $inF $articleF } result]} {
        cleanup "unable to save message in $articleF: $result"
    }

    if {($newP) && ([info exists options(announceMailboxes)])} {
        if {[catch { smtp::sendmessage \
                         [mime::initialize \
                              -canonical text/plain \
                              -param {charset us-ascii} \
                              -string ""] \
                         -atleastone true \
                         -originator "" \
                         -header [list From    $options(myMailbox)] \
                         -header [list To      $options(announceMailboxes)] \
                         -header [list Subject "new folder $folder"] } \
                   result]} {
            tclLog $result
        }
    }
}

proc alladdrs {mime keys} {
    set result {}

    foreach key $keys {
        foreach value [mutl::getheader $mime $key] {
            foreach addr [mime::parseaddress $value] {
		lappend result $addr
	    }
	}
    }

    return $result
}

proc anyfriend {outD addrs} {
    global options

    if {!$options(friendlyFire)} {
	return ""
    }

    foreach addr $addrs {
        catch { unset aprops }

        array set aprops $addr
	if {[catch { string tolower $aprops(local)@$aprops(domain) } \
		   recipient]} {
	    continue
	}

	if {[ownerP $aprops(local) $aprops(domain)]} {
	    tclLog "DEBUG: skipping $recipient"
	    continue
	}

	set outF [file join $outD [join [split $recipient /] _]]
	if {[file exists $outF]} {
	    return $recipient
	}

	tclLog "DEBUG: unknown recipient $recipient"
    }

    return ""
}


if {[catch {

    set program personal

    package require mutl 1.0
    package require smtp 1.1
    package require Tclx 8.0


# parse arguments and initialize environment

    set program [file tail [file rootname $argv0]]

    set configFile .${program}-config.tcl

    set debugP 0

    set messageFile -

    set originatorAddress ""

    set userName ""

    for {set argx 0} {$argx < $argc} {incr argx} {
        set option [lindex $argv $argx]
        if {[incr argx] >= $argc} {
            cleanup "missing argument to $option"
        }
        set value [lindex $argv $argx]

        switch -- $option {
            -config {
                set configFile $value
            }

            -debug {
                set options(debugP) [set debugP [smtp::boolean $value]]
            }

            -file {
                set messageFile $value
            }

            -originator {
                set originatorAddress $value
            }

            -user {
                set userName $value
            }

            default {
                cleanup "unknown option $option"
            }
        }
    }

    if {![string compare $messageFile -]} {
        array set tmp [mutl::tmpfile personal]

        lappend deleteFiles [set messageFile $tmp(file)]

        catch { file attributes $messageFile -permissions 0600 }

        if {[gets stdin line] <= 0} {
            cleanup "empty message"
        }
        if {[string first "From " $line] == 0} {
            if {![string compare $originatorAddress ""]} {
                set line [string range $line 5 end]
                if {[set x [string first " " $line]] > 0} {
                    set originatorAddress [string range $line 0 [expr $x-1]]
                }
            }
        } else {
            puts $tmp(fd) $line
        }
        fcopy stdin $tmp(fd)
        close $tmp(fd)
    }

    if {[string compare $userName ""]} {
        if {[catch { id convert user $userName }]} {
            cleanup "userName doesn't exist: $userName"
        }
        if {([catch { file isdirectory ~$userName } result]) \
                || (!$result)} {
            cleanup "userName doesn't have a home directory: $userName"
        }

        umask 0077
        cd ~$userName
    }

    if {![file exists $configFile]} {
        cleanup "configFile file doesn't exist: $configFile"
    }
    source $configFile

    set options(debugP) $debugP

    foreach {k v} [array get options] {
        if {![string compare $v ""]} {
            unset options($k)
        }
    }

    foreach k [list dataDirectory defaultMaildrop] {
        if {![info exists options($k)]} {
            cleanup "configFile didn't define $k: $configFile"
        }
    }

    if {![file isdirectory $options(dataDirectory)]} {
        file mkdir $options(dataDirectory)
    }

    if {![info exists options(myMailbox)]} {
        set options(myMailbox) [id user]
    }

    if {![info exists options(friendlyFire)]} {
        set options(friendlyFire) 0
    }


# crack the message

    if {[catch { set mime [mime::initialize -file $messageFile] } result]} {
#        global errorCode errorInfo
#
#        set ecode $errorCode
#        set einfo $errorInfo
#
#        if {![catch {
#            smtp::sendmessage \
#                [mime::initialize \
#                     -canonical multipart/mixed \
#                     -parts [list [mime::initialize \
#                                        -canonical text/plain \
#                                        -param  {charset us-ascii} \
#                                        -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \
#                                  [mime::initialize \
#                                        -canonical application/octet-stream \
#                                        -file $messageFile]]] \
#                -originator "" \
#                -header [list From    $options(myMailbox)] \
#                -header [list To      $options(myMailbox)] \
#                -header [list Subject "[info hostname] alert $program"]
#        }]} {
#            set result ""
#        }

	if {[info exists options(auditInFile)]} {
	    saveMessage $messageFile $options(auditInFile)
	    tclLog "invalid, but saved: $result"
	    cleanup
	}

        cleanup "re-queued: $result"
    }

    set origProper ""
    foreach key {From Sender Return-Path} {
        if {[string compare \
                    [set origProper [mutl::firstaddress \
                                         [mutl::getheader $mime $key]]] \
                    ""]} {
            break
        }
    }
    if {![string compare $origProper ""]} {
        set origProper [mutl::firstaddress [list $originatorAddress]]
    }

    catch { unset aprops }

    array set aprops [list local "" domain ""]
    array set aprops [lindex [mime::parseaddress $origProper] 0]
    set origLocal $aprops(local)
    set origDomain $aprops(domain)

    regsub -all "  *" \
           [set subject [string trim \
                                [lindex [mutl::getheader $mime Subject] 0]]] \
           " " subject


    if {[catch { set folderTarget [impersonalMail $origLocal@$origDomain] }]} {
        set folderTarget ""
    }
    if {[set impersonalP [string compare $folderTarget ""]]} {
        if {![info exists options(foldersDirectory)]} {
            cleanup "configFile didn't define folderTarget: $configFile"
        }
    } elseif {[info exists options(auditInFile)]} {
# keep an audit copy of personal mail

        saveMessage $messageFile $options(auditInFile)
    }


# perform duplicate supression

    set messageID [lindex [concat [mutl::getheader $mime Resent-Message-ID] \
                                  [mutl::getheader $mime Message-ID]] 0]
    if {[string compare $messageID ""]} {
        if {![file isdirectory \
                   [set idD [file join $options(dataDirectory) msgids]]]} {
            file mkdir $idD
        } else {
            pruneDir $idD msgid
        }

        if {[set len [string length $messageID]] > 2} {
            set messageID [string range $messageID 1 [expr $len-2]]
        }
        if {$impersonalP} {
            set prefix X-

            catch { unset aprops }

            array set aprops [lindex [mime::parseaddress $folderTarget] 0]
            set prefix \
                X-[lindex [split [join [split $aprops(local) /] _] .] 0]-
        } else {
            set prefix ""
        }

        set idF [file join $idD $prefix[join [split $messageID /] _]]
        if {[file exists $idF]} {
            tclLog "duplicate ID: $origProper $messageID ($subject)"

            cleanup
        }

        if {[catch { close [open $idF { WRONLY CREAT TRUNC }] } result]} {
            tclLog $result
        }
    }


# record information about the originator

    if {![string compare \
                 [set origAddress \
                      [string tolower $origLocal@$origDomain]] \
                 @]} {
        tclLog "no originator"

        if {!$impersonalP} {
            saveMessage $messageFile
        }

        cleanup
    }

    tclLog "DEBUG processing: $origProper <$messageID> ($subject)"

    if {![file isdirectory \
                   [set inD [file join $options(dataDirectory) inaddrs]]]} {
        file mkdir $inD
    }

    set inF [file join $inD [join [split $origAddress /] _]]
    if {[catch { set fd [open $inF { WRONLY CREAT TRUNC }] } result]} {
        tclLog $result
    } else {
        catch { puts $fd $origProper }
        if {[catch { close $fd } result]} {
            tclLog $result
        }
    }


# store impersonal mail in private folder area

    if {$impersonalP} {
        if {![string compare $messageID ""]} {
            cleanup "no Message-ID"
        }

        if {![file isdirectory $options(foldersDirectory)]} {
            file mkdir $foldersDirectory
        }

        array set mapping {}

        if {![catch { set fd [open $options(mappingFile) { RDONLY }] }]} {
            while {[gets $fd line] >= 0} {
                if {([llength [set map [split $line :]]] == 2) \
                        && ([string length \
                                    [set k [string trim [lindex $map 0]]]] \
                                > 0) \
                        && ([string length \
                                    [set v [string trim [lindex $map 1]]]] \
                                > 0)} {
                    set mapping($k) $v
                }
            }

            if {[catch { close $fd } result]} {
                tclLog $result
            }
        }

        if {![info exists mapping($folderTarget)]} {
            set mapping($folderTarget) store
        }
        if {![string compare $mapping($folderTarget) process]} {
            catch { set mapping($folderTarget) \
                        [processFolder $folderTarget $mime] }
        }
        switch -- $mapping($folderTarget) {
            store {
                dofolder $folderTarget $messageFile
            }

            ignore {
                tclLog "ignoring message for $folderTarget"
            }

            bounce {
                cleanup "rejecting message for $folderTarget" 67
            }

            default {
                if {[catch { smtp::sendmessage $mime \
                                 -atleastone true \
                                 -originator "" \
                                 -recipients $mapping($folderTarget) } \
                            result]} {
                    tclLog $result
                }
            }
        }

        cleanup
    }


# perform originator supression and guest list maintenance

    if {[string compare \
                [set resentProper \
                     [mutl::firstaddress \
                          [mutl::getheader $mime Resent-From]]] \
                ""]} {
        catch { unset aprops }

        array set aprops [lindex [mime::parseaddress $resentProper] 0]
        set resentLocal $aprops(local)
        set resentDomain $aprops(domain)

        if {[string compare \
                    [set resentAddress \
                         [string tolower $resentLocal@$resentDomain]] \
                    @]} {
            foreach p {Proper Local Domain Address} {
                set orig$p [set resent$p]
            }
        }
    }

    foreach p {out tmp bad} {
        if {![file isdirectory [set ${p}D [file join $options(dataDirectory) \
                                                ${p}addrs]]]} {
            file mkdir [set ${p}D]
        }

        set ${p}F [file join [set ${p}D] [join [split $origAddress /] _]]
    }

    pruneDir $tmpD addr


# deal with Klez-inspired nonsense
    if {([info exists options(dropNames)]) && ([catch { 
        foreach part [mime::getproperty $mime parts] {
            catch { unset params }
            array set params [mime::getproperty $part params]
            if {[info exists params(name)]} {
		foreach name $options(dropNames) {
		    if {[string match $name $params(name)]} {
                        tclLog "rejecting: $origProper <$messageID> ($subject) $params(name)"
                        cleanup
		    }
		}
            }
        }
    } result])} {
	tclLog "Klez-check: $result"
    }

    set friend ""
    if {[adminP $origLocal $origDomain]} {
        tclLog "DEBUG admin check: $origProper <$messageID> ($subject)"

# if DSNs were the rule, it would make sense to parse it... no such luck

        set fd [open $messageFile { RDONLY }]
        set text [read $fd]
        if {[catch { close $fd } result]} {
            tclLog $result
        }

        foreach file [glob -nocomplain [file join $badD *]] {
            set addr [file tail $file]
            if {([string match *$addr* $text]) \
                    || (([set x [string first @ $addr]] > 0) \
                            && ([string match \
                                        *[string range $addr 0 [expr $x-1]]* \
                                        $text]))} {
                tclLog "failure notice: $origProper ($addr)"

                cleanup
            }
        }

        tclLog "DEBUG admin continue: $origProper <$messageID> ($subject)"
    } elseif {(![ownerP $origLocal $origDomain]) \
                    && (![friendP $origLocal $origDomain]) \
                    && (![file exists $outF]) \
                    && (![file exists $tmpF]) \
                    && (![string compare ""\
		              [set friend [anyfriend $outD \
			                      [alladdrs $mime {To cc}]]]]) \
                    && (![findPhrase $subject]) \
                    && ([info exists options(noticeFile)])} {
        if {[file exists $badF]} {
            catch { file delete -- $badF }
        } elseif {[catch {
            set fd [open $options(noticeFile) { RDONLY }]
            set text [read $fd]
            if {[catch { close $fd } result]} {
                tclLog $result
            }

            regsub -all %passPhrase% $text [makePhrase] text
            for {set rsubject $subject} \
                    {[regexp -nocase ^re: $rsubject]} \
                    {set rsubject [string trimleft \
                                           [string range $rsubject 3 end]]} {
            }
            regsub -all %subject% $text $rsubject text

            smtp::sendmessage \
                [mime::initialize \
                     -canonical multipart/mixed \
                     -parts [list [mime::initialize \
                                       -canonical text/plain \
                                       -param {charset us-ascii} \
                                       -string $text] \
                                  [mime::initialize \
                                        -canonical message/rfc822 \
                                        -parts [list $mime]]]] \
                -originator "" \
                -header [list From    $options(myMailbox)] \
                -header [list To      $origProper] \
                -header [list Subject "Re: $rsubject"]

             set fd [open $badF { WRONLY CREAT TRUNC }]
        } result]} {
            tclLog $result
        } else {
            catch { puts $fd $origProper }
            if {[catch { close $fd } result]} {
                tclLog $result
            }
        }
        tclLog "rejecting: $origProper <$messageID> ($subject)"

        cleanup
    } elseif {[string compare $friend ""]} {
        tclLog "accepting: $origProper because of $friend"
    } else {
        if {[ownerP $origLocal $origDomain]} {
            set addrD $outD
        } else {
            set addrD $tmpD
        }

	foreach addr [alladdrs $mime \
		               {From To cc Resent-From Resent-To Resent-cc}] {
            catch { unset aprops }

            array set aprops $addr
            set addrLocal $aprops(local)
            set addrDomain $aprops(domain)

            if {[string compare \
                        [set addrAddress \
                             [string tolower $addrLocal@$addrDomain]] @]} {
                set addrF [file join $addrD [join [split $addrAddress /] _]]

                if {[file exists $addrF]} {
                    continue
                }

                if {[catch { set fd [open $addrF { WRONLY CREAT TRUNC }] } \
                           result]} {
                    tclLog $result
                } else {
                    catch { puts $fd $aprops(proper) }
                    if {[catch { close $fd } result]} {
                        tclLog $result
                    }
                }
	    }
        }
    }


# perform final actions, if we're the originator

    if {[ownerP $origLocal $origDomain]} {
        if {[info exists options(auditOutFile)]} {
            saveMessage $messageFile $options(auditOutFile)
        }

        cleanup
    }


# send a copy to the pda

    if {([info exists options(pdaMailboxes)]) \
            && ([string compare [set text [mutl::gathertext $mime]] ""])} {
        if {[info exists options(pdaMailsize)]} {
            set text [string range $text 0 [expr $options(pdaMailsize)-1]]
        }
        set pda [mime::initialize \
                     -canonical text/plain \
                     -param {charset us-ascii} \
                     -string $text]

        foreach key {From To cc Subject Date Reply-To} {
            foreach value [mutl::getheader $mime $key] {
                mime::setheader $pda $key $value -mode append
            }
        }

        if {[catch { smtp::sendmessage $pda \
                         -atleastone true \
                         -originator "" \
                         -recipients $options(pdaMailboxes) } result]} {
            tclLog $result
        }
    }


# send a copy to the remote mailbox

    if {[info exists options(remoteMailboxes)]} {
        if {[catch { smtp::sendmessage $mime \
                         -atleastone true \
                         -originator "" \
                         -recipients $options(remoteMailboxes) } result]} {
            tclLog $result
        } else {
            cleanup
        }
    }

    saveMessage $messageFile


    cleanup


} result]} {
    global errorCode errorInfo

    set ecode $errorCode
    set einfo $errorInfo

    if {(![catch { info body tclLog } result2]) \
            && ([string compare [string trim $result2] \
                        {catch {puts stderr $string}}])} {
        catch { tclLog $result }
    }

    catch {
        smtp::sendmessage \
            [mime::initialize \
                 -canonical text/plain \
                 -param  {charset us-ascii} \
                 -string "$result\n\nerrorCode: $ecode\n\n$einfo"] \
            -originator "" \
            -header [list From    [id user]@[info hostname]]       \
            -header [list To      operator@[info hostname]]        \
            -header [list Subject "[info hostname] fatal $program"]
    }

    cleanup $result
}


exit 75
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/mime/mbot/pkgIndex.tcl.

1
2
package ifneeded mutl 1.0 [list source [file join $dir mutl.tcl]]
package ifneeded mbox 1.0 [list source [file join $dir mbox.tcl]]
<
<




Deleted examples/nntp/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
This directory contains examples making use of the nntp module
provided by tcllib.

The file 'nntp.examples' provides a number of very small examples on
how to use the nntp module.

Beyond that there is currently only one application is available,
'postnews'. This application is a drop-in replacement of the 'postit'
application which came with my [1] Debian/Linux system. I wrote it
because 'postit' was unable to post articles to the host 'news' aka
'shawnews', i.e. the NNTP system provided by my new ISP here in
Vancouver. I had no big desire to look into the C code of 'postit' to
find out why it was unable to post, wrote a hack version of 'postnews'
in 15 minutes and when that worked my desire to debug 'postit' went
below zero. Another half an hour was spent the next evening with
'postnews' to polish it and make it a nice example for 'tcllib'.

Synopsis:

	postit articlelist newsserver

articlelist is a file in <newspsool>/outgoing containing a list of all
articles to push to the newsserver. It contains one line per article
to push. Each line consists of two fields, the path to the file
containing the article itself and the message id of the article. The
fields are separated by whitespace. The aformentioned path is relative
to <newsspool>.

The knowledge that articlelist = <newspsool>/outgoing/<somefile> holds
is essential to allow 'postnews' to compute the location of the
<newsspool> without a third argument.

The application carefully checks that the articlelist exists, is a
file and is readable. It also checks each articlefile in the same
manner. Only articles which are not known to the server are
posted. This check uses the message id in the articlelist, i.e. it
does not have to read the articlefile to determine this information.


-------------------------------------------------------------
[1] Andreas Kupries <[email protected]>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































Deleted examples/nntp/nntp.examples.

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

All commands require a 'package require nntp'

1. Connecting to default news server

    nntp::nntp

2. Connecting to non-default news server at non-default port

    nntp::nntp nntpserver.example.net 110

3. Connection to default nntp server and getting a list of newsgroups.

    # It might take awhile to print all the newsgroups
    set connection [nntp::nntp]
    set newsgroups [list ]
    foreach newsgroup [$connection list] {
        lappend newsgroups [lindex $newsgroup 0]
    }
    puts [join $newsgroups ", "]

4. Get basic information about a newsgroup

    set connection [nntp::nntp]
    foreach {total first last group} [$connection group comp.lang.tcl] {
        break
    }
    puts " newsgroup: $group\n message count: $total\n first message: $first\n\
           last message: $last"

5. Get your daily dose of c.l.t. from a tcl prompt

    set connection [nntp::nntp]
    $connection group comp.lang.tcl
    puts [join [$connection article] \n]

    # Repeat this until there are no more messages to read:
    $connection next
    puts [join [$connection article] \n]

6. Get the number, who sent the message, and the subjects of the first
   10 messages in c.l.t

    set connection [nntp::nntp]
    $connection group comp.lang.tcl
    set messageList [list ]

    foreach {total first last group} [$connection group comp.lang.tcl] {
        break
    }

    # Since we only want to see the first 10 messages, set last to $first + 10
    set last [expr {$first + 10}]
    set subjectList [$connection xhdr subject "$first-$last"]
    set fromList [$connection xhdr from "$first-$last"]

    foreach subject $subjectList from $fromList {
        if {([regexp {(\d+)\s+([^\s].*)} $from match number from] > 0) &&
                ([regexp {\d+\s+([^\s].*)} $subject match subject] > 0)} {
            lappend messageList "$number\t$from\t$subject"
        }
    }

    puts [join $messageList \n]

7. Search for all messages written by Jeff Hobbs in c.l.t


    set connection [nntp::nntp]
    $connection group comp.lang.tcl

    foreach {total first last group} [$connection group comp.lang.tcl] {
        break
    }

    $connection xpat from $first-$last "*Jeffrey Hobbs*"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































Deleted examples/nntp/postnews.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
#!/usr/local/bin/tclsh
# -*- tcl -*-
#
# This application is like 'postit', but written in tcl.
# The only package used is 'nntp' from 'tcllib'.
#
# Takes two arguments: 
# 1) The path to the file listing the articles to push
#    into the NNTP network
# 2) The name of the newsserver to push the articles to.
#
# The path to the spool directory is 1 level above the
# article file.

# Check number of arguments

if {[llength $argv] != 2} {
    puts stderr "$argv0: wrong # args, should be \"$argv0 articles newsserver\""
    exit 1
}

# Retrieve arguments

set articlefile [lindex $argv 0]
set newsserver  [lindex $argv 1]

# Validate file

if {![file exists $articlefile]} {
    puts stderr "$argv0: $articlefile does not exist"
    exit 1
}
if {[file isdirectory $articlefile]} {
    puts stderr "$argv0: $articlefile is not a file"
    exit 1
}
if {![file readable $articlefile]} {
    puts stderr "$argv0: $articlefile is not readable"
    exit 1
}

# Get path and article information

set spoolpath [file dirname [file dirname [file join [pwd] $articlefile]]]
set articles  [split [read [set fh [open $articlefile r]]][close $fh] \n]

puts "spooling from $spoolpath"

# Now we are ready to deal with the newsserver

package require nntp ; # from tcllib

proc nntp_cmd {exit title cmd {oktitle {}}} {
    global argv0 

    puts -nonewline stdout $title
    flush stdout
    if {[catch {
	set res [uplevel 1 $cmd]
    } msg]} {
	puts stdout " error: $msg"
	#puts stderr "$argv0: nntp error: $msg"
	if {$exit} {
	    exit 1
	}
	return 0
    } else {
	if {$oktitle != {}} {
	    puts stdout " $res $oktitle"
	} else {
	    puts stdout " $res"
	}
	return 1
    }
}

# Introduce us to the server

nntp_cmd 1 {open       } {set news [nntp::nntp $newsserver]}
nntp_cmd 1 {mode reader} {$news mode_reader}

# Iterate over all articles in the file.

set lastgroup {}

foreach article $articles {
    set article [string trim $article]
    if {$article == {}} {continue}

    foreach {msgfile id} [split $article] {break}

    # We have to validate the message files too.
    # Invalid files are skipped.

    set msgpath [file join $spoolpath $msgfile]

    if {![file exists $msgpath]} {
	puts stderr "article error: $msgfile does not exist"
	continue
    }
    if {[file isdirectory $msgpath]} {
	puts stderr "article error: $msgfile is not a file"
	continue
    }
    if {![file readable $msgpath]} {
	puts stderr "article error: $msgfile is not readable"
	continue
    }

    set group [join [file split [file dirname $msgfile]] .]

    if {[string compare $group $lastgroup] != 0} {

	if {![nntp_cmd 0 {set group  } {$news group $group}]} {
	    # Group does not exist or other error.
	    # Skip the article, can't post it.
	    continue
	}

	set lastgroup $group
    }

    # Group of the message is current, the message file itself is valid.
    # Proceed and check for existence of the article on the server.
    #                mode reader
    if {[nntp_cmd 0 {stat       } {$news stat $id} {article is present, skip}]} {
	continue
    }

    #continue

    if {[catch {
	set msg [read [set fh [open $msgpath r]]][close $fh]
    }]} {
	puts stderr "article error: $msgfile was deleted between check and actual posting"
        continue
    }

    puts stdout "post [llength [split $msg \n]] lines $id"

    nntp_cmd 0 {post       } {$news post $msg}
}

nntp_cmd 1 {quit       } {$news quit}
exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































Deleted examples/ntp/rdate.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
# rdate.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# NAME
#  rdate - set the system's date from a remote host
#
# SYNOPSIS
#  rdate [-psa] [-ut] host
#
# DESCRIPTION
#  Rdate displays and sets the local date and time from the host name or ad-
#  dress given as the argument. It uses the RFC868 protocol which is usually
#  implemented as a built-in service of inetd(8).
#
#  Available options:
#
#  -p      Do not set, just print the remote time
#
##  -s      Do not print the time.
##
##  -a      Use the adjtime(2) call to gradually skew the local time to the
##          remote time rather than just hopping.
#
#  -u      Use UDP
#
#  -t      Use TCP
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#
# $Id: rdate.tcl,v 1.1 2003/03/17 23:34:58 patthoyts Exp $

package require time;                   # tcllib 1.4

proc rdate {args} {
    # process the command line options.
    array set opts {-p 0 -s 0 -a 0 -t 0 -u x}
    while {[string match -* [set option [lindex $args 0]]]} {
        switch -exact -- $option {
            -p { set opts(-p) 1 }
            -u { set opts(-t) 0 }
            -t { set opts(-t) 1 }
            -s { return -code error "not implemented: use rdate(8)" }
            -a { return -code error "not implemented: use rdate(8)" }
            -- { ::time::Pop args; break }
            default {
                set err [join [lsort [array names opts -*]] ", "]
                return -code error "bad option $option: must be $err"
            }
        }
        ::time::Pop args
    }

    # Check that we have a host to talk to.
    if {[llength $args] != 1} {
        return -code error "wrong \# args: "
    }
    set host [lindex $args 0]

    # Construct the time command - optionally force the protocol to tcp
    set cmd ::time::gettime
    if {$opts(-t)} {
        lappend cmd -protocol tcp
    }
    lappend cmd $host

    # Perform the RFC 868 query (synchronously)
    set tok [eval $cmd]

    # Check for errors or extract the time in the unix epoch.
    set t 0
    if {[::time::status $tok] == "ok"} {
        set t [::time::unixtime $tok]
        ::time::cleanup $tok
    } else {
        set msg [::time::error $tok]
        ::time::cleanup $tok
        return -code error $msg 
    }

    # Display the time.
    if {$opts(-p)} {
        puts [clock format $t]
    }

    return
}

if {! $tcl_interactive} {
    eval rdate $argv
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































Deleted examples/oreilly-oscon2001/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
Example application using tcllib modules.
=========================================

This application (oscon) extracts session, track and talk information
from the O'Reilly OSCON webpages, collates them and writes some global
reports. It uses the tcllib modules "htmlparse", "struct" ("matrix",
"tree"), "csv", "report" and "log".

It is called as

	oscon <prefix> <htmlfile>...

reads the provided HTML files containing the webpages to process and
then produces the six files

	<prefix>.main.csv	All talks with time, location, track
				information, as CSV file.
	<prefix>.main.txt	As above, ASCII report
	<prefix>.main.html	As above, as HTML table

	<prefix>.sched.csv	Track information, sorted by day and
				start time, as CSV file
	<prefix>.sched.txt	As above, ASCII report
	<prefix>.sched.html	As above, as HTML table

Adding other reports (like room usage, east/west usage, ...) should be
rather easy.

If "a2ps" is available the script will additionally generate .ps files
out of the .txt files.

----------------------------------------------------------------

*Note*: The webpages used to develop this application are provided
here too to allow a successful operation of the example even if the
actual webpages at O'Reilly changed their format or are not available
anymore.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Deleted examples/oreilly-oscon2001/oscon.

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

package require struct
package require csv
package require report
package require htmlparse
package require textutil
package require log

# Restrict logging to levels 'info' and higher.
log::lvSuppressLE debug

# 1. CSV structure filled by the parser = main data table
#    ----------------------------------------------------
#    Day Time/Start Time/End Track Tower Room Speaker Title
#
#    Matrices: "dmain" and "dmainr"
#
#    Difference: dmainr contains gratituous newlines in the
#    speaker column which make for a better TXT report (less
#    wide).
#
#    This is also report 'main'.
#
# 2. Schedule report to see conflicts, CSV structure
#    ----------------------------------------------
#    Day Time                Location-Columns, one per Room
#        (15min granularity) (Content: Speaker + Topic)
#
#    Matrices: "sched" and "schedr". Difference as for dmain(r)
#	and the location columns
#
#    This will be report 'sched'.

proc main {} {
    global pfx argv

    set pfx   [lindex $argv 0]
    set files [lrange $argv 1 end]

    if {($pfx == {}) || ([llength $files] == 0)} {
	usage
	exit -1
    }

    initialize
    foreach f $files {
	log::log info "Scanning \"$f\" ..."
	parse $f
    }
    gen_schedule
    dump_main
    dump_schedule
    postscript
    return
}

proc usage {} {
    global argv0
    puts "usage: $argv0 prefix file..."
}


proc initialize {} {
    global rooms tracks
    ::struct::matrix::matrix dmain  ; # data 1
    ::struct::matrix::matrix dmainr ; # data 1r
    ::struct::matrix::matrix sched  ; # data 2
    ::struct::matrix::matrix schedr ; # data 2r
    array set rooms  {}
    array set tracks {}
    dmain  add columns 8
    dmain  add row {Day Start End Track Tower Room Speaker Title}
    dmainr add columns 8
    dmainr add row {Day Start End Track Tower Room Speaker Title}
    return
}

proc parse {htmlfile} {
    global rooms tracks

    ::struct::tree::tree t

    log::log info "Reading \"$htmlfile\" ..."
    set html [read [set fh [open $htmlfile]]]
    close $fh

    log::log info "Parsing \"$htmlfile\" ..."
    htmlparse::2tree $html t
    htmlparse::removeVisualFluff t
    htmlparse::removeFormDefs t

    log::log info "Extracting information"

    #puts ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # Navigate and extract the information
    #t walk root -command {print %t %n}
    #exit

    set base [walk {1 1 0 1 1 0 1 0 1 0}]
    set day  [walkf $base {0 0}]
    set day  [escape [t get $day -key data]]
    log::log debug "Day = $day"
    set day [string range $day 0 2]

    # Walk through the sessions of that day.

    set sess [t next $base]
    while {$sess != {}} {
	set start [cvtdate [escape [t get [walkf $sess {0 0}] -key data]]]
	set track [string trim [escape [t get [walkf $sess {1 0}] -key data]]]
	set loc   [escape [t get [walkf $sess {1 1 0}] -key data]]
	set loc   [string trimright $loc "\n\r\t:"]

	log::log debug "    $start - $track - $loc"

	# Separate Room/Tower information ...
	regexp {(.*) in the (.*) Tower} $loc -> room tower
	set room  [string trim $room]
	set tower [string trim $tower]
	set rooms($tower/$room) .
	set tracks($track) .

	set talk [walkf $sess {1 1 3}]
	while {$talk != {}} {
	    set time    [escape [t get $talk -key data]]
	    set talk    [t next $talk]
	    set title   [escape [t get [walkf $talk {0 0 0}] -key data]]
	    set speaker [escape [t get [walkf $talk {0 2}]   -key data]]

	    # Now we have everything to fill the main table ...
	    # (After a bit of munging of the strings we got)

	    foreach {start end} [split $time -] break
	    set start [cvtdate $start]
	    set end   [cvtdate $end]

	    regsub -all \r  $speaker \n speaker
	    regsub -all \n+ $speaker \n speaker
	    regsub -all " *\n *" $speaker "\n" speaker
	    set speakerc [split $speaker "\n"]
	    set speakerc [join $speakerc ", "]
	    log::log debug "        $start - $end - $speakerc - $title"

	    #puts >>$speakerc<<
	    #puts >>$speaker<<

	    #                Day Time/Start Time/End Tower Room Speaker Title
	    dmainr add row [list $day $start $end $track $tower $room $speaker  $title]
	    dmain  add row [list $day $start $end $track $tower $room $speakerc $title]

	    # Forward to next talk
	    catch {set talk [t next $talk]}
	    catch {set talk [t next $talk]}
	}

	set sess [t next $sess]
    }

    t destroy
    return
}

proc print {t n} {
    set  tp  [$t get $n -key type]
    set  d   [$t depth $n]
    set idx ""
    catch {set  idx [$t index $n]}
    incr d  $d
    incr d  $d

    switch -exact -- $tp {
        a {
            log::log debug "[textutil::strRepeat " " $d]$idx $tp ([$t get $n -key data]...)"
        }
        PCDATA {
            log::log debug "[textutil::strRepeat " " $d]$idx $tp ([string range [$t get $n -key data] 0 20]...)"
        }
        default {
            log::log debug "[textutil::strRepeat " " $d]$idx $tp"
        }
    }
}

proc walkf {n p} {
    #log::log info "$n + $p ="
    foreach idx $p {
        if {$n == ""} {break}
        set n [lindex [t children $n] $idx]
        #log::log info "$idx :- $n"
    }
    return $n
}

proc walk {p} {
    return [walkf root $p]
}

proc cvtdate {date} {
    clock format [clock scan $date] -format "%H:%M"
}

proc escape {text} {
    # Special escape for nbsp, convert into space and not the
    # character specified by the standard.

    regsub -all {&nbsp;} $text { } text
    htmlparse::mapEscapes $text
}


proc gen_schedule {} {
    global rooms tracks

    dmain  set rect 0 1 [lsort -decreasing -index 0 [lsort -index 1 [dmain  get rect 0 1 end end]]]
    dmainr set rect 0 1 [lsort -decreasing -index 0 [lsort -index 1 [dmainr get rect 0 1 end end]]]

    sched  add columns 2
    schedr add columns 2
    #sched  add columns [array size rooms]
    #schedr add columns [array size rooms]
    sched  add columns [array size tracks]
    schedr add columns [array size tracks]

    #log::log info Tracks=[array size tracks]
    #log::log info Rooms.=[array size rooms]

    set res [list Day Time]
    set c 2
    foreach k [lsort [array names tracks]] {
	lappend res $k
	set tracks($k) $c
	incr c
    }

    sched  add row $res
    schedr add row $res

    # Data in dmain is already sorted by day. By starting time only
    # partially, there are back references.
    # Just move them to the correct rooms and rows!

    #-- Day Time Location-Columns, one per Room --

    set n [dmain rows]
    set p 0

    array set rmap {}

    for {set r 1} {$r < $n} {incr r} {
	foreach {day start end track tower room speaker title} [dmain get row $r] break
	#[list $day $start $end $tower $room $speakerc $title]

	set key $day,$start
	if {![info exists rmap($key)]} {
	    log::log info "Track schedule $day $start"
	    sched  add row
	    schedr add row
	    incr p

	    set rmap($key) $p
	    sched  set cell 0 $p $day
	    sched  set cell 1 $p $start
	    schedr set cell 0 $p $day
	    schedr set cell 1 $p $start
	}

	sched  set cell $tracks($track) $rmap($key) "$tower; $room; $speaker; $title"
	schedr set cell $tracks($track) $rmap($key) "$tower $room\n$speaker\n$title"
    }

    # Squeeze the columns 2+ in the report matrix

    set cols [schedr columns]
    for {set c 2} {$c < $cols} {incr c} {

	if {[schedr columnwidth $c] > 21} {
	    log::log debug "Squeezing $c"
	    set col [schedr get column $c]
	    set res [list]
	    foreach item $col {
		lappend res [wrap $item 21]
	    }
	    schedr set column $c $res
	}
    }

    # Now sort by day (primary key) and starting time (secondary key).
    # (Meaning we have to sort by time first, and then the day)

    # sched  setrect 0 0 [lsort -decreasing -index 0 [lsort -index 1 [sched  getrect 0 0 end end]]]
    # schedr setrect 0 0 [lsort -decreasing -index 0 [lsort -index 1 [schedr getrect 0 0 end end]]]

    return
}

proc dump_main {} {
    global pfx
    log::log info "Writing talk information /CSV"

    set f [open ${pfx}.main.csv w]
    csv::writematrix dmain $f
    close $f

    log::log info "Writing talk information /TXT"

    # Compute width of report and squeeze the title column to fit
    # below 80 char/line

    # Day Time/Start Time/End Track Tower Room Speaker Title

    set total 0
    incr total [dmain columnwidth 0]
    incr total [dmain columnwidth 1]
    incr total [dmain columnwidth 2]
    incr total [dmain columnwidth 3]
    incr total [dmain columnwidth 4]
    incr total [dmain columnwidth 5]
    incr total [dmain columnwidth 6]

    #log::log info Total=$total

    if {$total < 80} {
	set total [expr {80 - $total}]
	set titles [dmain getcolumn 7]
	set res [list]
	foreach t $titles {
	    lappend res [textutil::adjust $t -length $total]
	}
	dmain setcolumn 7 $res
    }

    ::report::report r [dmainr columns] style captionedtable 1
    set f [open ${pfx}.main.txt w]
    r printmatrix2channel dmainr $f
    close $f
    r destroy

    # Now the HTML report, use 'dmain' as base, actually formatting
    # into lines is done by the browser.

    log::log info "Writing talk information /HTML"

    ::report::report r [dmain columns] style html

    set f [open ${pfx}.main.html w]
    puts $f "<html><head><title>Talk information and schedule</title></head><body>"
    puts $f "<h1>Talk information and schedule</h1>"
    puts $f "<p><table border=1>"
    r printmatrix2channel dmain $f
    puts $f "</table></p></body></html>"
    close $f
    r destroy
}

proc dump_schedule {} {
    global pfx
    log::log info "Writing track schedule /CSV"

    set f [open ${pfx}.sched.csv w]
    csv::writematrix sched $f
    close $f

    log::log info "Writing track schedule /TXT"

    ::report::report r [schedr columns] style captionedtable 1
    r datasep set [r top get]
    r datasep enable

    set f [open ${pfx}.sched.txt w]
    r printmatrix2channel schedr $f
    close $f
    r destroy

    # Now the HTML report, use 'sched' as base, actually formatting
    # into lines is done by the browser.

    log::log info "Writing track schedule /HTML"

    ::report::report r [sched columns] style html

    set f [open ${pfx}.sched.html w]
    puts $f "<html><head><title>Track schedules</title></head><body>"
    puts $f "<h1>Track schedules</h1>"
    puts $f "<p><table border=1>"
    r printmatrix2channel sched $f
    puts $f "</table></p></body></html>"
    close $f
    r destroy
}

proc postscript {} {
    global pfx
    # Transforms texts into printable postscript, using a2ps (if available)

    catch {exec a2ps -o ${pfx}.main.ps  -1 -B -r -f7 ${pfx}.main.txt}
    catch {exec a2ps -o ${pfx}.sched.ps -1 -B -r -f4 ${pfx}.sched.txt}
    return
}

proc wrap {text len} {
    # @author Jeffrey Hobbs <[email protected]>
    #
    # @c Wraps the given <a text> into multiple lines not
    # @c exceeding <a len> characters each. Lines shorter
    # @c than <a len> characters might get filled up.
    #
    # @a text: The string to operate on.
    # @a len: The maximum allowed length of a single line.
    #
    # @r Basically <a text>, but with changed newlines to
    # @r restrict the length of individual lines to at most
    # @r <a len> characters.

    # @n This procedure is not checked by the testsuite.

    # @i wrap, word wrap

    # Convert all newlines into spaces and initialize the result
    # see ::pool::string::oneLine too.

    regsub -all "\n" $text { } text
    incr len -1

    set out {}

    # As long as the string is longer than the intended length of
    # lines in the result:

    while {[string len $text] > $len} {
	# - Find position of last space in the part of the text
	#   which could a line in the result.

	# - We jump out of the loop if there is none and the whole
	#   text does not contain spaces anymore. In the latter case
	#   the rest of the text is one word longer than an intended
	#   line, we cannot avoid the longer line.

	set i [string last { } [string range $text 0 $len]]

	if {$i == -1 && [set i [string first { } $text]] == -1} {
	    break
	}

	# Get the just fitting part of the text, remove any heading
	# and trailing spaces, then append it to the result string,
	# don't close it with a newline!

	append out [string trim [string range $text 0 [incr i -1]]]\n

	# Shorten the text by the length of the processed part and
	# the space used to split it, then iterate.

	set text [string range $text [incr i 2] end]
    }

    return $out$text
}

# -------------------------------------------
# Define the required reports styles

::report::defstyle simpletable {} {
    data   set [split "[string repeat "| "   [columns]]|"]
    top    set [split "[string repeat "+ - " [columns]]+"]
    bottom set [top get]
    top	   enable
    bottom enable
}
::report::defstyle captionedtable {{n 1}} {
    simpletable
    topdata   set [data get]
    topcapsep set [top  get]
    topcapsep enable
    tcaption $n
}
::report::defstyle html {} {
    set c  [columns]
    set cl $c ; incr cl -1
    data set "<tr> [split [string repeat " " $cl] ""] </tr>"
    for {set col 0} {$col < $c} {incr col} {
	pad $col left  "<td>"
	pad $col right "</td>"
    }
    return
}

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

main
exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/oreilly-oscon2001/osconwrap.

1
2
3
4
5
6
#!/bin/sh
rm -f [1-4]*
./oscon 1wed sessions_wednesday.html
./oscon 2tue sessions_thursday.html
./oscon 3fri sessions_friday.html
./oscon 4all sessions_wednesday.html sessions_thursday.html sessions_friday.html
<
<
<
<
<
<












Deleted examples/oreilly-oscon2001/sessions_friday.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
<!--  w/print2.view  -->
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
   "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head> 
<title>conferences.oreilly.com -- O'Reilly Open Source Convention -- Sessions: Friday At-A-Glance</title>
<meta name="keywords" content="" />
<meta name="description" content=" " />
<link href="/style/style2.css" type="text/css" rel="stylesheet" />
</head>


<!--  OS2001/e_header  -->
<body bgcolor="#ffffff" vlink="#0000cc" link="#990000" text="#000000">
<table border="0" cellpadding="0" cellspacing="0" width="700">
<tr>
<td valign="top" colspan="2" nowrap="nowrap"><img src="/images/oscon01_header_main.gif" width="700" height="76" border="0" alt="O'Reilly Open Source Convention" /></td>
</tr>
<tr>
<td valign="top" colspan="2"><a href="http://www.oreilly.com/"><font color="#008800"><img  src="/images/oscon01_oreilly_tab.gif" width="92" height="18" border="0" alt="oreilly.com" /></font></a><a href="http://www.oreillynet.com/"><font color="#008800"><img src="/images/oscon01_orn_tab.gif" width="92" height="18" border="0" alt="O'Reilly Network" /></font></a><img src="/images/oscon01_header_tag.gif" width="516" height="18" border="0" alt=" " /></td>
</tr>
<tr>
<td valign="middle" bgcolor="#990000" nowrap="nowrap"><a href="http://conferences.oreilly.com/"><font color="#008800"><img src="/images/oscon01_nav_conf.gif" hspace="0" vspace="0" width="77" height="24" border="0" alt="Conferences" /></font></a><a href="http://software.oreilly.com/"><font color="#880000"><img src="/images/oscon01_nav_soft.gif" hspace="0" vspace="0" width="63" height="24" border="0" alt="Software" /></font></a><a href="http://international.oreilly.com/"><font color="#880000"><img src="/images/oscon01_nav_intl.gif" hspace="0" vspace="0" width="80" height="24" border="0" alt="International" /></font></a></td>
<td valign="middle" bgcolor="#990000" align="right" height="30" nowrap="nowrap">
<div class="tiny">
<form method="get" action="http://search.oreilly.com/cgi-bin/search">
<input type="text" id="term" name="term" size="20" />
<select id="category" name="category">
<option value="All">All of oreilly.com</option>
<option value="Books">Books</option>
<option value="Conferences">Conferences</option>
</select>
<input type="hidden" id="pref" name="pref" value="all" />
<input class="tiny" type="submit" value="Search" />
<img src="/images/dotclear.gif" width="2" height="1" alt=" " />
</div>
</td>
</form>
</tr>
</table>

<table border="0" cellpadding="0" cellspacing="0" width="700">
<tr>
<td width="135" valign="top" bgcolor="#000000">

<!--  OS2001 e_nav  -->
<img src="/images/dotclear.gif" width="135" height="10" /><br />
<table border="0" cellpadding="1" cellspacing="0"> 
<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="http://conferences.oreilly.com/oscon/" class="nav2"><font color="#008800">Home</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/register.html" class="nav2"><font color="#008800">Registration</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/hotel.html" class="nav2"><font color="#008800">Hotel/Travel</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/tutorials.html" class="nav2"><font color="#008800">Tutorials</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/sessions.html" class="nav2"><font color="#008800">Sessions</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/bofs.html" class="nav2"><font color="#008800">BOFs</font></a></td>
</tr>

<!--  tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/events.html" class="nav2">Events</a></td>
</tr  -->

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/speakers.html" class="nav2"><font color="#008800">Speakers</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/press.html" class="nav2"><font color="#008800">Press</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/maillist.html" class="nav2"><font color="#008800">Mail List</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/exhibitors.html" class="nav2"><font color="#008800">Exhibitors</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/sponsors.html" class="nav2"><font color="#008800">Sponsors</font></a></td>
</tr>
</table> 

&nbsp;<br />
</td>
<td valign="top" align="center" bgcolor="#ffffff">

<!--   sc/374 p2p e_content_header  -->
<table border="0" cellspacing="8" cellpadding="2" width="100%">
<tr>
<td colspan="2" valign="top">
<center>
<font size="3"><b>Innovate--Collaborate--Discover</b></font><br />
<font size="5"><b>O'Reilly Open Source Convention</b></font><br />
<font size="3"><b>Sheraton San Diego Hotel, San Diego, CA<br /> 
July 23-27, 2001</b></font>
<hr size="1" width="70%" />
</center>
</td>
</tr>
</table>

<table border="0" cellspacing="8" cellpadding="2" width="100%"><tr><td width="25%" valign="top" align="right">

<img src="/images/animals/hornbill_xs.gif" width="100" height="112" border="0" alt="Hornbill" />
<br /><br /><br />

<center><a href="http://conferences.oreillynet.com/cs/os2001/pub/10/register.html"><font color="#008800"><img src="/images/regnow_oscon.gif" width="100" height="100" border="0" alt="Register Now!" /></font></a><br /><font size="-1" color="#990000"><b><a href="http://conferences.oreillynet.com/cs/os2001/pub/10/register.html"><font color="#008800">Save up to $400</font></a><br />when you register<br />before June 22!</b></font></center>


</td><td width="75%" valign="top">

<h2>Sessions: Friday At-A-Glance</h2>

<table width="100%" cellpadding="6" cellspacing="1" border="0">
<tr valign="top">
<td colspan="2" bgcolor="#990000"><font size="4" color="#ffffff"><b>Friday, July 27</b></font></td>
</tr>
<!--  q/363  -->
<tr valign="top"><td bgcolor="#cccccc"><b>8:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Keynote</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">8:45am  - 10:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1528"><font color="#880000">The State of Open Source</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Tim&nbsp;O'Reilly

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Zope</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1240"><font color="#880000">Network Mapping and Management in Zope</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Scott&nbsp;Burton

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1241"><font color="#880000">OIO on Zope</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Andrew Po-Jung&nbsp;Ho

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1382"><font color="#880000">Using XML with Python</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Prescod

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1399"><font color="#880000">Pervasive XML: Viewing the World Through Infoset-colored Glasses</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Don&nbsp;Box

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 11:45am</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1400"><font color="#880000">XML and the 80/20 Point</font></a></b><br />



<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1439"><font color="#880000">Slash: Taming the Beast</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Brian&nbsp;Aker

<!--  e_spkr/first_last.view  -->
Chris&nbsp;Nandor<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1442"><font color="#880000">File Conversion for Space Shuttle Issue Trouble Reports</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Dave&nbsp;Carvell

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1446"><font color="#880000">The Conway Channel</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Damian&nbsp;Conway

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Apache</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1411"><font color="#880000">Automatic Content Insertion</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Anupriya&nbsp;Ramraj

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1412"><font color="#880000">Using Apache to Monitor Your Network for Disaster Recovery</font></a></b><br />

<!--  e_spkr/first_last.view  -->
John&nbsp;Haines

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Mozilla</b></font>
<blockquote>
<font size="-1"><b>Harbor Island III in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1531"><font color="#880000">Mozilla Developer Day</font></a></b><br />




<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1312"><font color="#880000">Creating an API for a Bioinformatic Web Application: The Metalloprotein-site Database and Browser at TSRI</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jesus&nbsp;Castagnetto

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Marina II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1533"><font color="#880000">PHP Meeting</font></a></b><br />




<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1357"><font color="#880000">A Tcl-Powered Handheld Computer for Telecommunications Test Automation</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Karl&nbsp;Lehenbauer

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 11:45am</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1358"><font color="#880000">A New Method for Embedding Tcl/Tk into Windows Applications</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Gravereaux

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">11:45am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1359"><font color="#880000">Fulfilling the Promise of [package unknown]</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Don&nbsp;Porter

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Linux</b></font>
<blockquote>
<font size="-1"><b>Harbor Island I in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1248"><font color="#880000">The Great Brain Race</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Eric&nbsp;Raymond

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30pm  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1251"><font color="#880000">FVNC: A Scaling and Faster VNC Viewer for X</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Ricardo Ueda&nbsp;Karpischek

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Open Source</b></font>
<blockquote>
<font size="-1"><b>Marina II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1534"><font color="#008800">Open Source Speech Processing Tools</font></a></b><br />




<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Zope</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1242"><font color="#880000">Using Perl with Zope</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Todd&nbsp;Coram

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1243"><font color="#880000">Enterprise Zope</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jim&nbsp;Fulton

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1383"><font color="#880000">Using XML with Tcl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Steve&nbsp;Ball

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1384"><font color="#880000">Jabber as a Platform for Specialized Messaging Services</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Carlos&nbsp;de la Guardia

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1532"><font color="#880000">Bleeding Edge XML</font></a></b><br />




<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1449"><font color="#880000">An Introduction to Mail::Audit</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Simon&nbsp;Cozens

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1509"><font color="#880000">Dissecting Regular Expressions</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jeff&nbsp;Pinyan

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:45pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1512"><font color="#880000">Extreme Perl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Damian&nbsp;Conway

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1525"><font color="#880000">Object-oriented Delegation</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Damian&nbsp;Conway

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Apache</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 3:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1413"><font color="#880000">Apache Portable Run-time: Why?</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Ryan&nbsp;Bloom

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1314"><font color="#880000">bware cache: Extending PHP to Cache-compiled Code Inside Web Server Memory</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Roberto&nbsp;Biancardi

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1315"><font color="#880000">Large-scale Web Application Development with PHP</font></a></b><br />

<!--  e_spkr/first_last.view  -->
John&nbsp;Donagher

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1360"><font color="#880000">RetrievalWare Query Tool: Glueware Between Knowledge Retrieval and Data Mining</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Mac&nbsp;Cody

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1361"><font color="#880000">Tcl/Tk in Survivability Modeling for Military Systems</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Ronald A.&nbsp;Bowers

<!--  e_spkr/first_last.view  -->
Robert G.&nbsp;Parker<!--  e_spkr/first_last.view  -->
Paul G.&nbsp;Tanenbaum<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1362"><font color="#880000">Computer Vision Scripting</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Stephan&nbsp;Scholze

<!--  e_spkr/first_last.view  -->
Christian&nbsp;Widmer<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Linux</b></font>
<blockquote>
<font size="-1"><b>Harbor Island I in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1249"><font color="#880000">RAD Programming on Linux</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Ray&nbsp;Lischner

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1250"><font color="#880000">Thin Clients and GNU/Linux Using LTSP</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jim&nbsp;McQuillan

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:00pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1254"><font color="#880000">An Introduction to Crystal Space Games Toolkit</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Richard D.&nbsp;Shank

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Zope</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:45pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1244"><font color="#880000">Zope Presentation Templates</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Todd&nbsp;Coram

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:45pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1245"><font color="#880000">Content Management with Zope CMF</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Tres&nbsp;Seaver

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1385"><font color="#880000">XML User Interfaces: SMIL and VoiceXML</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Fabio&nbsp;Arciniegas A.

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1386"><font color="#880000">Next Generation of Web Graphics: An Introduction to SVG</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Antoine&nbsp;Quint

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1467"><font color="#880000">Porting Perl to Make Porting Perl Unnecessary</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Gurusamy&nbsp;Sarathy

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1468"><font color="#880000">Embedded Testing with Pod::Tests</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Michael G.&nbsp;Schwern

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1513"><font color="#880000">Oracle::OCI Module</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Tim&nbsp;Bunce

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1433"><font color="#880000">How to Write a DBD Driver</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Daini Xie&nbsp;Strathy

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1519"><font color="#880000">Lightning Talks</font></a></b><br />




<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Apache</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1414"><font color="#880000">Web Security for Business: Creating and Implementing Private Certificate Authority with Openssl and mod_ssl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Weinstein

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1316"><font color="#880000">Client-side Applications with PHP</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Andrei&nbsp;Zmievski

<!--  e_spkr/first_last.view  -->
Frank&nbsp;Kromann<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1317"><font color="#880000">The Future of PHP (panel)</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jim&nbsp;Winstead

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1363"><font color="#880000">Taskflow: Encapsulation for Concurrent Scheduling and Execution in Tcl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Franc&nbsp;Brglez

<!--  e_spkr/first_last.view  -->
Hemang&nbsp;Lavana<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:15pm  - 4:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1364"><font color="#880000">Command, Control Integration Language (C2IL)</font></a></b><br />

<!--  e_spkr/first_last.view  -->
James T.&nbsp;Henning

<!--  e_spkr/first_last.view  -->
Debra J.&nbsp;Siquieros<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">4:45pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1365"><font color="#880000">Next Generation of Integration with Tcl/Tk</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Vice

<!--  e_spkr/first_last.view  -->
Gerald&nbsp;Lester<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Linux</b></font>
<blockquote>
<font size="-1"><b>Harbor Island I in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1253"><font color="#880000">Creating a Development Environment for Embedded Linux</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Dr. Richard&nbsp;Sevenich

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1252"><font color="#880000">Embedded Linux Case Study: The Flying Penguin</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Christopher&nbsp;Grill

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<!--  end q/363  -->

</table>






</td>
</tr>
<tr>
<td colspan="2" align="center">
<!--  OS2001 footer  -->

<hr size="1" noshade="noshade" />
<font size="1" face="Verdana, Arial, Helvetica">
<b><a href="http://www.oreilly.com/"><font color="#008800">oreilly.com Home</font></a> | 
<a href="http://conferences.oreilly.com/"><font color="#008800">Conferences Home</font></a> |
<a href="http://conferences.oreilly.com/oscon/"><font color="#008800">Open Source Convention Home</font></a><br />
<a href="/cs/os2001/pub/10/register.html"><font color="#008800">Registration</font></a> | 
<a href="/cs/os2001/pub/10/hotel.html"><font color="#008800">Hotels/Travel</font></a> | 
<a href="/cs/os2001/pub/10/tutorials.html"><font color="#008800">Tutorials</font></a> | 
<a href="/cs/os2001/pub/10/sessions.html"><font color="#008800">Sessions</font></a> |
<a href="/cs/os2001/pub/10/speakers.html"><font color="#008800">Speakers</font></a><br />
<a href="/cs/os2001/pub/10/press.html"><font color="#008800">Press</font></a> |
<a href="/cs/os2001/pub/10/maillist.html"><font color="#008800">Mail List</font></a> | 
<a href="/cs/os2001/pub/10/exhibitors.html"><font color="#008800">Exhibitors</font></a> | 
<a href="/cs/os2001/pub/10/sponsors.html"><font color="#008800">Sponsors</font></a><br />
</b>
<br /><img src="/images/dotclear.gif" width="1" height="6" 
alt=" " /><br />
<i>&copy; 2001, O'Reilly &amp; Associates, Inc.<br />
<a href="mailto:[email protected]"><font color="#880000">[email protected]</font></a>
</i>
</font></td>
</tr>
</table>
</td>
</tr>
</table><!-- This section is added by WWWOFFLE -->
     <hr>
<p align=center>
WWWOFFLE - Sun, 22 Apr 2001 21:56:19 CEST (vor 1 Tag) - [<a
href="http://localhost:8080/control/delete-url/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_friday.html">L&ouml;schen</a>|
<a href="http://localhost:8080/refresh/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_friday.html">Neu&nbsp;abrufen</a>:
<a href="http://localhost:8080/refresh-options/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_friday.html">Optionen</a>|
<a href="http://localhost:8080/monitor-options/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_friday.html">regelm.&nbsp;abrufen</a>|
<a href="http://localhost:8080/index/url/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_friday.html">Index</a>] - WWWOFFLE
</p>
<hr>
<!-- This section is added by WWWOFFLE -->
</body> 

</html>





































































<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/oreilly-oscon2001/sessions_thursday.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
<!--  w/print2.view  -->
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
   "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head> 
<title>conferences.oreilly.com -- O'Reilly Open Source Convention -- Sessions: Thursday At-A-Glance</title>
<meta name="keywords" content="" />
<meta name="description" content=" " />
<link href="/style/style2.css" type="text/css" rel="stylesheet" />
</head>


<!--  OS2001/e_header  -->
<body bgcolor="#ffffff" vlink="#0000cc" link="#990000" text="#000000">
<table border="0" cellpadding="0" cellspacing="0" width="700">
<tr>
<td valign="top" colspan="2" nowrap="nowrap"><img src="/images/oscon01_header_main.gif" width="700" height="76" border="0" alt="O'Reilly Open Source Convention" /></td>
</tr>
<tr>
<td valign="top" colspan="2"><a href="http://www.oreilly.com/"><font color="#008800"><img  src="/images/oscon01_oreilly_tab.gif" width="92" height="18" border="0" alt="oreilly.com" /></font></a><a href="http://www.oreillynet.com/"><font color="#008800"><img src="/images/oscon01_orn_tab.gif" width="92" height="18" border="0" alt="O'Reilly Network" /></font></a><img src="/images/oscon01_header_tag.gif" width="516" height="18" border="0" alt=" " /></td>
</tr>
<tr>
<td valign="middle" bgcolor="#990000" nowrap="nowrap"><a href="http://conferences.oreilly.com/"><font color="#008800"><img src="/images/oscon01_nav_conf.gif" hspace="0" vspace="0" width="77" height="24" border="0" alt="Conferences" /></font></a><a href="http://software.oreilly.com/"><font color="#880000"><img src="/images/oscon01_nav_soft.gif" hspace="0" vspace="0" width="63" height="24" border="0" alt="Software" /></font></a><a href="http://international.oreilly.com/"><font color="#880000"><img src="/images/oscon01_nav_intl.gif" hspace="0" vspace="0" width="80" height="24" border="0" alt="International" /></font></a></td>
<td valign="middle" bgcolor="#990000" align="right" height="30" nowrap="nowrap">
<div class="tiny">
<form method="get" action="http://search.oreilly.com/cgi-bin/search">
<input type="text" id="term" name="term" size="20" />
<select id="category" name="category">
<option value="All">All of oreilly.com</option>
<option value="Books">Books</option>
<option value="Conferences">Conferences</option>
</select>
<input type="hidden" id="pref" name="pref" value="all" />
<input class="tiny" type="submit" value="Search" />
<img src="/images/dotclear.gif" width="2" height="1" alt=" " />
</div>
</td>
</form>
</tr>
</table>

<table border="0" cellpadding="0" cellspacing="0" width="700">
<tr>
<td width="135" valign="top" bgcolor="#000000">

<!--  OS2001 e_nav  -->
<img src="/images/dotclear.gif" width="135" height="10" /><br />
<table border="0" cellpadding="1" cellspacing="0"> 
<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="http://conferences.oreilly.com/oscon/" class="nav2"><font color="#008800">Home</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/register.html" class="nav2"><font color="#008800">Registration</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/hotel.html" class="nav2"><font color="#008800">Hotel/Travel</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/tutorials.html" class="nav2"><font color="#008800">Tutorials</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/sessions.html" class="nav2"><font color="#008800">Sessions</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/bofs.html" class="nav2"><font color="#008800">BOFs</font></a></td>
</tr>

<!--  tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/events.html" class="nav2">Events</a></td>
</tr  -->

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/speakers.html" class="nav2"><font color="#008800">Speakers</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/press.html" class="nav2"><font color="#008800">Press</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/maillist.html" class="nav2"><font color="#008800">Mail List</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/exhibitors.html" class="nav2"><font color="#008800">Exhibitors</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/sponsors.html" class="nav2"><font color="#008800">Sponsors</font></a></td>
</tr>
</table> 

&nbsp;<br />
</td>
<td valign="top" align="center" bgcolor="#ffffff">

<!--   sc/374 p2p e_content_header  -->
<table border="0" cellspacing="8" cellpadding="2" width="100%">
<tr>
<td colspan="2" valign="top">
<center>
<font size="3"><b>Innovate--Collaborate--Discover</b></font><br />
<font size="5"><b>O'Reilly Open Source Convention</b></font><br />
<font size="3"><b>Sheraton San Diego Hotel, San Diego, CA<br /> 
July 23-27, 2001</b></font>
<hr size="1" width="70%" />
</center>
</td>
</tr>
</table>

<table border="0" cellspacing="8" cellpadding="2" width="100%"><tr><td width="25%" valign="top" align="right">

<img src="/images/animals/hornbill_xs.gif" width="100" height="112" border="0" alt="Hornbill" />
<br /><br /><br />

<center><a href="http://conferences.oreillynet.com/cs/os2001/pub/10/register.html"><font color="#008800"><img src="/images/regnow_oscon.gif" width="100" height="100" border="0" alt="Register Now!" /></font></a><br /><font size="-1" color="#990000"><b><a href="http://conferences.oreillynet.com/cs/os2001/pub/10/register.html"><font color="#008800">Save up to $400</font></a><br />when you register<br />before June 22!</b></font></center>


</td><td width="75%" valign="top">

<h2>Sessions: Thursday At-A-Glance</h2>

<table width="100%" cellpadding="6" cellspacing="1" border="0">
<tr valign="top">
<td colspan="2" bgcolor="#990000"><font size="4" color="#ffffff"><b>Thursday, July 26</b></font></td>
</tr>
<!--  q/363  -->
<tr valign="top"><td bgcolor="#cccccc"><b>8:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Keynote</b></font>
<blockquote>
<font size="-1"><b>Grand Ballroom in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">8:45am  - 10:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1529"><font color="#880000">An Open Source Success Story on Wall Street</font></a></b><br />


<!--  e_spkr/first_last.view  -->
W. Phillip&nbsp;Moore

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>mod_perl</b></font>
<blockquote>
<font size="-1"><b>Harbor Island I in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1266"><font color="#880000">Developing a B2B Commerce Site Using Perl/Mason</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jaron&nbsp;Rubenstein

<!--  e_spkr/first_last.view  -->
Edward&nbsp;Zborowski<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1523"><font color="#880000">Authentication and Authorization with mod_perl</font></a></b><br />

<!--  e_spkr/first_last.view  -->
James G.&nbsp;Smith

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PostgreSQL</b></font>
<blockquote>
<font size="-1"><b>Bel Aire South in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1320"><font color="#880000">Using PostgreSQL in Web Applications</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Gavin M.&nbsp;Roy

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1321"><font color="#880000">Moving From Flat File Storage to RDBMS</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Aldrich

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1379"><font color="#880000">Using XML with Perl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Kip&nbsp;Hampton

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1393"><font color="#880000">SOAP Mishaps and Mistakes</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Don&nbsp;Box

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1394"><font color="#880000">A Specification for Common RPC Identification Services</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Randy&nbsp;Ray

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1443"><font color="#880000">Grokking the CPAN</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Elaine&nbsp;Ashton

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1448"><font color="#880000">10 Modules I Wouldn't Go Anywhere Without</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Simon&nbsp;Cozens

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1490"><font color="#880000">Default Lexical Scoping in Perl and Other Languages</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Daniel&nbsp;Chetlin

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 11:45am</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1491"><font color="#880000">Perl and Speech</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Kevin&nbsp;Lenzo

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">11:45am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1492"><font color="#880000">Extensible POD</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Adam&nbsp;Turoff

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1495"><font color="#880000">Internals of Rx</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Mark-Jason&nbsp;Dominus

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:45am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1450"><font color="#880000">Dirty Stories About the Perl Regex Engine</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Mark-Jason&nbsp;Dominus

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 11:45am</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1496"><font color="#880000">ReBug</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Michel&nbsp;Lambert

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Python</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1331"><font color="#880000">New Features in Python 2</font></a></b><br />


<!--  e_spkr/first_last.view  -->
David&nbsp;Beazley

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Mozilla</b></font>
<blockquote>
<font size="-1"><b>Harbor Island III in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1278"><font color="#880000">Using JavaScript with XPCOM: Components the Easy Way</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Michael&nbsp;Ang

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1289"><font color="#880000">Using XPCOM and Python with Mozilla</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Mark&nbsp;Hammond

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1306"><font color="#880000">Under the Hood of PHP: Advanced Techniques for Developing PHP Extensions</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Andi&nbsp;Gutmans

<!--  e_spkr/first_last.view  -->
Zeev&nbsp;Suraski<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1307"><font color="#880000">PEAR: The PHP Extension and Application Repository</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Stig&nbsp;Bakken

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1350"><font color="#008800">The (Active) State of Tcl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jeff&nbsp;Hobbs

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Open Source</b></font>
<blockquote>
<font size="-1"><b>Marina II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1290"><font color="#880000">Embracing Insanity: Understanding the Open Source Community</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Russell C.&nbsp;Pavlicek

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1291"><font color="#880000">Sharing Open Source Java Components on Wall Street</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Carl&nbsp;Reed

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PostgreSQL</b></font>
<blockquote>
<font size="-1"><b>Bel Aire South in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 3:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1322"><font color="#880000">OpenACS:  Porting Oracle Apps to PostgreSQL</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Benjamin&nbsp;Adida

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 3:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1380"><font color="#880000">Understanding XML Namespaces</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Aaron&nbsp;Skonnard

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1395"><font color="#880000">XSLT and Scripting Languages</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Prescod

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1396"><font color="#880000">Orchard: A New API for XML</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Matt&nbsp;Sergeant

<!--  e_spkr/first_last.view  -->
Ken&nbsp;McLeod<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1472"><font color="#880000">Cross Database Perl Applications</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Matt&nbsp;Sergeant

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1470"><font color="#880000">TIGER by the Tail: Geographic Mapping Systems from Public Domain Data</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Michael G.&nbsp;Schwern

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1473"><font color="#880000">The Perl Geek Code</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Michel&nbsp;Rodriguez

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1514"><font color="#880000">Camel Goes Surfing</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Andy&nbsp;Wardley

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1489"><font color="#880000">Developing WAP Applications with Perl</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Dan&nbsp;Brian

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1516"><font color="#880000">Camelot</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Andy&nbsp;Wardley

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Python</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1332"><font color="#880000">Programmer's Package Manager: Using SOAP to Fetch Pre-built Python Packages</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Trent&nbsp;Mick

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1333"><font color="#880000">Using Python to Customize, Extend, and Integrate Enterprise Project Management Software</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Deborah&nbsp;Davidson

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1334"><font color="#880000">The Adventures of a Snake in the Land of Camels</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Ascher

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Apache</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1407"><font color="#880000">Filesystem Layouts and Apache Performance</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jeff D.&nbsp;Almeida

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Mozilla</b></font>
<blockquote>
<font size="-1"><b>Harbor Island III in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1276"><font color="#880000">Mozilla Community Quality Assurance and Testing</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Asa&nbsp;Dotzler

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1530"><font color="#880000">Lightning Talks</font></a></b><br />



<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1308"><font color="#880000">PHP as a Teaching Language: A Case Study</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Laura&nbsp;Thomson

<!--  e_spkr/first_last.view  -->
Luke&nbsp;Welling<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1309"><font color="#880000">PHP in the Wireless World</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Roland&nbsp;Schmidt

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1351"><font color="#880000">Tcl/Tk in the Analog Simulation Environment at Agere Systems</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Michael S.&nbsp;Toth

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1352"><font color="#880000">Taskflow: An XML Schema and a Universally Configurable Client in Tcl/Tk</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Hemang&nbsp;Lavana

<!--  e_spkr/first_last.view  -->
Franc&nbsp;Brglez<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1353"><font color="#880000">Scripting Data Structures</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Mark&nbsp;Harrison

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Open Source</b></font>
<blockquote>
<font size="-1"><b>Marina II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1292"><font color="#880000">Using TreeMenu to Display Decision Trees Built with Perm and Data Extracted from a SQL Database</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Richard L.&nbsp;Holbert

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1293"><font color="#880000">Principles of XP and Open Source</font></a></b><br />

<!--  e_spkr/first_last.view  -->
&nbsp;chromatic

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PostgreSQL</b></font>
<blockquote>
<font size="-1"><b>Bel Aire South in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1323"><font color="#880000">Tools for Managing Your PostgreSQL Database Environment</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Mark&nbsp;Cotton

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1324"><font color="#880000">Gedafe:  The Generic Database Frontend</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Schweikert

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 5:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1381"><font color="#880000">A Guide to W3C XML Schemas</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Martin&nbsp;Gudgin

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1397"><font color="#880000">Redfoot RDF Application Framework</font></a></b><br />


<!--  e_spkr/first_last.view  -->
James&nbsp;Tauber

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1398"><font color="#880000">XML Linking Technologies</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Eric&nbsp;van der Vlist

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1445"><font color="#880000">Lazy Website Maintenance</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Damian&nbsp;Conway

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1441"><font color="#880000">VSAP: A Dynamic, Scalable Hosting Application Platform</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Dan&nbsp;Brian

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1461"><font color="#880000">Perl on the Microsoft .NET Framework</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jan&nbsp;Dubois

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1460"><font color="#880000">SOAP: The Power of Simplicity</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Paul&nbsp;Kulchenko

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1503"><font color="#880000">A First Look at the Insides of Perl 6</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Dan&nbsp;Sugalski

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1504"><font color="#880000">What's New in 5.8</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jarkko&nbsp;Hietaniemi

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Python</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1335"><font color="#880000">PyDebug: A New Application for Integrated Debugging of Python with C and Fortran Extensions</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Peter&nbsp;Stoltz

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:15pm  - 4:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1336"><font color="#880000">Component-oriented Programming in Python</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Brian&nbsp;Kelley

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Apache</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1409"><font color="#880000">Web Security for Business: Introduction to mod_ssl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Weinstein

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1410"><font color="#880000">Apache's Role in a PKI</font></a></b><br />

<!--  e_spkr/first_last.view  -->
James G.&nbsp;Smith

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Mozilla</b></font>
<blockquote>
<font size="-1"><b>Harbor Island III in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1279"><font color="#880000">Networking in Mozilla</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Gagan&nbsp;Saksena

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1280"><font color="#880000">Jabberzilla and Mozilla Integration</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Eric&nbsp;Murphy

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>PHP 1</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1310"><font color="#880000">XSLT and PHP</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Sterling&nbsp;Hughes

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1311"><font color="#880000">Using PHP+XML-RPC to Develop Open GroupWare Standard (OGWS)</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Dan&nbsp;Kuykendall

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1354"><font color="#880000">TSIPP Workbench: Working Widgets Without Code</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Welton

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:15pm  - 4:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1355"><font color="#880000">KitView: A User Interface Tool for MetaKit</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Steve&nbsp;Landers

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">4:45pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1356"><font color="#880000">Tcl/Tk Extensions for Visualization of Large Data Sets</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Neil&nbsp;McKay

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Open Source</b></font>
<blockquote>
<font size="-1"><b>Marina II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1295"><font color="#880000">Sharing the Wealth: Why Publically Versioned Resources are the Future of Everything</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Karl&nbsp;Fogel

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:15pm  - 4:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1296"><font color="#880000">Comparing Open Source Indexers</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Eric Lease&nbsp;Morgan

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">4:45pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1297"><font color="#880000">Internationalized Programming with Perl and ICU</font></a></b><br />

<!--  e_spkr/first_last.view  -->
James&nbsp;Briggs

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<!--  end q/363  -->

</table>






</td>
</tr>
<tr>
<td colspan="2" align="center">
<!--  OS2001 footer  -->

<hr size="1" noshade="noshade" />
<font size="1" face="Verdana, Arial, Helvetica">
<b><a href="http://www.oreilly.com/"><font color="#008800">oreilly.com Home</font></a> | 
<a href="http://conferences.oreilly.com/"><font color="#008800">Conferences Home</font></a> |
<a href="http://conferences.oreilly.com/oscon/"><font color="#008800">Open Source Convention Home</font></a><br />
<a href="/cs/os2001/pub/10/register.html"><font color="#008800">Registration</font></a> | 
<a href="/cs/os2001/pub/10/hotel.html"><font color="#008800">Hotels/Travel</font></a> | 
<a href="/cs/os2001/pub/10/tutorials.html"><font color="#008800">Tutorials</font></a> | 
<a href="/cs/os2001/pub/10/sessions.html"><font color="#008800">Sessions</font></a> |
<a href="/cs/os2001/pub/10/speakers.html"><font color="#008800">Speakers</font></a><br />
<a href="/cs/os2001/pub/10/press.html"><font color="#008800">Press</font></a> |
<a href="/cs/os2001/pub/10/maillist.html"><font color="#008800">Mail List</font></a> | 
<a href="/cs/os2001/pub/10/exhibitors.html"><font color="#008800">Exhibitors</font></a> | 
<a href="/cs/os2001/pub/10/sponsors.html"><font color="#008800">Sponsors</font></a><br />
</b>
<br /><img src="/images/dotclear.gif" width="1" height="6" 
alt=" " /><br />
<i>&copy; 2001, O'Reilly &amp; Associates, Inc.<br />
<a href="mailto:[email protected]"><font color="#880000">[email protected]</font></a>
</i>
</font></td>
</tr>
</table>
</td>
</tr>
</table><!-- This section is added by WWWOFFLE -->
     <hr>
<p align=center>
WWWOFFLE - Sun, 22 Apr 2001 21:56:20 CEST (vor 1 Tag) - [<a
href="http://localhost:8080/control/delete-url/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_thursday.html">L&ouml;schen</a>|
<a href="http://localhost:8080/refresh/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_thursday.html">Neu&nbsp;abrufen</a>:
<a href="http://localhost:8080/refresh-options/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_thursday.html">Optionen</a>|
<a href="http://localhost:8080/monitor-options/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_thursday.html">regelm.&nbsp;abrufen</a>|
<a href="http://localhost:8080/index/url/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_thursday.html">Index</a>] - WWWOFFLE
</p>
<hr>
<!-- This section is added by WWWOFFLE -->
</body> 

</html>





































































<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/oreilly-oscon2001/sessions_wednesday.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
<!--  w/print2.view  -->
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
   "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head> 
<title>conferences.oreilly.com -- O'Reilly Open Source Convention -- Sessions: Wednesday At-A-Glance</title>
<meta name="keywords" content="" />
<meta name="description" content=" " />
<link href="/style/style2.css" type="text/css" rel="stylesheet" />
</head>


<!--  OS2001/e_header  -->
<body bgcolor="#ffffff" vlink="#0000cc" link="#990000" text="#000000">
<table border="0" cellpadding="0" cellspacing="0" width="700">
<tr>
<td valign="top" colspan="2" nowrap="nowrap"><img src="/images/oscon01_header_main.gif" width="700" height="76" border="0" alt="O'Reilly Open Source Convention" /></td>
</tr>
<tr>
<td valign="top" colspan="2"><a href="http://www.oreilly.com/"><font color="#008800"><img  src="/images/oscon01_oreilly_tab.gif" width="92" height="18" border="0" alt="oreilly.com" /></font></a><a href="http://www.oreillynet.com/"><font color="#008800"><img src="/images/oscon01_orn_tab.gif" width="92" height="18" border="0" alt="O'Reilly Network" /></font></a><img src="/images/oscon01_header_tag.gif" width="516" height="18" border="0" alt=" " /></td>
</tr>
<tr>
<td valign="middle" bgcolor="#990000" nowrap="nowrap"><a href="http://conferences.oreilly.com/"><font color="#008800"><img src="/images/oscon01_nav_conf.gif" hspace="0" vspace="0" width="77" height="24" border="0" alt="Conferences" /></font></a><a href="http://software.oreilly.com/"><font color="#880000"><img src="/images/oscon01_nav_soft.gif" hspace="0" vspace="0" width="63" height="24" border="0" alt="Software" /></font></a><a href="http://international.oreilly.com/"><font color="#880000"><img src="/images/oscon01_nav_intl.gif" hspace="0" vspace="0" width="80" height="24" border="0" alt="International" /></font></a></td>
<td valign="middle" bgcolor="#990000" align="right" height="30" nowrap="nowrap">
<div class="tiny">
<form method="get" action="http://search.oreilly.com/cgi-bin/search">
<input type="text" id="term" name="term" size="20" />
<select id="category" name="category">
<option value="All">All of oreilly.com</option>
<option value="Books">Books</option>
<option value="Conferences">Conferences</option>
</select>
<input type="hidden" id="pref" name="pref" value="all" />
<input class="tiny" type="submit" value="Search" />
<img src="/images/dotclear.gif" width="2" height="1" alt=" " />
</div>
</td>
</form>
</tr>
</table>

<table border="0" cellpadding="0" cellspacing="0" width="700">
<tr>
<td width="135" valign="top" bgcolor="#000000">

<!--  OS2001 e_nav  -->
<img src="/images/dotclear.gif" width="135" height="10" /><br />
<table border="0" cellpadding="1" cellspacing="0"> 
<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="http://conferences.oreilly.com/oscon/" class="nav2"><font color="#008800">Home</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/register.html" class="nav2"><font color="#008800">Registration</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/hotel.html" class="nav2"><font color="#008800">Hotel/Travel</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/tutorials.html" class="nav2"><font color="#008800">Tutorials</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/sessions.html" class="nav2"><font color="#008800">Sessions</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/bofs.html" class="nav2"><font color="#008800">BOFs</font></a></td>
</tr>

<!--  tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/events.html" class="nav2">Events</a></td>
</tr  -->

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/speakers.html" class="nav2"><font color="#008800">Speakers</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/press.html" class="nav2"><font color="#008800">Press</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/maillist.html" class="nav2"><font color="#008800">Mail List</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/exhibitors.html" class="nav2"><font color="#008800">Exhibitors</font></a></td>
</tr>

<tr>
<td><img src="/images/nav_arrow_oscon.gif" width="20" height="18" alt="Arrow" border="0" /></td>
<td valign="top"><a href="/cs/os2001/pub/10/sponsors.html" class="nav2"><font color="#008800">Sponsors</font></a></td>
</tr>
</table> 

&nbsp;<br />
</td>
<td valign="top" align="center" bgcolor="#ffffff">

<!--   sc/374 p2p e_content_header  -->
<table border="0" cellspacing="8" cellpadding="2" width="100%">
<tr>
<td colspan="2" valign="top">
<center>
<font size="3"><b>Innovate--Collaborate--Discover</b></font><br />
<font size="5"><b>O'Reilly Open Source Convention</b></font><br />
<font size="3"><b>Sheraton San Diego Hotel, San Diego, CA<br /> 
July 23-27, 2001</b></font>
<hr size="1" width="70%" />
</center>
</td>
</tr>
</table>

<table border="0" cellspacing="8" cellpadding="2" width="100%"><tr><td width="25%" valign="top" align="right">

<img src="/images/animals/hornbill_xs.gif" width="100" height="112" border="0" alt="Hornbill" />
<br /><br /><br />

<center><a href="http://conferences.oreillynet.com/cs/os2001/pub/10/register.html"><font color="#008800"><img src="/images/regnow_oscon.gif" width="100" height="100" border="0" alt="Register Now!" /></font></a><br /><font size="-1" color="#990000"><b><a href="http://conferences.oreillynet.com/cs/os2001/pub/10/register.html"><font color="#008800">Save up to $400</font></a><br />when you register<br />before June 22!</b></font></center>


</td><td width="75%" valign="top">

<h2>Sessions: Wednesday At-A-Glance</h2>

<table width="100%" cellpadding="6" cellspacing="1" border="0">

<tr valign="top">
<td colspan="2" bgcolor="#990000"><font size="4" color="#ffffff"><b>Wednesday, July 25</b></font></td>
</tr>
<!--  q/363  -->
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>MySQL</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1284"><font color="#880000">MySQL for Industrial Strength Mailing Listservers</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Mark&nbsp;Karaman

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1285"><font color="#880000">MySQL Server and Application Performance Tuning</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jeremy D.&nbsp;Zawodny

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>mod_perl</b></font>
<blockquote>
<font size="-1"><b>Harbor Island I in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1263"><font color="#880000">Choosing a Templating System</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Perrin&nbsp;Harkins

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1271"><font color="#880000">Exception Handling in mod_perl</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Matt&nbsp;Sergeant

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1373"><font color="#880000">Open Source, Open Data</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Simon&nbsp;St.Laurent

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1374"><font color="#880000">Internet Computing with Web Services</font></a></b><br />

<!--  e_spkr/first_last.view  -->
James&nbsp;Tauber

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:15am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1387"><font color="#880000">Collection Indexing: Improving Web Directory Listings with XML Technologies</font></a></b><br />


<!--  e_spkr/first_last.view  -->
John&nbsp;Tigue

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:15am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1388"><font color="#880000">Charlie as Application Framework</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Petr&nbsp;Cimprich

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1438"><font color="#880000">Transfusing Message Plasma into Business with Perl and Other  Magic</font></a></b><br />


<!--  e_spkr/first_last.view  -->
DJ&nbsp;Adams

<!--  e_spkr/first_last.view  -->
Piers&nbsp;Harding<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1451"><font color="#880000">The Identity Function</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Mark-Jason&nbsp;Dominus

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1458"><font color="#880000">An Improved Perl Beautifier</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Dr. Tim&nbsp;Maher

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1471"><font color="#880000">Pretty Printing Perl</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Simon&nbsp;Cozens

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1459"><font color="#880000">Tangram: Object Persistence in Relational Databases</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jean-Louis&nbsp;Leroy

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1466"><font color="#880000">Alzabo: A Data Modeller and RDBMS-OO Mapper</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Rolsky

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Python</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1325"><font color="#880000">Python Keynote</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Guido&nbsp;van Rossum

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Java</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 11:30am</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1478"><font color="#880000">OpenNMS: Java, Network Management, and Open Source</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Shane&nbsp;O'Donnell

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">11:30am  - 12:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1476"><font color="#880000">Building Java Projects with Amber</font></a></b><br />

<!--  e_spkr/first_last.view  -->
James Duncan&nbsp;Davidson

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>10:45am</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">10:45am  - 12:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1342"><font color="#880000">Greetings and Keynote</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Mark&nbsp;Harrison

<!--  e_spkr/first_last.view  -->
Michael&nbsp;McLennan<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>MySQL</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 3:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1286"><font color="#880000">Row-level Locking with MySQL</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Rich&nbsp;Tucker

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>mod_perl</b></font>
<blockquote>
<font size="-1"><b>Harbor Island I in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1260"><font color="#880000">Real World Performance Tuning</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Ask Bjoern&nbsp;Hansen

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1261"><font color="#880000">Reference Implementation of an Open Micropayment System Using Apache and Perl</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jeffrey W.&nbsp;Baker

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1267"><font color="#880000">mod_perl as an HTTP RPC Daemon</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Matt&nbsp;Sergeant

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1375"><font color="#880000">XML Schema Languages</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Prescod

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1376"><font color="#880000">XML Protocols</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Paul&nbsp;Prescod

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1389"><font color="#880000">AxKit: XML Application Serving with mod_perl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Matt&nbsp;Sergeant

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1390"><font color="#880000">Building Web Applications with Apache XML Suite</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David G.&nbsp;Halsted

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1440"><font color="#880000">Statistical Disambiguation of Word Senses with Perl</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Dan&nbsp;Brian

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1435"><font color="#880000">Automatic Document Categorization</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Ken&nbsp;Williams

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1501"><font color="#880000">Linguana</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Dan&nbsp;Brian

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1499"><font color="#880000">Porting Perl to JVM</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Bradley M.&nbsp;Kuhn

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1502"><font color="#880000">Increasing Perl Use</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Dave&nbsp;Cross

<br />
</font>
</li>
</ul>

</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Python</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1326"><font color="#880000">Python for Massively Multiplayer Virtual Worlds</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jason&nbsp;Asbahr

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1327"><font color="#880000">Writing Python Plug-ins for Adobe After Effects and Photoshop</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Grant J.&nbsp;Munsey

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1328"><font color="#880000">The Artist as Python Programmer</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Gever&nbsp;Tulley

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Java</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1475"><font color="#880000">OpenEJB: The EJB Container System</font></a></b><br />


<!--  e_spkr/first_last.view  -->
David&nbsp;Blevins

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1477"><font color="#880000">Using JBoss.org: A Java 2 Enterprise Edition-based Container</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Andreas&nbsp;Schaefer

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Mozilla</b></font>
<blockquote>
<font size="-1"><b>Harbor Island III in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1277"><font color="#880000">Embedding Mozilla</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Chris&nbsp;Blizzard

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:30pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1281"><font color="#880000">Komodo: Building an Application Based on the Mozilla Framework</font></a></b><br />

<!--  e_spkr/first_last.view  -->
David&nbsp;Ascher

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>1:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">1:45pm  - 2:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1344"><font color="#880000">mod_websh: A Tcl-based Apache Module for Rapid Application Development</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Andrej&nbsp;Vckovski

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">2:15pm  - 2:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1345"><font color="#880000">LDAPtcl: A Tcl Interface to the Lightweight Directory Access Protocol</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Randy&nbsp;Kunkee

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">2:45pm  - 3:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1346"><font color="#880000">KAP: The Kinetic Application Processor</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Mark&nbsp;Harrison

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>MySQL</b></font>
<blockquote>
<font size="-1"><b>Fairbanks C&D in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1287"><font color="#880000">MySQL Replication: Scaling to New Heights</font></a></b><br />


<!--  e_spkr/first_last.view  -->
David&nbsp;Axmark

<!--  e_spkr/first_last.view  -->
Sasha&nbsp;Pachev<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1288"><font color="#880000">MySQL Crash Recovery</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Mike&nbsp;Furgal

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Point Loma A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1377"><font color="#880000">JDOM: How It Works, and How It Opened the Java Process</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Jason&nbsp;Hunter

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1378"><font color="#880000">Data Exchange Using Xbeans Release Two</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Bruce&nbsp;Martin

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>XML/XTech2001</b></font>
<blockquote>
<font size="-1"><b>Coronado A in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1391"><font color="#880000">XML Content Management System Using XSLT, Schematron, and Ant</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Eric&nbsp;van der Vlist

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1392"><font color="#880000">XML-based Application Frameworks Panel</font></a></b><br />
<b>Moderator</b>: 
<!--  e_spkr/first_last.view  -->
Edd&nbsp;Dumbill

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand A in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1469"><font color="#880000">Perl Refactorings or The Good From The Bad and The Ugly</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Michael G.&nbsp;Schwern

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1464"><font color="#880000">Complex Application Engineering with Perl: Stability and Speed</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jason W.&nbsp;May

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand B in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1506"><font color="#880000">Flash in the Pan</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Simon&nbsp;Wistow

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1508"><font color="#880000">Graphing Perl</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Leon&nbsp;Brocard

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Perl 5</b></font>
<blockquote>
<font size="-1"><b>Grand C in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1510"><font color="#880000">Inline</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Brian&nbsp;Ingerson

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1462"><font color="#880000">Orchard: A Simple Alternative to XS</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Ken&nbsp;McLeod

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Python</b></font>
<blockquote>
<font size="-1"><b>Bel Aire North in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1329"><font color="#880000">Designing a Masked Array Facility for Python</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Paul&nbsp;Dubois

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:15pm  - 4:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1330"><font color="#880000">Steering Massively Parallel Simulations Under Python</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Patrick J.&nbsp;Miller

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">4:45pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1752"><font color="#880000">Spheral++, An Open Source Tool for Simulating Hydrodynamical Processes in Astrophysical Problems</font></a></b><br />

<!--  e_spkr/first_last.view  -->
J. Michael&nbsp;Owen

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Java</b></font>
<blockquote>
<font size="-1"><b>Harbor Island II in the East Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:30pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1494"><font color="#880000">The JAWIN Architecture for Java/COM/Win32 Interop</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Stuart&nbsp;Halloway

<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:30pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1474"><font color="#880000">Scarab: Issue Tracking System Built for the Ages</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Jon S.&nbsp;Stevens

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<tr valign="top"><td bgcolor="#cccccc"><b>3:45pm</b></td>
<td bgcolor="#eeeeee"><font size="4"><b>Tcl/Tk</b></font>
<blockquote>
<font size="-1"><b>Fairbanks A&B in the West Tower
:</b></font><br />
&nbsp;&nbsp;&nbsp;<font size="-1">3:45pm  - 4:15pm</font>

<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1347"><font color="#880000">Making the Voice of Tcl Heard: Experiences in Combining Tcl with Voice Software</font></a></b><br />


<!--  e_spkr/first_last.view  -->
Spyros&nbsp;Potamianos

<!--  e_spkr/first_last.view  -->
Manolis&nbsp;Tsangaris<!--  e_spkr/first_last.view  -->
Alexios&nbsp;Zavras<br />
</font>
</li>
</ul>
&nbsp;&nbsp;&nbsp;<font size="-1">4:15pm  - 4:45pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1348"><font color="#880000">Building Mission-critical CAD Applications with Tcl/Tk</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Michael&nbsp;McLennan

<br />

</font>
</li>
</ul>&nbsp;&nbsp;&nbsp;<font size="-1">4:45pm  - 5:15pm</font>
<ul>
<li><font size="-1"><b><a href="http://conferences.oreillynet.com/cs/os2001/view/e_sess/1349"><font color="#880000">Netview: A Tcl/Tk Application for the Visualization of AT&T FR Network</font></a></b><br />

<!--  e_spkr/first_last.view  -->
Ding&nbsp;Chunping

<br />

</font>
</li>
</ul>
</blockquote>
</td>
</tr>
<!--  end q/363  -->



</table>


















</td>
</tr>
<tr>
<td colspan="2" align="center">
<!--  OS2001 footer  -->

<hr size="1" noshade="noshade" />
<font size="1" face="Verdana, Arial, Helvetica">
<b><a href="http://www.oreilly.com/"><font color="#008800">oreilly.com Home</font></a> | 
<a href="http://conferences.oreilly.com/"><font color="#008800">Conferences Home</font></a> |
<a href="http://conferences.oreilly.com/oscon/"><font color="#008800">Open Source Convention Home</font></a><br />
<a href="/cs/os2001/pub/10/register.html"><font color="#008800">Registration</font></a> | 
<a href="/cs/os2001/pub/10/hotel.html"><font color="#008800">Hotels/Travel</font></a> | 
<a href="/cs/os2001/pub/10/tutorials.html"><font color="#008800">Tutorials</font></a> | 
<a href="/cs/os2001/pub/10/sessions.html"><font color="#008800">Sessions</font></a> |
<a href="/cs/os2001/pub/10/speakers.html"><font color="#008800">Speakers</font></a><br />
<a href="/cs/os2001/pub/10/press.html"><font color="#008800">Press</font></a> |
<a href="/cs/os2001/pub/10/maillist.html"><font color="#008800">Mail List</font></a> | 
<a href="/cs/os2001/pub/10/exhibitors.html"><font color="#008800">Exhibitors</font></a> | 
<a href="/cs/os2001/pub/10/sponsors.html"><font color="#008800">Sponsors</font></a><br />
</b>
<br /><img src="/images/dotclear.gif" width="1" height="6" 
alt=" " /><br />
<i>&copy; 2001, O'Reilly &amp; Associates, Inc.<br />
<a href="mailto:[email protected]"><font color="#880000">[email protected]</font></a>
</i>
</font></td>
</tr>
</table>
</td>
</tr>
</table><!-- This section is added by WWWOFFLE -->
     <hr>
<p align=center>
WWWOFFLE - Sun, 22 Apr 2001 21:55:56 CEST (vor 1 Tag) - [<a
href="http://localhost:8080/control/delete-url/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_wednesday.html">L&ouml;schen</a>|
<a href="http://localhost:8080/refresh/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_wednesday.html">Neu&nbsp;abrufen</a>:
<a href="http://localhost:8080/refresh-options/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_wednesday.html">Optionen</a>|
<a href="http://localhost:8080/monitor-options/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_wednesday.html">regelm.&nbsp;abrufen</a>|
<a href="http://localhost:8080/index/url/?http://conferences.oreillynet.com/cs/os2001/pub/w/os2001/sessions_wednesday.html">Index</a>] - WWWOFFLE
</p>
<hr>
<!-- This section is added by WWWOFFLE -->
</body> 

</html>





































































<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted examples/smtpd/tcl_smtpd.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
#! /bin/sh
#
# tcl_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Simple test of the mail server. All incoming messages are displayed to
# stdout.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# 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.
# -------------------------------------------------------------------------
# \
exec tclsh8.3 "$0" ${1+"$@"}

package require smtpd

# In this example application we just print received mail to stdout.
proc deliver {sender recipients data} {
    if {[catch {eval array set saddr [mime::parseaddress $sender]}]} {
        error "invalid sender address \"$sender\""
    }
    set mail "From $saddr(address) [clock format [clock seconds]]"
    append mail "\n" [join $data "\n"]

    foreach rcpt $recipients {
        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
            puts $mail
        }
    }
}

# Deny only hosts from 192.168.1.*
proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
        error "your domain is not allowed to post, Spammers!"
    }
}

# Only reject sender 'denied'
proc validate_sender {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return
}

# Only reject recipients beginning with 'bogus'
proc validate_recipient {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "bogus*" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return
}

# Set up the server
smtpd::configure \
    -deliver            ::deliver \
    -validate_host      ::validate_host \
    -validate_recipient ::validate_recipient \
    -validate_sender    ::validate_sender

# Run the server on the default port 25. For unix change to 
# a high numbered port eg: 2525 or 8025 etc with
# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525

set iface 0.0.0.0
set port 25

if {$argc > 0} {
    set iface [lindex $argv 0]
}
if {$argc > 1} {
    set port [lindex $argv 1]
}

smtpd::start $iface $port

vwait forever

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


























































































































































































Deleted examples/smtpd/tk_smtpd.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
#! /bin/sh
#
# tk_smtpd - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Simple test of the mail server. All incoming messages are displayed in a 
# message dialog.
#
# This example works nicely under Windows or within tkcon.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# 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.
# -------------------------------------------------------------------------
# \
exec wish8.3 "$0" ${1+"$@"}

package require smtpd
package require Tk
wm withdraw .

# Handle new mail by raising a message dialog for each recipient.
proc deliver {sender recipients data} {
    if {[catch {eval array set saddr [mime::parseaddress $sender]}]} {
        error "invalid sender address \"$sender\""
    }
    set mail "From $saddr(address) [clock format [clock seconds]]"
    append mail "\n" [join $data "\n"]

    foreach rcpt $recipients {
        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
            tk_messageBox -title "To: $addr(address)" -message $mail
        }
    }
}

# Accept everyone except those spammers on 192.168.1.* :)
proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
        error "your domain is not allowed to post, Spammers!"
    }
}

# Accept mail from anyone except user 'denied'
proc validate_sender {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return    
}

# Only reject mail for recipients beginning with 'bogus'
proc validate_recipient {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "bogus*" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return
}

# Setup the mail server
smtpd::configure \
    -deliver            ::deliver \
    -validate_host      ::validate_host \
    -validate_recipient ::validate_recipient \
    -validate_sender    ::validate_sender

# Run the server on the default port 25. For unix change to 
# a high numbered port eg: 2525 or 8025 etc with
# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525

set iface 0.0.0.0
set port 25

if {$argc > 0} {
    set iface [lindex $argv 0]
}
if {$argc > 1} {
    set port [lindex $argv 1]
}

smtpd::start $iface $port

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






























































































































































































Deleted examples/smtpd/tk_smtpdMIME.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
#! /bin/sh
#
# tk_smtpdMIME -Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# Simple test of the mail server. All incoming messages are displayed in a 
# message dialog.
#
# This uses the new MIME token passing interface to the smtpd module.
#
# This example works nicely under Windows or within tkcon.
#
# Usage tk_smtpd 0.0.0.0 8025
#    or tk_smtpd 127.0.0.1 2525
#    or tk_smtpd
# to listen to the default port 25 on all tcp/ip interfaces.
#
# -------------------------------------------------------------------------
# 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.
# -------------------------------------------------------------------------
# \
exec wish "$0" ${1+"$@"}

package require smtpd
package require mime
package require Tk
wm withdraw .
set _dlgid 0

# Handle new mail by raising a message dialog for each recipient.
proc deliverMIME {token} {

    set senders [mime::getheader $token From]
    set recipients [mime::getheader $token To]

    if {[catch {eval array set saddr \
                    [mime::parseaddress [lindex $senders 0]]}]} {
        error "invalid sender address \"$senders\""
    }
    set mail "From $saddr(address) [clock format [clock seconds]]\n"
    append mail [mime::buildmessage $token]
    foreach rcpt $recipients {
        if {! [catch {eval array set addr [mime::parseaddress $rcpt]}]} {
            display "To: $addr(address)" $mail
        }
    }
}

proc display {title mail} {
    global _dlgid
    incr _dlgid
    set dlg [toplevel .dlg$_dlgid]
    set frm [frame ${dlg}.f -bd 0]
    set txt [text ${frm}.e -yscrollcommand [list ${frm}.sb set]]
    set scr [scrollbar ${frm}.sb -command [list $txt yview]]
    set but [button ${dlg}.b -text "Dismiss" -command [list destroy $dlg]]
    pack $scr -side right -fill y
    pack $txt -side left -fill both -expand 1
    pack $frm -side top -fill both -expand 1
    pack $but -side bottom
    wm title $dlg $title
    $txt insert 0.0 $mail
}

# Accept everyone except those spammers on 192.168.1.* :)
proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
        error "your domain is not allowed to post, Spammers!"
    }
}

# Accept mail from anyone except user 'denied'
proc validate_sender {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return    
}

# Only reject mail for recipients beginning with 'bogus'
proc validate_recipient {address} {
    eval array set addr [mime::parseaddress $address]
    if {[string match "bogus*" $addr(local)]} {
        error "mailbox $addr(local) denied"
    }
    return
}

# Setup the mail server
smtpd::configure \
    -deliverMIME        ::deliverMIME \
    -validate_host      ::validate_host \
    -validate_recipient ::validate_recipient \
    -validate_sender    ::validate_sender

# Run the server on the default port 25. For unix change to 
# a high numbered port eg: 2525 or 8025 etc with
# smtpd::start 127.0.0.1 8025 or smtpd::start 0.0.0.0 2525

set iface 0.0.0.0
set port 25

if {$tcl_interactive } {

    puts {you'll want to issue 'smtpd::start' to begin}

} else {

    if {$argc > 0} {
        set iface [lindex $argv 0]
    }
    if {$argc > 1} {
        set port [lindex $argv 1]
    }
        
    smtpd::start $iface $port
}

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




























































































































































































































































Deleted examples/struct/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
This directory contains some examples regarding the usage of struct
funtionality. For example a small diff tool based on

	struct::list longestCommonSubsequence.

=======================================================================

Example operations:

	tclsh ./diff2.tcl diff.tcl diff2.tcl

		Differences between the diff-tools in pseudo-'patch' form.

	tclsh ./diff.tcl diff.tcl diff2.tcl

		Differences between the diff-tools side by side.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted examples/struct/diff.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
# MAIN PROGRAM
#
# Usage:
#       diff.tcl file1 file2
#
# Output:
#       Puts out a list of lines consisting of:
#               n1<TAB>n2<TAB>line
#
#       where n1 is a line number in the first file, and n2 is a line number in the second file.
#       The line is the text of the line.  If a line appears in the first file but not the second,
#       n2 is omitted, and conversely, if it appears in the second file but not the first, n1
#       is omitted.

lappend auto_path \
	[file join \
	[file dirname [file dirname [file dirname [file dirname [file join [pwd] [info script]]]]]] \
	modules struct]
package require struct

# Open the files and read the lines into memory

set                      f1 [open [lindex $argv 0] r]
set lines1 [split [read $f1] \n]
close                   $f1

set                      f2 [open [lindex $argv 1] r]
set lines2 [split [read $f2] \n]
close                   $f2

set i 0
set j 0

::struct::list assign [::struct::list longestCommonSubsequence $lines1 $lines2] x1 x2

foreach p $x1 q $x2 {
    while { $i < $p } {
	set l [lindex $lines1 $i]
	puts "[incr i]\t\t$l"
    }
    while { $j < $q } {
	set m [lindex $lines2 $j]
	puts "\t[incr j]\t$m"
    }
    set l [lindex $lines1 $i]
    puts "[incr i]\t[incr j]\t$l"
}
while { $i < [llength $lines1] } {
    set l [lindex $lines1 $i]
    puts "[incr i]\t\t$l"
}
while { $j < [llength $lines2] } {
    set m [lindex $lines2 $j]
    puts "\t[incr j]\t$m"
}

exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































Deleted examples/struct/diff2.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
# MAIN PROGRAM
#
# Usage:
#       diff2.tcl file1 file2
#
# Output:
#       Puts out a list of lines describing the changes from file1 to file2
#	in a format similar to 'patch'. It not the same as patch, but could
#	be modified to be exactly the same.

lappend auto_path \
	[file join \
	[file dirname [file dirname [file dirname [file dirname [file join [pwd] [info script]]]]]] \
	modules struct]
package require struct

# Open the files and read the lines into memory

set                      f1 [open [lindex $argv 0] r]
set lines1 [split [read $f1] \n]
close                   $f1

set                      f2 [open [lindex $argv 1] r]
set lines2 [split [read $f2] \n]
close                   $f2

set i 0
set j 0

::struct::list assign [::struct::list longestCommonSubsequence $lines1 $lines2] x1 x2

set chunks 0
foreach chunk [::struct::list lcsInvert2 $x1 $x2 [llength $lines1] [llength $lines2]] {
    set chunks 1
    puts ===========================================
    puts $chunk
    puts -------------------------------------------

    ::struct::list assign [lindex $chunk 1] b1 e1
    ::struct::list assign [lindex $chunk 2] b2 e2

    switch -exact -- [lindex $chunk 0] {
	changed {
	    puts "< [join [lrange $lines1 $b1 $e1] "\n< "]"
	    puts "---"
	    puts "> [join [lrange $lines2 $b2 $e2] "\n> "]"
	}
	added   {
	    puts "> [join [lrange $lines2 $b2 $e2] "\n> "]"
	}
	deleted {
	    puts "< [join [lrange $lines1 $b1 $e1] "\n< "]"
	}
    }
}
if {$chunks} {
    puts ===========================================
}

exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































Deleted installer.tcl.

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

# --------------------------------------------------------------
# Installer for Tcllib

set distribution   [file dirname [info script]]
lappend auto_path  [file join $distribution modules]

source [file join $distribution tcllib_version.tcl] ; # Get version information.

# --------------------------------------------------------------
# Low-level commands of the installation engine.

proc gen_main_index {outdir package version} {
    global config

    log "\nGenerating [file join $outdir pkgIndex.tcl]"
    if {$config(dry)} {return}

    set   index [open [file join $outdir pkgIndex.tcl] w]

    puts $index "# Tcl package index file, version 1.1"
    puts $index "# Do NOT edit by hand.  Let $package install generate this file."
    puts $index "# Generated by $package installer for version $version"

    puts $index {
# All tcllib packages need Tcl 8 (use [namespace])
if {![package vsatisfies [package provide Tcl] 8]} {return}

# Extend the auto_path to make tcllib packages available
if {[lsearch -exact $::auto_path $dir] == -1} {
    lappend ::auto_path $dir
}

# For Tcl 8.3.1 and later, that's all we need
if {[package vsatisfies [package provide Tcl] 8.4]} {return}
if {(0 == [catch {
    package vcompare [info patchlevel] [info patchlevel]
}]) && (
    [package vcompare [info patchlevel] 8.3.1] >= 0
)} {return}

# For older Tcl releases, here are equivalent contents
# of the pkgIndex.tcl files of all the modules

if {![package vsatisfies [package provide Tcl] 8.0]} {return}
}
    puts $index ""
    puts $index "set maindir \$dir"

    foreach pi [lsort [glob -nocomplain [file join $outdir * pkgIndex.tcl]]] {
	set subdir [file tail [file dirname $pi]]
	puts $index "set dir \[file join \$maindir [list $subdir]\] ;\t source \[file join \$dir pkgIndex.tcl\]"
    }

    puts  $index "unset maindir"
    puts  $index ""
    close $index
    return
}

proc xcopy {src dest recurse {pattern *}} {
    run file mkdir $dest
    foreach file [glob [file join $src $pattern]] {
        set base [file tail $file]
	set sub  [file join $dest $base]

	if {0 == [string compare CVS $base]} {continue}

        if {[file isdirectory $file]} then {
	    if {$recurse} {
		run file mkdir  $sub
		xcopy $file $sub $recurse $pattern
	    }
        } else {
            run file copy -force $file $sub
        }
    }
}

# --------------------------------------------------------------
# Module specific commands

proc _null {args} {}

proc _tcl {module libdir} {
    global distribution
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    0 *.tcl
    return
}

proc _doc {module libdir} {
    global distribution

    _tcl $module $libdir
    xcopy \
	    [file join $distribution modules $module mpformats] \
	    [file join $libdir $module mpformats] \
	    1
    return
}

proc _tex {module libdir} {
    global distribution

    _tcl $module $libdir
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    0 *.tex
    return
}

proc _tci {module libdir} {
    global distribution

    _tcl $module $libdir
    file copy -force [file join $distribution modules $module tclIndex] \
	    [file join $libdir $module]
    return
}

proc get_input {f} {return [read [set if [open $f r]]][close $if]}
proc write_out {f text} {
    global config
    if {$config(dry)} {log "Generate $f" ; return}
    puts -nonewline [set of [open $f w]] $text
    close $of
}

proc _man {module format ext docdir} {
    global distribution argv argc argv0 config

    package require doctools
    ::doctools::new dt -format $format -module $module

    foreach f [glob -nocomplain [file join $distribution modules $module *.man]] {

	set out [file join $docdir [file rootname [file tail $f]]].$ext

	log "Generating $out"
	if {$config(dry)} {continue}

	dt configure -file $f
	file mkdir [file dirname $out]

	set data [dt format [get_input $f]]
	switch -exact -- $format {
	    nroff {
		set data [string map \
			[list \
			{.so man.macros} \
			$config(man.macros)] \
			$data]
	    }
	    html {}
	}
	write_out $out $data

	set warnings [dt warnings]
	if {[llength $warnings] > 0} {
	    log [join $warnings \n]
	}
    }
    dt destroy
    return
}

proc _exa {module exadir} {
    global distribution
    xcopy \
	    [file join $distribution examples $module] \
	    [file join $exadir $module] \
	    1
    return
}

# --------------------------------------------------------------
# List of modules to install (and definitions guiding the process)

set     modules [list]
array set guide {}
foreach {m pkg doc exa} {
    base64	_tcl  _man  _null
    calendar	 _tci _man  _null
    cmdline	_tcl  _man  _null
    comm	_tcl  _man  _null
    control	 _tci _man  _null
    counter	_tcl  _man  _null
    crc		_tcl  _man  _null
    csv		_tcl  _man _exa
    des		_tcl  _man  _null
    dns		_tcl  _man _exa
    doctools	 _doc _man _exa
    exif	_tcl  _man  _null
    fileutil	_tcl  _man  _null
    ftp		_tcl  _man _exa
    ftpd	_tcl  _man _exa
    html	_tcl  _man  _null
    htmlparse	_tcl  _man  _null
    irc		_tcl  _man _exa
    javascript	_tcl  _man  _null
    log		_tcl  _man  _null
    math	 _tci _man  _null
    md5		_tcl  _man  _null
    md4		_tcl  _man  _null
    mime	_tcl  _man _exa
    ncgi	_tcl  _man  _null
    nntp	_tcl  _man _exa
    ntp		_tcl  _man _exa
    pop3	_tcl  _man  _null
    pop3d	_tcl  _man  _null
    profiler	_tcl  _man  _null
    report	_tcl  _man  _null
    sha1	_tcl  _man  _null
    smtpd	_tcl  _man _exa
    soundex	_tcl  _man  _null
    stooop	_tcl  _man  _null
    struct	_tcl  _man _exa
    textutil	 _tex _man  _null
    uri		_tcl  _man  _null
} {
    lappend modules $m
    set guide($m,pkg) $pkg
    set guide($m,doc) $doc
    set guide($m,exa) $exa
}

# --------------------------------------------------------------
# Use configuration to perform installation

proc clear {}     {global message ; set     message ""}
proc msg   {text} {global message ; append  message $text \n ; return}
proc get   {}     {global message ; return $message}

proc log {text} {
    global config
    if {!$config(gui)} {puts stdout $text ; flush stdout ; return}
    .l.t insert end $text\n
    .l.t see    end
    update
    return
}
proc log* {text} {
    global config
    if {!$config(gui)} {puts -nonewline stdout $text ; flush stdout ; return}
    .l.t insert end $text
    .l.t see    end
    update
    return
}

proc run {args} {
    global config
    if {$config(dry)} {
	log [join $args]
	return
    }
    eval $args

    log* .
    return
}

proc xinstall {type args} {
    global modules guide
    foreach m $modules {
	eval $guide($m,$type) $m $args
    }
    return
}

proc doinstall {} {
    global config tcllib_version distribution tcllib_name

    if {$config(pkg)}       {
	xinstall   pkg $config(pkg,path)
	gen_main_index $config(pkg,path) $tcllib_name $tcllib_version
    }
    if {$config(doc,nroff)} {
	set config(man.macros) [string trim [get_input [file join $distribution man.macros]]]
	xinstall doc nroff n    $config(doc,nroff,path)
    }
    if {$config(doc,html)}  {xinstall doc html  html $config(doc,html,path)}
    if {$config(exa)}       {xinstall exa $config(exa,path)}
    log ""
    return
}


# --------------------------------------------------------------
# Initialize configuration.

array set config {
    pkg 1 pkg,path {}
    doc,nroff 0 doc,nroff,path {}
    doc,html  0 doc,html,path  {}
    exa 1 exa,path {}
    dry 0 wait 1 valid 1
    gui 0 no-gui 0
}

# --------------------------------------------------------------
# Determine a default configuration, if possible

proc defaults {} {
    global tcl_platform config tcllib_version tcllib_name distribution

    if {[string compare $distribution [info nameofexecutable]] == 0} {
	# Starpack. No defaults for location.
    } else {
	# Starkit, or unwrapped. Derive defaults location from the
	# location of the executable running the installer, or the
	# location of its library.

	# For a starkit [info library] is inside the running
	# tclkit. Detect this and derive the lcoation from the
	# location of the executable itself for that case.

	if {[string match [info nameofexecutable]* [info library]]} {
	    # Starkit
	    set libdir [file join [file dirname [file dirname [info nameofexecutable]]] lib]
	} else {
	    # Unwrapped.
	    if {[catch {set libdir [lindex $::tcl_pkgPath end]}]} {
		set libdir [file dirname [info library]]
	    }
	}

	set basedir [file dirname $libdir]
	set bindir  [file join $basedir bin]

	if {[string compare $tcl_platform(platform) windows] == 0} {
	    set mandir  {}
	    set htmldir [file join $basedir tcllib_doc]
	} else {
	    set mandir  [file join $basedir man mann]
	    set htmldir [file join $libdir  tcllib${tcllib_version} tcllib_doc]
	}

	set config(pkg,path)       [file join $libdir ${tcllib_name}${tcllib_version}]
	set config(doc,nroff,path) $mandir
	set config(doc,html,path)  $htmldir
	set config(exa,path)       [file join $bindir tcllib_examples${tcllib_version}]
    }

    if {[string compare $tcl_platform(platform) windows] == 0} {
	set config(doc,nroff) 0
	set config(doc,html)  1
    } else {
	set config(doc,nroff) 1
	set config(doc,html)  0
    }
    return
}

# --------------------------------------------------------------
# Show configuration on stdout.

proc showpath {prefix key} {
    global config

    if {$config($key)} {
	if {[string length $config($key,path)] == 0} {
	    puts "${prefix}Empty path, invalid."
	    set config(valid) 0
	    msg "Invalid path: [string trim $prefix " 	:"]"
	} else {
	    puts "${prefix}$config($key,path)"
	}
    } else {
	puts "${prefix}Not installed."
    }
}

proc showconfiguration {} {
    global config tcllib_version

    puts "Installing Tcllib $tcllib_version"
    if {$config(dry)} {
	puts "\tDry run, simulation, no actual activity."
	puts ""
    }

    puts "You have chosen the following configuration ..."
    puts ""

    showpath "Packages:      " pkg
    showpath "Examples:      " exa

    if {$config(doc,nroff) || $config(doc,html)} {
	puts "Documentation:"
	puts ""

	showpath "\tNROFF:  " doc,nroff
	showpath "\tHTML:   " doc,html
    } else {
	puts "Documentation: Not installed."
    }
    puts ""
    return
}

# --------------------------------------------------------------
# Setup the installer user interface

proc browse {label key} {
    global config

    set  initial $config($key)
    if {$initial == {}} {set initial [pwd]}

    set dir [tk_chooseDirectory \
	    -title    "Select directory for $label" \
	    -parent    . \
	    -initialdir $initial \
	    ]

    if {$dir == {}} {return} ; # Cancellation

    set config($key)  $dir
    return
}

proc setupgui {} {
    global config tcllib_name tcllib_version
    set config(gui) 1

    wm withdraw .
    wm title . "Installing $tcllib_name $tcllib_version"

    foreach {w type cspan col row opts} {
	.pkg checkbutton 1 0 0 {-anchor w -text {Packages:}    -variable config(pkg)}
	.dnr checkbutton 1 0 1 {-anchor w -text {Doc. Nroff:}  -variable config(doc,nroff)}
	.dht checkbutton 1 0 2 {-anchor w -text {Doc. HTML:}   -variable config(doc,html)}
	.exa checkbutton 1 0 3 {-anchor w -text {Examples:}    -variable config(exa)}

	.spa frame  3 0 4 {-bg black -height 2}

	.dry checkbutton 2 0 6 {-anchor w -text {Simulate installation}   -variable config(dry)}

	.pkge entry 1 1 0 {-width 40 -textvariable config(pkg,path)}
	.dnre entry 1 1 1 {-width 40 -textvariable config(doc,nroff,path)}
	.dhte entry 1 1 2 {-width 40 -textvariable config(doc,html,path)}
	.exae entry 1 1 3 {-width 40 -textvariable config(exa,path)}

	.pkgb button 1 2 0 {-text ... -command {browse Packages pkg,path}}
	.dnrb button 1 2 1 {-text ... -command {browse Nroff    doc,nroff,path}}
	.dhtb button 1 2 2 {-text ... -command {browse HTML     doc,html,path}}
	.exab button 1 2 3 {-text ... -command {browse Examples exa,path}}

	.sep  frame  3 0 7 {-bg black -height 2}

	.run  button 1 0 8 {-text {Install} -command {set ::run 1}}
	.can  button 1 1 8 {-text {Cancel}  -command {exit}}
    } {
	eval [list $type $w] $opts
	grid $w -column $col -row $row -sticky ew -columnspan $cspan
	grid rowconfigure . $row -weight 0
    }

    grid .can -sticky e

    grid rowconfigure    . 9 -weight 1
    grid columnconfigure . 0 -weight 0
    grid columnconfigure . 1 -weight 1

    wm deiconify .
    return
}

proc handlegui {} {
    setupgui
    vwait ::run
    showconfiguration
    validate

    toplevel .l
    wm title .l "Install log"
    text     .l.t -width 70 -height 25 -relief sunken -bd 2
    pack     .l.t -expand 1 -fill both

    return
}

# --------------------------------------------------------------
# Handle a command line

proc handlecmdline {} {
    showconfiguration
    validate
    wait
    return
}

proc processargs {} {
    global argv argv0 config

    while {[llength $argv] > 0} {
	switch -exact -- [lindex $argv 0] {
	    -no-wait     {set config(wait) 0}
	    -no-gui      {set config(no-gui) 1}
	    -simulate    -
	    -dry-run     {set config(dry) 1}
	    -html        {set config(doc,html) 1}
	    -nroff       {set config(doc,nroff) 1}
	    -examples    {set config(exa) 1}
	    -pkgs        {set config(pkg) 1}
	    -no-html     {set config(doc,html) 0}
	    -no-nroff    {set config(doc,nroff) 0}
	    -no-examples {set config(exa) 0}
	    -no-pkgs     {set config(pkg) 0}
	    -pkg-path {
		set config(pkg) 1
		set config(pkg,path) [lindex $argv 1]
		set argv             [lrange $argv 1 end]
	    }
	    -nroff-path {
		set config(doc,nroff) 1
		set config(doc,nroff,path) [lindex $argv 1]
		set argv                   [lrange $argv 1 end]
	    }
	    -html-path {
		set config(doc,html) 1
		set config(doc,html,path) [lindex $argv 1]
		set argv                  [lrange $argv 1 end]
	    }
	    -example-path {
		set config(exa) 1
		set config(exa,path) [lindex $argv 1]
		set argv             [lrange $argv 1 end]
	    }
	    -help   -
	    default {
		puts stderr "usage: $argv0 ?-dry-run/-simulate? ?-no-wait? ?-no-gui? ?-html|-no-html? ?-nroff|-no-nroff? ?-examples|-no-examples? ?-pkgs|-no-pkgs? ?-pkg-path path? ?-nroff-path path? ?-html-path path? ?-example-path path?"
		exit 1
	    }
	}
	set argv [lrange $argv 1 end]
    }
    return
}

proc validate {} {
   global config

    if {$config(valid)} {return}

    puts "Invalid configuration detected, aborting."
    puts ""
    puts "Please use the option -help to get more information"
    puts ""

    if {$config(gui)} {
	tk_messageBox \
		-icon error -type ok \
		-default ok \
		-title "Illegal configuration" \
		-parent . -message [get]
	clear
    }
    exit 1
}

proc wait {} {
   global config

    if {!$config(wait)} {return}

    puts -nonewline stdout "Is the chosen configuration ok ? y/N: "
    flush stdout
    set answer [gets stdin]
    if {($answer == {}) || [string match "\[Nn\]*" $answer]} {
	puts stdout "\tNo. Aborting."
	puts stdout ""
	exit 0
    }
    return
}

# --------------------------------------------------------------
# Main code

proc main {} {
    global config

    defaults
    processargs
    if {$config(no-gui) || [catch {package require Tk}]} {
	handlecmdline
    } else {
	handlegui
    }
    doinstall
    return
}

# --------------------------------------------------------------
main
exit 0
# --------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted license.terms.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
This software is copyrighted by Ajuba Solutions and other parties.
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. 
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































Deleted main.tcl.

1
2
3
4
# -*- tcl -*-
# Entrypoint for strkit and -pack based distributions

source [file join [file dirname [info script]] installer.tcl]
<
<
<
<








Deleted man.macros.

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
























































































































































































































































































































































































































































































Changes to modules/base64/ChangeLog.













1
2
3
4
5
6
7












2003-04-21  Andreas Kupries  <[email protected]>

	* uuencode.test: Added code to suppress output from the log
	  package during the test.

2003-04-11  Andreas Kupries  <[email protected]>

>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
2003-04-22  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* uuencode.test: Added code to suppress output from the log
	  package during the test.

2003-04-11  Andreas Kupries  <[email protected]>

Changes to modules/base64/uuencode.tcl.

1
2
3
4
5
6
7
8
9
10
11




12
13

14
15
16
17
18
19
20
21
22
# uuencode - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.
# -------------------------------------------------------------------------
# @(#)$Id: uuencode.tcl,v 1.8 2003/03/24 23:21:22 andreas_kupries Exp $

package require Tcl 8.2;                # tcl minimum version




package require log;                    # tcllib 1.0


namespace eval ::uuencode {
    variable version 1.0.2

    namespace export encode decode uuencode uudecode
}

proc ::uuencode::Enc {c} {
    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
}








|


>
>
>
>
|
|
>

|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
# uuencode - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.
# -------------------------------------------------------------------------
# @(#)$Id: uuencode.tcl,v 1.8.2.2 2003/05/13 01:04:27 patthoyts Exp $

package require Tcl 8.2;                # tcl minimum version
catch {package require log};            # tcllib 1.0

# Try and get some compiled helper package.
if {[catch {package require tcllibc}]} {
    catch {package require Trf}
}

namespace eval ::uuencode {
    variable version 1.1.0

    namespace export encode decode uuencode uudecode
}

proc ::uuencode::Enc {c} {
    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
}
31
32
33
34
35
36
37

38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
































































































54
55
56
57
58
59
60
        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
}

































































































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

# Description:
#  Permit more tolerant decoding of invalid input strings by padding to
#  a multiple of 4 bytes with nulls.
# Result:







>
















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
        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_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            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);
            }
            
            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_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            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) );
            }
            
            return TCL_OK;
        }
    }
}

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

# Description:
#  Permit more tolerant decoding of invalid input strings by padding to
#  a multiple of 4 bytes with nulls.
# Result:
69
70
71
72
73
74
75

76
77
78
79
80
81
82
83
84
85




86
87
88
89
90
91
92
    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 {[catch {package require Trf 2.0}]} {
    interp alias {} ::uuencode::encode {} ::uuencode::Encode
    interp alias {} ::uuencode::decode {} ::uuencode::Decode
} else {
    proc ::uuencode::encode {s} {
        return [::uuencode -mode encode -- $s]
    }
    proc ::uuencode::decode {s} {
        return [::uuencode -mode decode -- [pad $s]]
    }




}

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

proc ::uuencode::uuencode {args} {
    array set opts {mode 0644 filename {} name {}}
    while {[string match -* [lindex $args 0]]} {







>
|
|
|
|






>
>
>
>







171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
    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 command ::uuencode::CDecode] != {}} {    
    # tcllib criticl 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 {}}
    while {[string match -* [lindex $args 0]]} {

Changes to modules/base64/uuencode.test.

1
2
3
4
5
6
7
8
9
10



11
12
13
14
15



16






















17
18
19
20
21
22
23
# uuencode.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.6 2003/04/21 20:16:53 andreas_kupries Exp $




if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}




package require uuencode






















package require log
log::lvSuppress notice

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

test uuencode-1.0 {encode string} {
    catch {::uuencode::encode ABC} result








|

>
>
>





>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
# uuencode.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.6.2.1 2003/05/13 01:04:27 patthoyts Exp $

# -------------------------------------------------------------------------
# Initialize the test package
#
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget uuencode
catch {namespace delete ::uuencode}
if {[catch {source [file join [file dirname [info script]] uuencode.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

if {[info command ::uuencode::CEncode] != {}} {
    puts "- uuencode [package provide uuencode] (critcl based)"
} elseif {[package provide Trf] != {}} {
    puts "- uuencode [package provide uuencode] (Trf based)"
} else {
    puts "- uuencode [package provide uuencode] (pure tcl)"
}

package require log
log::lvSuppress notice

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

test uuencode-1.0 {encode string} {
    catch {::uuencode::encode ABC} result
37
38
39
40
41
42
43

44
45
46
47
48
49
50
51
52
53
54
55
56
57
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 {[catch {package present Trf}]} {

    set testdata {begin 644 data.dat
75&AE(&-A="!S870@;VX@=&AE(&UA="X`
`
end}
} else {
    puts "Trf present"

    set testdata {begin 644 data.dat
75&AE(&-A="!S870@;VX@=&AE(&UA="X~
`
end}
}

test uuencode-1.4 {uuencode string} {







>





<
|







65
66
67
68
69
70
71
72
73
74
75
76
77

78
79
80
81
82
83
84
85
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 {[catch {package present Trf}]} {
    # critcl / pure tcl based
    set testdata {begin 644 data.dat
75&AE(&-A="!S870@;VX@=&AE(&UA="X`
`
end}
} else {

    # Trf based
    set testdata {begin 644 data.dat
75&AE(&-A="!S870@;VX@=&AE(&UA="X~
`
end}
}

test uuencode-1.4 {uuencode string} {
95
96
97
98
99
100
101












102
103
104
105
106
107
108
109
110
111
    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."]]













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

file delete -force uuencode.test.data    
::tcltest::cleanupTests

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







>
>
>
>
>
>
>
>
>
>
>
>










123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
    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]
}

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

file delete -force uuencode.test.data    
::tcltest::cleanupTests

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

Changes to modules/base64/yencode.tcl.

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54







































































































55
56
57
58
59
60
61
# yencode.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.
# -------------------------------------------------------------------------
# @(#)$Id: yencode.tcl,v 1.3 2003/01/26 00:38:28 patthoyts Exp $

package require Tcl 8.2;                # tcl minimum version
package require crc32;                  # tcllib 1.1


namespace eval ::yencode {
    variable version 1.0.1
    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 + 42) % 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 - 42) % 256}]
            set esc 0
        }
        append r [format %c $v]
    }
    return $r
}








































































































# -------------------------------------------------------------------------
# Description:
#  Pop the nth element off a list. Used in options processing.
#
proc ::yencode::Pop {varname {nth 0}} {
    upvar $varname args








|


|
>








|














|


















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







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

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 {
    variable version 1.0.1
    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 + 42) % 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 - 42) % 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_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            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 + 42) % 256;
                }
                *r++ = v;
            }

            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_GetObjResult(interp);
            if (Tcl_IsShared(resultPtr)) {
                resultPtr = Tcl_DuplicateObj(resultPtr);
                Tcl_SetObjResult(interp, resultPtr);
            }
            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 - 42) % 256;
                    esc = 0;
                }
                *r++ = v;
                rlen++;
            }
            Tcl_SetByteArrayLength(resultPtr, rlen);

            return TCL_OK;
        }
    }
}

if {[info command ::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

Changes to modules/base64/yencode.test.

1
2
3
4
5
6
7
8
9
10



11
12
13
14
15



16




















17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


































37
38
39
40
41
42
43
44
45
46
47
48
49
# yencode.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.3 2003/01/26 00:38:28 patthoyts Exp $




if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}




package require yencode





















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 [file join $::tcltest::testsDirectory 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 match $dec $chk
} {0}
    



































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

catch {
    unset datafile
    rename ::yencode::loaddata {}
}
::tcltest::cleanupTests

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








|

>
>
>





>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




















>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>













1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
# yencode.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.3.2.1 2003/05/13 01:04:27 patthoyts Exp $

# -------------------------------------------------------------------------
# Initialize the test package
#
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget yencode
catch {namespace delete ::yencode}
if {[catch {source [file join [file dirname [info script]] yencode.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

if {[info command ::yencode::CEncode] != {}} {
    puts "- yencode [package provide yencode] (critcl based)"
} else {
    puts "- yencode [package provide yencode] (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 [file join $::tcltest::testsDirectory 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 match $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" {=*=4=7}
} {
    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 {[info command ::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" {=*=4=7}
    } {
        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 {}
}
::tcltest::cleanupTests

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

Deleted modules/calendar/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
2003-04-11  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl: 
	* gregorian.tcl: Fixed bug #614591. Set version of the package to
	  0.2

2002-02-14  Andreas Kupries  <[email protected]>

	* gregorian.tcl: Frink run.

2002-01-14  Kevin Kenny  <[email protected]>

	* 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  <[email protected]>

	* 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).
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted modules/calendar/calendar.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
#----------------------------------------------------------------------
#
# calendar.tcl --
#
#	This file is the main 'package provide' script for the
#   	'calendar' package.  The package provides various commands for
#	manipulating dates and times.
#
# RCS:$(@) $Id: calendar.tcl,v 1.2 2003/04/11 19:10:42 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::calendar {

    variable version 0.2

    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]] $version
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Deleted modules/calendar/gregorian.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
#----------------------------------------------------------------------
#
# 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.4 2003/04/11 19:10:42 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

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/calendar/gregorian.test.

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

package forget calendar
catch { namespace delete calendar }

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.
source [file join [file dirname [info script]] gregorian.tcl]

package require tcltest
namespace import -force tcltest::test ::tcltest::cleanupTests


#----------------------------------------------------------------------
#
# TEST CASES
#
#----------------------------------------------------------------------

# Unix epoch

array set gregUnixEpoch {
	ERA CE 
	YEAR 1970 
	MONTH 1 
	DAY_OF_MONTH 1
}
set unixEpoch [calendar::GregorianCalendar::EYMDToJulianDay gregUnixEpoch]

# 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
} {}

cleanupTests

# Local Variables:
# mode:tcl
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/calendar/pkgIndex.tcl.

1
2
if { ! [package vsatisfies [package provide Tcl] 8.2] } {return}
package ifneeded calendar 0.2 [list source [file join $dir calendar.tcl]]
<
<




Deleted modules/calendar/tclIndex.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
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]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted modules/cmdline/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
2003-04-11  Andreas Kupries  <[email protected]>

	* typedCmdline.tcl: Fixed bug #614591. See also last entry, this
	  file was forgotten.

2003-04-10  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* cmdline.tcl (cmdline::getfiles): Use string map instead of
	regsub.

2002-08-30  Andreas Kupries  <[email protected]>

	* typeCmdline.tcl: Updated 'info exist' to 'info exists'.

2002-04-24  Andreas Kupries <[email protected]>

	* Applied patch #540313 on behalf of Melissa Chawla
	  <[email protected]> and Don Porter
	  <[email protected]>.

	  * 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 independant locations in your application where
	    commandline arguments are parsed.  I bumped the package
	    version to 1.2.

	* cmdline.man: Updated documentation.

2002-04-14  Andreas Kupries <[email protected]>

	* cmdline.man: Added doctools manpage.

2001-10-16  Andreas Kupries <[email protected]>

	* cmdline.n:
	* cmdline.tcl:
	* pkgIndex.tcl: Version up to 1.1.1

2001-10-12  Andreas Kupries <[email protected]>

	* cmdline.tcl: Corrected the inline documentation to reflect what
	  is actually happening. Problem reported by Glenn Jackman
	  <[email protected]>, Item #46650.

2001-07-31  Andreas Kupries <[email protected]>

	* cmdline.n: Added manpage [446584].

2001-06-21  Andreas Kupries <[email protected]>

	* typedCmdline.tcl:
	* cmdline.tcl: Fixed dubious code reported by frink.

2000-05-03  Brent Welch <[email protected]>

	* 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 vfixes the -verbose command
	line bug in connect.

2000-04-07  Eric Melski  <[email protected]>

	* typedCmdline.test: Changed sourcing bits at start of file to
	work better with updated file dependancies.

	* 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  <[email protected]>

	* 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  <[email protected]>

	* cmdline.test: Adapted tests to work with tcllib test framework.

1999-10-29  Scott Stanton  <[email protected]>

	* cmdline.tcl: Fixed bug where options that contained regexp
	special characters would cause an error.  Cleaned up lots of
	messy code.  Added test suite.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































Deleted modules/cmdline/cmdline.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
[manpage_begin cmdline n 1.2.1]
[moddesc   {command line / option processing}]
[titledesc {Procedures to process command lines and options.}]
[require Tcl 8.2]
[require cmdline [opt 1.2.1]]
[description]

This package provides commands to parse command lines and options.

[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 or 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.

[nl]

[arg argvVar] contains the name of the argv list to process. If
options are found the arg list is modified and the processed arguments
are removed from the start of the list.

[nl]

[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.  Otherwise
the option is a boolean that is set to 1 if present.

[nl]

[arg optVar] refers to the variable the command will store the found
option into (without the leading '-' and without the .arg extension).

[nl]

[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:".

[nl]

[arg optlist] contains a list of lists where each element specifies an
option in the form: [arg flag] [arg default] [arg comment].

[nl]

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.


[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).

[nl]

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 ".bin" extensions that the
pro-apps use because they must be wrapped by a shell script.

[list_end]

[keywords {cmdline processing}]
[manpage_end]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































Deleted modules/cmdline/cmdline.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
'\" 
'\" Copyright (c) 2001 by Andreas Kupries <[email protected]>
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: cmdline.n,v 1.3 2001/10/17 17:27:25 andreas_kupries Exp $
'\" 
.so man.macros
.TH cmdline n 1.0 Cmdline "command line / option processing"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
::cmdline \- Procedures to process command lines and options.
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require cmdline ?1.1.1?\fR
.sp
\fB::cmdline::getopt\fR \fIargvVar optstring optVar valVar\fR
.sp
\fB::cmdline::getoptions\fR \fIarglistVar optlist\fR ?\fIusage\fR?
.sp
\fB::cmdline::usage\fR \fIoptlist\fR ?\fIusage\fR?
.sp
\fB::cmdline::getfiles\fR \fIpatterns quiet\fR
.sp
\fB::cmdline::getArgv0\fR
.BE
.SH DESCRIPTION
.PP
This package provides commands to parse command lines and options.
.TP
\fB::cmdline::getopt\fR \fIargvVar optstring optVar valVar\fR
This command works in a fashion like the standard C based \fBgetopt\fR
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
procede. The command returns 1 if an option was found, 0 if no more
options were found, and -1 if an error occurred.
.sp
\fIargvVar\fR contains the name of the argv list to process. If
options are found the arg list is modified and the processed arguments
are removed from the start of the list.
.sp
\fIoptstring\fR 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.  Otherwise
the option is a boolean that is set to 1 if present.
.sp
\fIoptVar\fR refers to the variable the command will store the found
option into (without the leading '-' and without the .arg extension).
.sp
\fIvalVar\fR 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.
.TP
\fB::cmdline::getoptions\fR \fIarglistVar optlist\fR ?\fIusage\fR?
Processes the set of command line options found in the list variable
named by \fIarglistVar\fR 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
\fIusage\fR-argument contains a string to include in front of the
generated message. If not present it defaults to "options:".
.sp
\fIoptlist\fR contains a list of lists where each element specifies an
option in the form: \fIflag default comment\fR
.sp
If \fIflag\fR 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 \fIflag\fR ends in ".secret", it will not be
displayed in the usage.
.TP
\fB::cmdline::usage\fR \fIoptlist\fR ?\fIusage\fR?
Generates and returns an error message that lists the allowed
flags. \fIoptlist\fR is defined as for
\fB::cmdline::getoptions\fI. The optional \fIusage\fR-argument
contains a string to include in front of the generated message. If not
present it defaults to "options:".
.TP
\fB::cmdline::getfiles\fR \fIpatterns quiet\fR
Given a list of file \fIpatterns\fR 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 \fIquiet\fR to
true).
.sp
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.
.TP
\fB::cmdline::getArgv0\fR
This command returns the "sanitized" version of \fIargv0\fR.  It will
strip off the leading path and removes the ".bin" extensions that the
pro-apps use because they must be wrapped by a shell script.

.SH KEYWORDS
cmdline processing
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































Deleted modules/cmdline/cmdline.tcl.

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

package require Tcl 8.2
package provide cmdline 1.2.1

namespace eval ::cmdline {
    namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
	    getKnownOptions usage
}

# Load the typed versions of these functions
source [file join [file dirname [info script]] typedCmdline.tcl]

# ::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 procede.
#
# 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 procede.
#
# 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 {[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 {[llength $argsList] != 0} {
			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]
    }
    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]
    }
    return [array get result]
}

# ::cmdline::GetOptionDefaults --
#
#	This internal procdure 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 \
	    {{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 comflict 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 [string map {{\\} {\\\\}} $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]
}


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/cmdline/cmdline.test.

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

package require tcltest
namespace import -force ::tcltest::*

set cmdLineFile [file join [file dirname [info script]] cmdline.tcl]
source $cmdLineFile
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}

# 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 [cmdline::getoptions argList {{foo.arg blat} {a.arg b}}] $argList
} {{foo blat a b} {}}
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                   
 -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                   
 -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                   
 -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                   
 -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                   
 -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                   
 -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]
    cd [list $::tcltest::temporaryDirectory]
"
    append script $body
    makeFile $script script

    set f [open "|[list $::tcltest::tcltest \
	    [file join $::tcltest::temporaryDirectory script]]" r]
    set result [read $f]
    close $f
    removeFile script
    return $result
}


# Create a directory with some files in it

file mkdir [file join $::tcltest::temporaryDirectory cmdlineJunk]
close [open [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] w]
close [open [file join $::tcltest::temporaryDirectory cmdlineJunk/foo2] w]
close [open [file join $::tcltest::temporaryDirectory cmdlineJunk/bar3] w]

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]
    }
} [list [file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]]
test cmdline-4.3 {cmdline::getfiles, multiple patterns} {pcOnly} {
    runGetFilesTest {
	cd cmdlineJunk
	set result [cmdline::getfiles {foo* bar*} 0]
	puts -nonewline [lsort $result]
    }
} [list [file join $::tcltest::temporaryDirectory cmdlineJunk/bar3] \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]]
test cmdline-4.4 {cmdline::getfiles, no match} {pcOnly} {
    runGetFilesTest {
	cd cmdlineJunk
	set result [cmdline::getfiles {blat* foo*} 0]
	puts -nonewline [lsort $result]
    }
} "warning: no files match \"blat*\"\n[list \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]]"
test cmdline-4.5 {cmdline::getfiles, quiet} {pcOnly} {
    runGetFilesTest {
	cd cmdlineJunk
	set result [cmdline::getfiles {blat* foo*} 1]
	puts -nonewline [lsort $result]
    }
} [list \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo2]]
test cmdline-4.6 {cmdline::getfiles, relative paths} {
    runGetFilesTest {
	cd cmdlineJunk
	set result [cmdline::getfiles {foo1 foo2} 0]
	puts -nonewline [lsort $result]
    }
} [list \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1] \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/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]
    }
} [list \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1]]
test cmdline-4.8 {cmdline::getfiles, no match} {
    runGetFilesTest {
	cd cmdlineJunk
	set result [cmdline::getfiles {blat foo1} 0]
	puts -nonewline [lsort $result]
    }
} "warning: no files match \"blat\"\n[list \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1]]"
test cmdline-4.9 {cmdline::getfiles, silent no match} {
    runGetFilesTest {
	cd cmdlineJunk
	set result [cmdline::getfiles {blat foo1} 1]
	puts -nonewline [lsort $result]
    }
} [list \
	[file join $::tcltest::temporaryDirectory cmdlineJunk/foo1]]

# Remove the temporary directory and files from the previous tests

file delete -force [file join $::tcltest::temporaryDirectory cmdlineJunk]
removeFile script

# 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 [cmdline::getKnownOptions argList {{foo.arg blat} {a.arg b}}] $argList
} {{foo blat a b} {}}
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                   
 -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                   
 -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                   
 -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                   
 -help                Print this message
 -?                   Print this message
" {}]

tcltest::cleanupTests
return


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/cmdline/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 cmdline 1.2.1 [list source [file join $dir cmdline.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/cmdline/typedCmdline.tcl.

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

}

# ::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 procede. 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 extentions

                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"
                    }
                } 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]
        } elseif {$err == -2 && ![info exists defaults($opt)]} {
            error [typedUsage $optlist $usage]
        }
    }
    if {[info exists result(?)] || [info exists result(help)]} {
        error [typedUsage $optlist $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 
#	(ie, 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 nothting 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
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/cmdline/typedCmdline.test.

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

package require tcltest
namespace import -force ::tcltest::*

set cmdLineFile [file join [file dirname [info script]] cmdline.tcl]
source $cmdLineFile
set argv0 "argv0"

# cmdline::typedGetopt

test 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 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 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 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 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 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 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 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 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 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 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 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 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 cmdline-6.14 {cmdline::typedGetopt, integer options} {
    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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 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 cmdline-7.1 {cmdline::typedGetoptions} {
    set argList {foo}
    list [cmdline::typedGetoptions argList {}] $argList
} {{} foo}
test cmdline-7.2 {cmdline::typedGetoptions, secret integer flag} {
    set argList {-foo 123}
    list [cmdline::typedGetoptions argList {{foo.integer.secret}}] $argList
} {{foo 123} {}}
test cmdline-7.3 {cmdline::typedGetoptions, normal integer flag} {
    set argList {-foo 123}
    list [cmdline::typedGetoptions argList {{foo.integer}}] $argList
} {{foo 123} {}}
test cmdline-7.4 {cmdline::typedGetoptions, missing integer flag, no default value} {
    set argList {}
    list [cmdline::typedGetoptions argList {{foo.integer}}] $argList
} {{} {}}
test 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 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 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 cmdline-7.8 {cmdline::typedGetoptions, missing integer flag with arg, default value} {
    set argList {-* 123}
    list [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}] $argList
} {{foo 234 * 123} {}}
test cmdline-7.9 {cmdline::typedGetoptions, missing integer flag with arg, default value} {
    set argList {-f}
    list [cmdline::typedGetoptions argList {{foo.integer 234} {*.double 5.234 {Unusual}}}] $argList
} {{foo 234 * 5.234} {}}
test 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 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 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 cmdline-7.13 {cmdline::typedGetoptions, multiple flags with arg, default value} {
    set argList {}
    list [cmdline::typedGetoptions argList {{foo.arg blat} {a.arg b}}] $argList
} {{foo blat a b} {}}
test cmdline-7.14 {cmdline::typedGetoptions, errors} {
    set argList {-a -foo}
    list [cmdline::typedGetoptions argList {{foo.arg blat} a}] $argList
} {{foo blat a {}} {}}
test cmdline-7.15 {cmdline::typedGetoptions, errors} {
    set argList {-a -fo}
    list [cmdline::typedGetoptions argList {{foo.arg blat} a}] $argList
} {{foo blat a {}} {}}
test cmdline-7.16 {cmdline::typedGetopt, xdigit options} {
    set argList {-foo 50gc}
    list [cmdline::typedGetoptions argList {foo.(50GC|50gc) bar}] $argList
} {{foo 50gc} {}}
test cmdline-7.17 {cmdline::typedGetopt, xdigit options} {
    set argList {-foo -bar}
    list [cmdline::typedGetoptions argList {foo.(50GC|50gc)? bar}] $argList
} {{foo {} bar {}} {}}
test 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 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 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 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 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 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 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 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 cmdline-7.26 {cmdline::typedGetoptions, unusual option} {
    set argList {-x?y -a -foo}
    list [cmdline::typedGetoptions argList {{foo.arg blat} x?y x*y a}] $argList
} {{foo blat x?y {} a {}} {}}
test 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 cmdline-7.28 {cmdline::typedGetoptions, unusual option, abbreviation} {
    set argList {-x -a -foo}
    list [cmdline::typedGetoptions argList {{foo.arg blat} x?y a}] $argList
} {{foo blat x?y {} a {}} {}}
test 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 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 cmdline-7.31 {cmdline::typedGetoptions, multiple boolean flag} {
    set argList {-foo}
    list [cmdline::typedGetoptions argList {{foo.multi}}] $argList
} {{foo {}} {}}
test cmdline-7.32 {cmdline::typedGetoptions, multiple boolean flag} {
    set argList {-foo -foo}
    list [cmdline::typedGetoptions argList {{foo.multi}}] $argList
} {{} {}}
test cmdline-7.33 {cmdline::typedGetoptions, multiple boolean flag} {
    set argList {-foo -foo -foo}
    list [cmdline::typedGetoptions argList {{foo.multi}}] $argList
} {{foo {}} {}}

tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/comm/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
2003-04-11  Andreas Kupries  <[email protected]>

	* comm.man:
	* comm.tcl:
	* pkgIndex.tcl: Set version of the package to to 4.0.1.

2003-01-28  David N. Welton  <[email protected]>

	* comm.tcl (::comm::commConfigure): Use 'string is integer'
	  instead of regexp's.
	  Require Tcl 8.2.

2003-01-16  Andreas Kupries  <[email protected]>

	* comm.man: More semantic markup, less visual one.

2002-08-06  Andreas Kupries  <[email protected]>

	* 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 <[email protected]>.

2002-03-06  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* comm.tcl: Frink run.

2002-01-15  Andreas Kupries  <[email protected]>

	* Bumped version to 3.7.1.

2001-11-16  Andreas Kupries <[email protected]>

	* 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 <[email protected]>

	* Integrated into tcllib.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































Deleted modules/comm/comm.LICENSE.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
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:

	[email protected]

Comments and questions on this software should be sent to the author:

	[email protected]
	[email protected]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































Deleted modules/comm/comm.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
[manpage_begin comm n 4.0.1]
[copyright {1995-1998 The Open Group. All Rights Reserved.}]
[moddesc   {remote communication}]
[titledesc {A remote communications facility for Tcl (7.6, 8.0, and later)}]
[require Tcl 8.2]
[require comm [opt 4.0.1]]
[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"] :

[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]

[section  COMMANDS]
[para]

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] [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] option is given.

[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]

[section  "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.

[section  "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.

[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"
}]

[para]

The default channel [cmd ::comm::comm] is created with:

[para]
[example {
  "::comm::comm new ::comm::comm -port 0 -local 1 -listen 1"
}]

[section  "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 value ..."]]]

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]
[lst_item "[option -listen] [opt [arg 0|1]]"]
[lst_item "[option -local]  [opt [arg 0|1]]"]
[lst_item "[option -port]   [opt [arg port]]"]
[list_end]

[para]
These configuration variables are readonly:

[list_begin definitions]
[lst_item "[option -chan]    [arg chan]"]
[lst_item "[option -serial]  [arg n]"]
[lst_item "[option -socket]  sock[arg In]"]
[list_end]

[para]

When [cmd config] changes the parameters of an existing channel, 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.

[section  "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 [emph 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).

[section  "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).

[section  "CLOSING CONNECTIONS"]
[para]

These methods give control over closing connections:

[list_begin definitions]

[call [cmd "::comm::comm shutdown"] [arg Iid]]

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:

[nl]
[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.

[section  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.

[nl]

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.

[nl]
Common variables include:

[list_begin definitions]

[lst_item [var chan]]
the name of the comm channel (and command)

[lst_item [var id]]
the id of the remote in question

[lst_item [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]

[lst_item [const connecting]]

Variables:
[arg "chan id host port"]

[nl]

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:

[nl]
[example {
 % ::comm::comm hook connecting {
     if [lb]string match {*[lb]02468[rb]} $id[rb] {
         error "Can't connect to even ids" 
     }
 }
 % ::comm::comm send 10000 puts ok
 Connect to remote failed: Can't connect to even ids
 % 
}]

[lst_item [const connected]]

Variables:
[arg "chan fid id host port"]
[nl]

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].

[lst_item [const incoming]]

Variables:
[arg "chan fid addr remport"]
[nl]

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:

[nl]
[example {
 ::comm::comm hook incoming {
     if [lb]string match 127.0.0.1 $addr[rb] {
         error "I don't talk to myself"
     }
 }
}]


[lst_item [const eval]]

Variables:
[arg "chan id cmd buffer"]
[nl]

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].

[nl]

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].

[nl]

Examples:

[list_begin enum]

[enum]
augmenting a command
[nl]
[example {
 % ::comm::comm send [lb]::comm::comm self[rb] pid
 5013
 % ::comm::comm hook eval {puts "going to execute $buffer"}
 % ::comm::comm send [lb]::comm::comm self[rb] pid
 going to execute pid
 5013
}]

[enum]
short circuiting a command
[nl]
[example {
 % ::comm::comm hook eval {puts "would have executed $buffer"; return 0}
 % ::comm::comm send [lb]::comm::comm self[rb] pid
 would have executed pid
 0
}]

[enum]
Replacing double eval semantics
[nl]
[example {
 % ::comm::comm send [lb]::comm::comm self[rb] llength {a b c}
 wrong # args: should be "llength list"
 % ::comm::comm hook eval {return [uplevel #0 $buffer]}
 return [lb]uplevel #0 $buffer[rb]
 % ::comm::comm send [lb]::comm::comm self[rb] llength {a b c}
 3
}]

[enum]
Using a slave interpreter
[nl]
[example {
 % interp create foo
 % ::comm::comm hook eval {return [lb]foo eval $buffer[rb]}
 % ::comm::comm send [lb]::comm::comm self[rb] 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)
[nl]
[example {
 % ::comm::comm hook eval {return [lb]eval foo eval $buffer[rb]}
}]

[enum]
Subverting the script to execute
[nl]
[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 [lb]::comm::comm self[rb] pid
 pid is a no-no
 % ::comm::comm send [lb]::comm::comm self[rb] a
 A-OK
}]

[list_end]


[lst_item [const reply]]

Variables:
[arg "chan id buffer ret return()"]
[nl]

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 bullet]
[bullet]
return result
[bullet]
return -code code result
[bullet]
return -code code -errorinfo info -errorcode ecode msg
[list_end]

For safety reasons, this is decomposed.  The return result is in
[arg ret], and the return switches are in the return array:

[list_begin bullet]
[bullet]
[emph return(-code)]
[bullet]
[emph return(-errorinfo)]
[bullet]
[emph return(-errordcode)]
[list_end]

Any of these may be the empty string.  Modifying these four variables
can change the return value, whereas modifying [arg buffer] has no
effect.


[lst_item [const lost]]

Variables:
[arg "chan id reason"]
[nl]

This hook is invoked when the connection to [emph id] is lost.  Return
value (or thrown error) is ignored.  [arg reason] is an explanatory
string indicating why the connection was lost.  Example:

[nl]

[example {
 ::comm::comm hook lost {
     global myvar
     if {$myvar(id) == $id} {
         myfunc
         return
     }
 }
}]

[list_end]

[section  UNSUPPORTED]
[para]
These interfaces may change or go away in subsequence releases.

[list_begin definitions]
[call [cmd "::comm::comm remoteid"]]

Returns the [emph 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].

[nl]

[example {
 proc send {args} {
     eval ::comm::comm send $args
 }
 rename winfo tk_winfo
 proc winfo {cmd args} {
     if ![lb]string match in* $cmd[rb] {return [lb]eval [lb]list tk_winfo $cmd[rb] $args[rb]}
     return [lb]::comm::comm interps[rb]
 }
}]

[list_end]

[section  SECURITY]
[para]
Something here soon.

[section "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 will still 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.

[section 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]

[lst_item "4.0"]

Per request by John LoVerso. Improved handling of error for async
invoked commands.

[lst_item "3.7"]

Moved into tcllib and placed in a proper namespace.

[lst_item "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.

[lst_item "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.

[lst_item "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]:

[example {
 comm send id break
 catch {comm send id break}
 comm send id expr 1 / 0
}]

[nl]

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"]!)


[lst_item "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.

[lst_item "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.

[lst_item "3.1"]

All the documented hooks were implemented.  [cmd commLostHook] was
removed.  A bug in [cmd "comm new"] was fixed.

[lst_item "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.

[lst_item "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.

[lst_item "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].

[lst_item "2.1"]
Unsupported method [cmd "comm remoteid"] was added.

[lst_item "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]

[section  AUTHOR]

John LoVerso, [email protected]

[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 bullet]
[bullet]

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.

[bullet]

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 bullet]
[bullet]

Allow easier use of a slave interp for actual command execution
(especially when operating in "not local" mode).

[bullet]

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 bullet]
[bullet]

Add an interp discovery and name->port mapping.  This is likely to be
in a separate, optional nameserver.  (See also the related work,
below.)

[bullet]

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
[emph http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html].

[para]
Michael Doyle <[email protected]> has code that implements the Tcl-DP
RPC interface using standard Tcl sockets, much like [package comm]

[para]
Andreas Kupries <[email protected]> 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].

[see_also send(n)]
[manpage_end]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/comm/comm.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
.\" $Id: comm.n,v 1.4 2002/01/18 20:51:15 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)
.\"
.so man.macros
.TH comm n 3.7 comm "package comm 3.7.1"
.SH NAME
comm.tcl \- A remote communications facility for Tcl (7.6, 8.0, and later)
.SH SYNOPSIS
.nf
\fBpackage require comm ?3.7.1?\fR
.sp
\fIchan \fBnew \fIchan\fR ?\fIname value ...\fR?
\fIchan \fBsend \fR?\fI-async\fR? \fIid cmd \fR?\fIarg arg ...\fR?
\fIchan \fBhook \fIevent\fR ?\fB+\fR??\fIscript\fR?
\fIchan \fIoption\fP ?\fI arg arg ...\fR?
.fi
The package initializes \fB::comm::comm\fR as the default \fIchan\fR.
.SH "INTRODUCTION"
.PP
The
.B comm
command provides an inter-interpreter remote execution facility
much like Tk's
.IR send "(n)",
except that it uses sockets rather than
the X server for the communication path.
As a result,
.B comm
works with multiple interpreters,
works on Windows and Macintosh systems,
and
provides control over the remote execution path.
.LP
These commands work just like
.B send
and
.BR "winfo interps" :
.CS
 \fB::comm::comm send \fR?\fI-async\fR? \fIid cmd \fR?\fIarg arg ...\fR?
 \fB::comm::comm interps\fP
.CE
.PP
This is all that is really needed to know in order to use
.BR comm .
'\"
'\"
'\"
.SH DESCRIPTION
.PP
.B comm
names communication endpoints with an
.I id
unique to each machine.
Before sending commands, the
.I id
of another interpreter is needed.
Unlike Tk's send,
.B comm
doesn't implicitly know the
.IR id 's
of all the interpreters on the system.
.TP
\fB::comm::comm send \fR?\fI-async\fR? \fIid cmd \fR?\fIarg arg ...\fR? 
This invokes the given command in the interpreter named by
.IR id .
The command waits for the result and remote errors are returned
unless the
.B -async
option is given.
.TP
\fB::comm::comm self\fP
Returns the
.I id
for this channel.
.TP
\fB::comm::comm interps\fP
Returns a list of all the remote
.IR id 's
to which this channel is connected.
.B comm
learns a new remote
.I id
when a command is first issued it,
or when a remote
.I id
first issues a command to this comm channel.
\fB::comm::comm ids\fP
is an alias for this method.
.TP
\fB::comm::comm connect \fR?\fIid\fR?
Whereas
.B "::comm::comm send"
will automatically connect to the given
.IR id ,
this forces a connection to a remote
.I id
without sending a command.
After this, the remote
.I id
will appear in
.BR "::comm::comm interps" .
.LP
These four methods make up the basic
.B comm
interface.
'\"
'\"
'\"
.SH "EVAL SEMANTICS"
.PP
The evaluation semantics of
.B "::comm::comm send"
are intended to match Tk's
.B send
.IR exactly .
This means that
.B comm
evaluates arguments on the remote side.
.LP
If you find that
.B "::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
.B send
command also produces the same error.
.CS
 % \fB::comm::comm send \fIid\fP llength {a b c}
 \fBwrong # args: should be "llength list"\fR
 % \fBsend \fIname\fP llength {a b c}
 \fBwrong # args: should be "llength list"\fR
.CE
.LP
The
.B eval
hook (described below) can be used to change from
.BR send 's
double eval semantics to single eval semantics.
'\"
'\"
'\"
.SH "MULTIPLE CHANNELS"
.PP
More than one
.B comm
channel (or
.IR listener )
can be created in each Tcl interpeter.
This allows flexibility to create full and restricted channels.
For instance,
.B hook
scripts are specific to the channel they are defined against. 
.TP
\fB::comm::comm new \fIchan\fR ?\fIname value ...\fR?
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
.BR ::comm::comm .
Any remaining arguments are passed to the
.B config
method.
.TP
\fB::comm::comm channels\fR
This lists all the channels allocated in this Tcl interpreter.
.LP
The default configuration parameters for a new channel are:
.PP
.CS
.B "-port 0 -local 1 -listen 0"
.CE
.PP
The default channel
.B ::comm::comm
is created with:
.PP
.CS
.B "::comm::comm new ::comm::comm -port 0 -local 1 -listen 1"
.CE
'\"
'\"
'\"
.SH "CHANNEL CONFIGURATION"
.PP
The
.B config
method acts similar to
.B fconfigure
in that it sets or queries configuration variables associated with a channel.
.RS
\fB::comm::comm config
.br
\fB::comm::comm config \fIname\fR
.br
\fB::comm::comm config ?\fIname value ...\fR?
.RE
When given no arguments,
.B config
returns a list of all variables and their value
With one argument,
.B config
returns the value of just that argument.
With an even number of arguments, the given variables are set to the
given values.
.PP
These configuration variables can be changed
(descriptions of them are elsewhere in this manual page):
.RS
-\fBlisten \fR?\fI0|1\fR?
-\fBlocal \fR?\fI0|1\fR?
-\fBport \fR?\fIport\fR?
.RE
.sp
These configuration variables are readonly:
.RS
-\fBchan\fR \fIchan\fR
-\fBserial\fR \fIn\fR
-\fBsocket\fR sock\fIn\fR
.RE
.PP
When
.B config
changes the parameters of an existing channel,
it closes and reopens the listening socket.
An automatically assigned channel
.I id
will change when this happens.
Recycling the socket is done by invoking
.BR "::comm::comm abort" ,
which causes all active sends to terminate.
'\"
'\"
'\"
.SH "ID/PORT ASSIGNMENTS"
.PP
.B comm
uses a TCP port for endpoint
.IR id .
The
.B interps
(or
.BR ids )
method merely lists all the TCP ports to which the channel is connected.
By default, each channel's
.I 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
.B "-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
.BR "-port {}" .
Note that a channel won't be created and initialized
unless the specific port can be allocated.
.PP
As a special case, if the channel is configured with
.BR "-listen 0",
then it will not create a listening socket and will use an id of
.I 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).
'\"
'\"
'\"
.SH "REMOTE INTERPRETERS"
.PP
By default, each channel is restricted to accepting connections from the
local system.  This can be overriden by using the
.B "-local 0"
configuration option
For such channels, the
.I id
parameter takes the form
.BI { "id host" }
.BR "" .
.LP
.BR WARNING :
The
.I host
must always be specified in the same form
(e.g., as either a fully qualified domain name,
plain hostname or an IP address).
'\"
'\"
'\"
.SH "CLOSING CONNECTIONS"
.PP
These methods give control over closing connections:
.TP
\fB::comm::comm shutdown \fIid\fR 
This closes the connection to
.IR id ,
aborting all outstanding commands in progress.  Note that nothing
prevents the connection from being immediately reopened by another
incoming or outgoing command.
.TP
\fB::comm::comm abort\fR
This invokes shutdown on all open connections in this comm channel.
.TP
\fB::comm::comm destroy\fR
This aborts all connections and then destroys the this comm channel itself,
including closing the listening socket.
Special code allows the default
.B ::comm::comm
channel to be closed
such that the
.B ::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:
.CS
.B "::comm::comm destroy; ::comm::comm new ::comm::comm"
.CE
.PP
When a remote connection is lost (because the remote exited or called
.BR shutdown ),
.B comm
can invoke an application callback.
This can be used to cleanup or restart an ancillary process,
for instance.
See the
.B lost
callback below.
'\"
'\"
'\"
.SH CALLBACKS
.PP
This is a mechanism for setting hooks for particular events:
.CS
 \fB::comm::comm hook \fIevent\fR ?\fB+\fR??\fIscript\fR? 
.CE
.LP
This uses a syntax similar to Tk's
.B bind
command.
Prefixing
.I script
with a + causes the new script to be appended.
Without this, a new
.I 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.
.LP
When an
.I event
occurs,
the
.I script
associated with it is evaluated
with the listed variables in scope and available.
The return code
.RB ( not
the return value) of the script
is commonly used decide how to further process after the hook.
.LP
Common variables include:
.RS
.IP \fBchan\fR 5
the name of the comm channel (and command)
.IP \fBid\fR 5
the id of the remote in question
.IP \fBfid\fR 5
the file id for the socket of the connection
.RE
.ta 4i
These are the defined
.IR events :
.TP
\fBconnecting\fR
Variables:
.I "chan id host port"
.br
This hook is invoked before making a connection
to the remote named in
.IR id .
An error return (via
.BR error )
will abort the connection attempt with the error.
Example:
.sp
.CS
 % ::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
 % 
.CE
.\"
.TP
.B connected
Variables:
.I "chan fid id host port"
.br
This hook is invoked immediately after making a remote connection to
.IR id ,
allowing arbitrary authentication over the socket
named by
.IR fid .
An error return (via
.BR error )
will close the connection with the error.
.I host
and
.I port
are merely extracted from the
.IR id ;
changing any of these will have no effect on the connection, however.
It is also possible to substitute and replace \fIfid\fP.
.\"
.TP
\fBincoming\fP
Variables:
.I "chan fid addr remport"
.br
Hook invoked when receiving an incoming connection,
allowing arbitrary authentication over socket
named by
.IR fid .
An error return (via
.BR error )
will close the connection with the error.
Note that the peer is named by
.IR remport " and " addr
but that the remote
.I id
is still unknown.  Example:
.sp
.CS
 ::comm::comm hook incoming {
     if [string match 127.0.0.1 $addr] {
         error "I don't talk to myself"
     }
 }
.CE
.\"
.TP
\fBeval\fP
Variables:
.I "chan id cmd buffer"
.br
This hook is invoked after collecting a complete script from a remote
but
.B before
evalutating it.
This allows complete control over the processing of incoming commands.
.I cmd
contains either
.BR send " or " async .
.I buffer
holds the script to evaluate.
At the time the hook is called,
.B "$chan remoteid"
is identical in value to
.BR id.
.sp
By changing
.IR 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
.B return
.I result
(or, from within a procedure,
.B "return -code return"
.IR result ).
An error return (via
.BR error )
will return an error result, as is if the script caused the error.
Any other return will evaluate the script in
.I buffer
as normal.
For compatibility with 3.2,
.B break
and
.B "return -code break"
.I result
is supported, acting similarly to
.B "return {}"
and
.B "return -code return" 
.IR result .
.sp
Examples:
.RS
1. augmenting a command
.PP
.CS
 % ::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
.CE
.PP
2. short circuting a command
.PP
.CS
 % ::comm::comm hook eval {puts "would have executed $buffer"; return 0}
 % ::comm::comm send [::comm::comm self] pid
 would have executed pid
 0
.CE
.PP
3. Replacing double eval semantics
.PP
.CS
 % ::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
.CE
.PP
4. Using a slave interpreter
.PP
.CS
 % 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
.CE
.PP
5. Using a slave interpreter (double eval)
.PP
.CS
 % ::comm::comm hook eval {return [eval foo eval $buffer]}
.CE
.PP
6. Subverting the script to execute
.PP
.CS
 % ::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
.CE
.RE

.\"
.TP
\fBreply\fP
Variables:
.I "chan id buffer ret return()"
.br
This hook is invoked after collecting a complete reply script from a remote
but
.B before
evalutating it.
This allows complete control over the processing of replies to sent commands.
The reply
.I buffer
is in one of the following forms
.RS
.CS
 return \fIresult\fP
 return -code \fIcode\fP \fIresult\fP
 return -code \fIcode\fP -errorinfo \fIinfo\fP -errorcode \fIecode\fP \fImsg\fP
.CE
.PP
For safety reasons, this is decomposed.  The return result
is in 
.IR ret ,
and the return switches are in the return array:
.CS
.I return(-code)
.I return(-errorinfo)
.I return(-errordcode)
.CE
.PP
Any of these may be the empty string.
Modifying
these four variables can change the return value, whereas
modifying
.I buffer
has no effect.
.RE
.\"
.TP
\fBlost\fP
Variables:
.I "chan id reason"
.br
This hook is invoked when the connection to
.I id
is lost.
Return value (or thrown error) is ignored.
.I reason
is an explanatory string indicating why the connection was lost.
Example:
.sp
.CS
 ::comm::comm hook lost {
     global myvar
     if {$myvar(id) == $id} {
         myfunc
         return
     }
 }
.CE
.SH UNSUPPORTED
.PP
These interfaces may change or go away in subsequence releases.
.TP
\fB::comm::comm remoteid\fR 
Returns the
.I 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.
.TP
.B "::comm::comm_send"
Invoking this procedure will substitute the Tk
.B send
and
.B "winfo interps"
commands with these equivalents that use
.BR ::comm::comm .
.sp
.CS
 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]
 }
.CE
'\"
'\"
'\"
.SH SECURITY
.PP
Something here soon.
'\"
'\"
'\"
.SH "BLOCKING SEMANTICS"
.PP
There is one outstanding difference between
.B comm
and
.BR send .
When blocking in a synchronous remote command,
.B 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,
.B comm
uses the
.B vwait
command as a semaphore to indicate the return message has arrived.
The difference is that a synchronous
.B send
will block the application and prevent all events
(including window related ones) from being processed,
while a synchronous
.B comm
will block the application but still allow
other events will still get processed.
In particular,
.B "after idle"
handlers will fire immediately when comm blocks.
.LP
What can be done about this?
First, note that this behavior will come from any code using
.B vwait
to block and wait for an event to occur.
At the cost of multiple channel support,
.B 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
.BR comm )
One way would be to create a modified version of the
.B vwait
command that allow the event flags passed to Tcl_DoOneEvent to be specified.
For
.BR 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
.B comm
doesn't require Tk).
One of these approaches will be available in a future
.B comm
release as an optional component.
'\"
'\"
'\"
.SH COMPATIBILITY
.PP
.B Comm
exports itself as a package.
The package version number is in the form
.IR 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
.B comm
this command is usually used:
.PP
.CS
 \fBpackage require comm 3\fR
.CE
.PP
Note that requiring no version (or a specific version) can also be done.
.LP
The revision history of
.B comm
includes these releases:

.IP "3.7" 5
Moved into tcllib and placed in a proper namespace.

.IP "3.6" 5
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.

.IP "3.5" 5
Internal change to how reply messages from a
.B send
are handled.
Reply messages are now decoded into the
.I value
to pass to
.BR 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
.B reply
message.

.IP "3.4" 5
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
.B pending
rather than the message about the lost connection.
.B "comm ids"
is now an alias for
.B "comm interps"
(previously, it an alias for
.BR "comm chans" ).
Since the method invocation change of 3.0, break and other exceptional
conditions were not being returned correctly from
.BR "comm send" .
This has been fixed by removing the extra level of indirection into
the internal procedure
.BR commSend .
Also added propogation of the
.I errorCode
variable.
This means that these commands return exactly as they would with
.BR send :
.RS
.CS
 comm send \fIid\fP break
 catch {comm send \fIid\fP break}
 comm send \fIid\fP expr 1 / 0
.CE
.PP
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
.B "comm config"
(as this manual page still listed the defunct
.BR "comm init" !)
.RE

.IP "3.3" 5
Some minor bugs were corrected and the documentation was cleaned up.
Added some examples for hooks.  The return semantics of the
.B eval
hook were changed.

.IP "3.2" 5
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.

.IP "3.1" 5
All the documented hooks were implemented.
.B commLostHook
was removed.
A bug in
.B "comm new"
was fixed.

.IP "3.0" 5
This is a new version of
.B comm
with several major changes.
There is a new way of creating the methods available under the
.B comm
command.
The
.B "comm init"
method has been retired and is replaced by
.B "comm configure"
which allows access to many of the well-defined internal variables.
This also generalizes the options available to
.BR "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.

.IP "2.3" 5
.B "comm ids"
was renamed to
.BR "comm channels" .
General support for
.B "comm hook"
was fully implemented, but
only the
.B lost
hook exists, and it was changed to follow the general hook API.
.B commLostHook
was unsupported (replaced by
.BR "comm hook lost" )
and
.B commLost
was removed.
.IP "2.2" 5
The 
.B died
hook was renamed
.BR lost ,
to be accessed by
.B commLostHook
and an early implementation of
.BR "comm lost hook" .
As such,
.B commDied
is now
.BR commLost .

.IP "2.1" 5
Unsupported method
.B "comm remoteid"
was added.

.IP "2.0" 5
.B comm
has been rewritten from scratch (but is fully compatible with Comm 1.0,
without the requirement to use obTcl).
'\"
.SH AUTHOR
John LoVerso, [email protected]
.PP
.I http://www.opengroup.org/~loverso/tcl-tk/#comm
'\"
.SH COPYRIGHT
Copyright (C) 1995-1998 The Open Group.   All Rights Reserved.
Please see the file
.I comm.LICENSE
that accompanied this source,
or
.IR http://www.opengroup.org/www/dist_client/caubweb/COPYRIGHT.free.html .
.PP
This license for
.BR comm ,
new as of version 3.2,
allows it to be used for free,
without any licensing fee or royalty.
'\"
'\"
'\"
.SH BUGS
.IP \(bu
If there is a failure initializing a channel created with
.BR "::comm::comm new" ,
then the channel should be destroyed.
Currently, it is left in an inconsistent state.
.IP \(bu
There should be a way to force a channel to quiesce when changing the
configuration.
.LP
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.
.IP \(bu
Allow easier use of a slave interp for actual command execution
(especially when operating in "not local" mode).
.IP \(bu
Add host list (xhost-like) or "magic cookie" (xauth-like)
authentication to initial handshake.
.LP
The following are outstanding todo items.
.IP \(bu
Add an interp discovery and name->port mapping.
This is likely to be in a separate, optional nameserver.
(See also the related work, below.)
.IP \(bu
Fix the
.I "{id host}"
form so as not to be dependent upon canonical hostnames.
This requires fixes to Tcl to resolve hostnames!
.LP
.sp 2
This man page is bigger than the source file.
'\"
'\"
'\"
.SH "ON USING OLD VERSIONS OF TCL"
.PP
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:
.CS
.B "comm send $other exit"
.CE
.PP
Always make sure the channel is quiescent before closing/exiting or
use at least Tcl7.6 under Windows.
.LP
Tcl7.6 on the Mac contains several bugs.  It is recommended you use
at least Tcl7.6p2.
.LP
Tcl8.0 on UNIX contains a socket bug that can crash Tcl.  It is recommended
you use Tcl8.0p1 (or Tcl7.6p2).
'\"
'\"
'\"
.SH "RELATED WORK"
.PP
Tcl-DP provides an RPC-based remote execution interface, but is a compiled
Tcl extension.  See
.IR http://www.cs.cornell.edu/Info/Projects/zeno/Projects/Tcl-DP.html .
.PP
Michael Doyle <[email protected]> has code that implements the Tcl-DP RPC
interface using standard Tcl sockets, much like
.BR comm .
.PP
Andreas Kupries <[email protected]> uses
.B comm
and has built a simple nameserver as part of his Pool library.
See
.IR http://www.purl.org/net/akupries/soft/pool/index.htm .
'\"
'\"
'\"
.SH "SEE ALSO"
send(n)
'\"
'\" eof
'\"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/comm/comm.n.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
<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.2 2002/01/18 20:51:15 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, [email protected]
<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;[email protected]&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;[email protected]&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>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/comm/comm.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
# 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)
#
# 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.8 2003/04/11 19:39:12 andreas_kupries Exp $

package require Tcl 8.2

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
	    reply,hook 1
	    lost,hook 1
	    offerVers {3 2}
	    acceptVers {3 2}
	    defVers 2
	}
	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
    #	$meth,method		body of method
    #
    # Channel instance variables:
    # comm()
    #	$ch,port		listening port (our id)
    #	$ch,socket		listening socket
    #	$ch,local		boolean to indicate if port is local
    #	$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

    # Special initialization, defines the method 'method' to be used
    # for the definition of new methods (sic!). The code is executed
    # in the scope of the procedure '::comm::comm''. This means that
    # they have only access to the 'args' argument and the 'chan'
    # variable. This includes 'method' itself.

    # Create the methods on comm
    # Perhaps this shouldn't store them as procs?

    set comm(method,method) {
	# args[0]      = name of method
	# args[1..end] = body of method

	if {[llength $args] == 1} {
	    # No body given, call is query for body.
	    if [info exists comm([lindex $args 0],method)] {
		return $comm([lindex $args 0],method)
	    } else {
		error "No such method"
	    }
	}
	# Define new method.
	eval [linsert [lrange $args 1 end] 0 \
		set [list comm([lindex $args 0],method)]]
	#eval set [list comm([lindex $args 0],method)] [lrange $args 1 end]
    }

    if {0} {
	# Propogate result, code, and errorCode.  Can't just eval
	# otherwise TCL_BREAK gets turrned 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.
	eval [linsert $args 0 ::comm::comm send]
	#eval comm send $args
    }
    rename winfo tk_winfo
    proc winfo {cmd args} {
	if {![string match in* $cmd]} {
	    # Use pure lists to speed this up ...
	    return [eval [linsert $args 0 tk_winfo $cmd]]
	    #return [eval [list tk_winfo $cmd] $args]
	}
	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} {
    variable comm
    set chan ::comm::comm ; # chan is used in the code of the declared methods.

    set method [array names comm $cmd*,method]	;# min unique

    if {[llength $method] == 1} {
	return [eval $comm($method)]
    } else {
	foreach c [array names comm *,method] {
	    lappend cmds [lindex [split $c ,] 0]
	}
        error "bad subcommand \"$cmd\": should be [join [lsort $cmds] ", "]"
    }
}

::comm::comm method connect {
    #eval commConnect $args
    eval [linsert $args 0 commConnect]
}
::comm::comm method self {
    set comm($chan,port)
}
::comm::comm method channels {
    set comm(chans)
}
::comm::comm method new	{
    #eval commNew $args
    eval [linsert $args 0 commNew]
}
::comm::comm method configure {
    #eval commConfigure 0 $args
    eval [linsert $args 0 commConfigure 0]
}
::comm::comm method shutdown {
    eval commShutdown $args
    #eval commShutdown $args
}
::comm::comm method abort {
    eval [linsert $args 0 commAbort]
    #eval commAbort $args
}
::comm::comm method destroy {
    eval [linsert $args 0 commDestroy]
    #eval commDestroy $args
}
::comm::comm method hook {
    eval [linsert $args 0 commHook]
    #eval commHook $args
}
::comm::comm method ids {
    set res $comm($chan,port)
    foreach {i id} [array get comm $chan,fids,*] {lappend res $id}
    set res
}
::comm::comm method interps \
	[::comm::comm method ids]
::comm::comm method remoteid {
    if {[info exists comm($chan,remoteid)]} {
	set comm($chan,remoteid)
    } else {
	error "No remote commands processed yet"
    }
}
::comm::comm method debug {
    set comm(debug) \
	    [switch -exact -- $args on - 1 {subst 1} default {subst 0}]
}
::comm::comm method init {
    error "This method is no longer supported"
}
::comm::comm method send {
    set cmd send

    # args = ?-async? id cmd ?arg arg ...?
    set i 0
    if {[string match -async [lindex $args $i]]} {
	set cmd async
	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 {[string match "" $args]} {
	return -code error \
		"wrong # args: should be \"send ?-async? id arg ?arg ...?\""
    }
    if {[catch {commConnect $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 "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

    # wait for reply if so requested

    if {[string match 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 "--<<waiting $chan $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 "result\
		    <$comm($chan,return,$ser);$comm($chan,result,$ser)>"
	}
	after idle unset ::comm::comm($chan,result,$ser)

	array set return $comm($chan,return,$ser)
	unset comm($chan,return,$ser)
	switch -- $return(-code) {
	    "" - 0 {return $comm($chan,result,$ser)}
	    1 {
		return  -code $return(-code) \
			-errorinfo $return(-errorinfo) \
			-errorcode $return(-errorcode) \
			$comm($chan,result,$ser)
	    }
	    default {return -code $return(-code) $comm($chan,result,$ser)}
	}
    }
}

###############################################################################

# ::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 {arg} {
    variable comm
    if {$comm(debug)} {
	uplevel 1 $arg
    }
}

# ::comm::commNew --
#
#	Internal command. 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::commNew {ch args} {
    variable comm

    if {[lsearch -exact $comm(chans) $ch] >= 0} {
	error "Already existing channel: $ch"
    }
    if {([llength $args] % 2) != 0} {
	error "Must have an even number of config arguments"
    }
    if {[string match ::comm::comm $ch]} {
	# allow comm to be recreated after destroy
    } elseif {![string compare $ch [info proc $ch]]} {
	error "Already existing command: $ch"
    } else {
	regsub  "set chan \[^\n\]*\n" [info body ::comm::comm] \
		"set chan $ch\n" nbody
	proc $ch {cmd args} $nbody
    }
    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

    if {[llength $args] > 0} {
	eval [linsert $args 0 commConfigure 1]
	#eval commConfigure 1 $args
    }
    # XXX need to destroy chan if config failed
}

# ::comm::commDestroy --
#
#	Internal command. Destroy the channel invoking it.
#	Implements the 'comm destroy' method.
#
# Arguments:
#	None.
#
# Results:
#	None.

proc ::comm::commDestroy {} {
    upvar chan chan
    variable comm
    catch {close $comm($chan,socket)}
    commAbort
    catch {unset comm($chan,port)}
    catch {unset comm($chan,local)}
    catch {unset comm($chan,socket)}
    unset comm($chan,serial)
    set pos [lsearch -exact $comm(chans) $chan]
    set comm(chans) [lreplace $comm(chans) $pos $pos]
    if {[string compare ::comm::comm $chan]} {
	rename $chan {}
    }
}

# ::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]
    }
}
::comm::commConfVars port p
::comm::commConfVars local b
::comm::commConfVars listen b
::comm::commConfVars socket ro
::comm::commConfVars chan ro
::comm::commConfVars serial ro

# ::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 {{force 0} args} {
    upvar chan chan
    variable comm

    # query
    switch [llength $args] {
	0 {
	    foreach v $comm(vars) {lappend res -$v $comm($chan,$v)}
	    return $res
	}
	1 {
	    set arg [lindex $args 0]
	    set var [string range $arg 1 end]
	    if {[string match -* $arg] && [info exists comm($var,var)]} {
		return $comm($chan,$var)
	    } else {
		error "Unknown configuration option: $arg"
	    }
	}
    }

    # 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)]} {
	    error "Unknown configuration option: $arg"
	}
	set optval [lindex $args $opt]
	switch $comm($var,var) {
	    b {
		# FRINK: nocheck
		set $var [commBool $optval]
		set skip 1
	    }
	    v {
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    p {
		if {
		    [string compare $optval ""] &&
		    ![string is integer $optval]
		} {
		    error "Non-port to configuration option: -$var"
		}
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    i {
		if {![string is integer $optval]} {
		    error "Non-integer to configuration option: -$var"
		}
		# FRINK: nocheck
		set $var $optval
		set skip 1
	    }
	    ro { error "Readonly configuration option: -$var" }
	}
    }
    if {[info exists skip]} {
	error "Missing value for option: $arg"
    }

    foreach var {port listen local} {
	# FRINK: nocheck
	if {[info exists $var] && [set $var] != $comm($chan,$var)} {
	    incr force
	    # FRINK: nocheck
	    set comm($chan,$var) [set $var]
	}
    }

    # 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)]} {
	commAbort
	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 match "" $comm($chan,port)]} {
	set nport [incr comm(lastport)]
    } else {
	set userport 1
	set nport $comm($chan,port)
    } 
    while {1} {
	set cmd [list socket -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 erradicate the class
	    if {![string match ::comm::comm $chan]} {
		rename $chan {}
	    }
	    error $ret
	}
	set nport [incr comm(lastport)]
    }
    set comm($chan,socket) $ret

    # If port was 0, system allocated it for us
    set comm($chan,port) [lindex [fconfigure $ret -sockname] 2]
    return ""
}

# ::comm::commBool --
#
#	Internal command. Used by commConfigure to process boolean values.
#
# Arguments:
#	b	Value to process.
#
# Results:
#	bool	0 - false, 1 - true

proc ::comm::commBool {b} {
    switch -glob -- $b 0 - {[fF]*} - {[oO][fF]*} {return 0}
    return 1
}

# ::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 {id} {
    upvar chan chan
    variable comm

    commDebug {puts stderr "commConnect $id"}

    # process connecting hook now
    if {[info exists comm($chan,hook,connecting)]} {
    	eval $comm($chan,hook,connecting)
    }

    if {[info exists comm($chan,peers,$id)]} {
	return $comm($chan,peers,$id)
    }
    if {[lindex $id 0] == 0} {
	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 [socket $host $port]

    # process connected hook now
    if {[info exists comm($chan,hook,connected)]} {
    	if {[catch $comm($chan,hook,connected) err]} {
	    global errorInfo
	    set ei $errorInfo
	    close $fid
	    error $err $ei
	}
    }

    # commit new connection
    commNewConn $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 "commIncoming $chan $fid $addr $remport"}

    # process incoming hook now
    if {[info exists comm($chan,hook,incoming)]} {
    	if {[catch $comm($chan,hook,incoming) err]} {
	    global errorInfo
	    set ei $errorInfo
	    close $fid
	    error $err $ei
	}
    }

    # 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 protoline [gets $fid]
    set offeredvers [lindex $protoline 0]
    set remid [lindex $protoline 1]

    # 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
	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 compare [lindex [fconfigure $fid -sockname] 0] $addr]} {
	set id [list $remid $addr]
    } else {
	set id $remid
    }

    # 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 commited to using it.  commConnect
	# needs to be sychronous 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 $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 {id fid} {
    upvar chan chan
    variable comm

    commDebug {puts stderr "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 -trans binary -blocking 0
    fileevent $fid readable [list ::comm::commCollect $chan $fid]
}

# ::comm::commShutdown --
#
#	Internal command. Close down a peer connection.
#	Implements the 'comm shutdown' method.
#
# Arguments:
#	id	Reference to the remote interp
#
# Results:
#	None.

proc ::comm::commShutdown {id} {
    upvar chan chan
    variable comm

    if {[info exists comm($chan,peers,$id)]} {
	commLostConn $comm($chan,peers,$id) "Connection shutdown by request"
    }
}

# ::comm::commAbort --
#
#	Internal command. Close down all peer connections.
#	Implements the 'comm abort' method.
#
# Arguments:
#	None.
#
# Results:
#	None.

proc ::comm::commAbort {} {
    upvar chan chan
    variable comm

    foreach pid [array names comm $chan,peers,*] {
	commLostConn $comm($pid) "Connection aborted by request"
    }
}

# ::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 {
    fid {reason "target application died or connection lost"}
} {
    upvar chan chan
    variable comm

    commDebug {puts stderr "commLostConn $fid $reason"}

    catch {close $fid}

    set id $comm($chan,fids,$fid)

    foreach s $comm($chan,pending,$id) {
	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)}

    # process lost hook now
    catch {catch $comm($chan,hook,lost)}

    return $reason
}

###############################################################################

# ::comm::commHook --
#
#	Internal command. Implements 'comm hook'.
#
# Arguments:
#	hook	hook to modify
#	script	Script to add/remove to/from the hook
#
# Results:
#	None.

proc ::comm::commHook {hook {script +}} {
    upvar chan chan
    variable comm
    if {![info exists comm($hook,hook)]} {
	error "Unknown hook invoked"
    }
    if {!$comm($hook,hook)} {
	error "Unimplemented hook invoked"
    }
    if {[string match + $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 ""
}

###############################################################################

# ::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]} { 
	fileevent $fid readable {}		;# be safe
	commLostConn $fid
	return
    }
    append data $nbuf

    commDebug {puts stderr "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.

    while {![catch {set cmd [lindex $data 0]}]} {
	commDebug {puts stderr "cmd <$data>"}
	if {[string match "" $cmd]} break
	if {[info complete $cmd]} {
	    set data [lreplace $data 0 0]
	    after idle \
		    [list ::comm::commExec $chan $fid $comm($chan,fids,$fid) $cmd]
	}
    }
}

# ::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} {

    # 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 #
    
    variable comm

    # 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]

    commDebug {puts stderr "exec <$cmd,$ser,$buf>"}

    switch -- $cmd {
	send - async {}
	reply {
	    if {![info exists comm($chan,return,$ser)]} {
	        commDebug {puts stderr "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
	    }

	    if {[info exists comm($chan,hook,reply)]} {
		catch $comm($chan,hook,reply)
	    }

	    # this wakes up the sender
	    commDebug {puts stderr "--<<wakeup $chan $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 "unknown command; discard \"$cmd\""}
	    return
	}
    }

    # process eval hook now
    if {[info exists comm($chan,hook,eval)]} {
    	set err [catch $comm($chan,hook,eval) ret]
	commDebug {puts stderr "eval hook res <$err,$ret>"}
	switch $err {
	    1 {				;# error
		set done 1
	    }
	    2 - 3 {			;# return / break
		set err 0
		set done 1
	    }
	}
    }

    # exec command
    if {![info exists done]} {
	# 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).
	set err [catch [concat uplevel #0 $buffer] ret]
    }

    commDebug {puts stderr "res <$err,$ret>"}

    # The double list assures that the command is a single list when read.
    if {[string match send $cmd]} {
	# The catch here is just in case we lose the target.  Consider:
	#	comm send $other comm send [comm self] exit
	catch {
	    set return return
	    # send error or result
	    switch $err {
		0 {}
		1 {
		    global errorInfo errorCode
		    lappend return -code $err \
			    -errorinfo $errorInfo \
			    -errorcode $errorCode
		}
		default { lappend return -code $err}
	    }
	    lappend return $ret
	    puts $fid [list [list reply $ser $return]]
	    flush $fid
	}
    }

    if {$err == 1} {
	# 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 $ret
	} msg]} {
	    puts stderr "bgerror failed to handle background error."
	    puts stderr "    Original error: $ret"
	    puts stderr "    Error in bgerror: $msg"
	    flush stderr
	}
    }
    return
}

###############################################################################
#
# Finish creating "comm" using the default port for this interp.
#

if {![info exists ::comm::comm(comm,port)]} {
    if {[string match macintosh $tcl_platform(platform)]} {
	::comm::comm new ::comm::comm -port 0 -local 0 -listen 1
	set ::comm::comm(localhost) \
		[lindex [fconfigure $::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.0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/comm/comm.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
# -*- 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.2 2002/08/06 21:29:37 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

package require comm
puts "comm [package present 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

set path(spawn) [makeFile {
    ##puts [set fh [open ~/foo w]] $argv ; close $fh

    source [lindex $argv 0].tcl ; # load 'comm'
    # and wait for commands. But first send our
    # own server socket to the initiator
    ::comm::comm send [lindex $argv 1] [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] $path(spawn) \
	[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
# ------------------------------------------------------------------------

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}

test comm-1.3 {close remote} {
    ::comm::comm send -async [slave] {{exit}}
} {}

::comm::comm abort

::tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































Deleted modules/comm/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# Tcl package index file, version 1.0
# 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]} {return}
package ifneeded comm 4.0.1 [list source [file join $dir comm.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Changes to modules/control/ChangeLog.












































1
2
3
4
5
6
7











































2003-04-11  Andreas Kupries  <[email protected]>

	* control.man:
	* control.tcl:
	* pkgIndex.tcl:  Set version of the package to to 0.1.2.

2003-01-16  Andreas Kupries  <[email protected]>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
2005-05-24  Don Porter <[email protected]>

	* do.tcl:	Updates to use Tcl 8.5 [return] and [catch] extensions
	* control.man:	when availble to overcome LIMITATIONS.

	* wait-for-any.tcl:	New command: control::waitForAny.
	* wait-for-any.test:
	* tclIndex:

	* control.tcl:		Bump to version 0.2
	* pkgIndex.tcl:

	* do.test (do-2.3):	Update to accept newer error message format.
	          (do-2.2):	Error message refer to called command name.

2004-10-05  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.7 ========================
	* 

2004-05-23  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6.1 ========================
	* 

2004-02-15  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.6 ========================
	* 

2003-05-05  Andreas Kupries  <[email protected]>

	*
	* Released and tagged Tcllib 1.4 ========================
	* 

2003-05-01  Pat Thoyts  <[email protected]>

	* do.test: Skip test 1.14 if tcl < 8.3.

2003-04-11  Andreas Kupries  <[email protected]>

	* control.man:
	* control.tcl:
	* pkgIndex.tcl:  Set version of the package to to 0.1.2.

2003-01-16  Andreas Kupries  <[email protected]>

Changes to modules/control/ascaller.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# 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.2 2001/11/09 04:59:45 dgp 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 {








|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
# 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.2.6.1 2005/05/24 14:20:59 dgp 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 {

Changes to modules/control/assert.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
# assert.tcl --
#
#	The [assert] command of the package "control".
#
# RCS: @(#) $Id: assert.tcl,v 1.2 2002/02/15 05:35:30 andreas_kupries Exp $

namespace eval ::control {

    namespace eval assert {
	namespace export EnabledAssert DisabledAssert
	variable CallbackCmd [list return -code error]





|







1
2
3
4
5
6
7
8
9
10
11
12
# assert.tcl --
#
#	The [assert] command of the package "control".
#
# RCS: @(#) $Id: assert.tcl,v 1.2.2.1 2005/05/24 14:21:00 dgp Exp $

namespace eval ::control {

    namespace eval assert {
	namespace export EnabledAssert DisabledAssert
	variable CallbackCmd [list return -code error]

Changes to modules/control/control.man.

118
119
120
121
122
123
124
125
126

127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145



146
147
148
149

[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
}]




[see_also expr if join namespace return string while break continue]
[keywords control flow structure no-op assert do]
[manpage_end]







|
|
>



















>
>
>




118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153

[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 before
Tcl release 8.5, 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
}]

If the control package is used in an interpreter for Tcl 8.5 or
later, this limitation will not be present.

[see_also expr if join namespace return string while break continue]
[keywords control flow structure no-op assert do]
[manpage_end]

Deleted modules/control/control.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
'\"
'\" RCS: @(#) $Id: control.n,v 1.12 2002/01/18 21:45:42 dgp Exp $
'\" 
.so man.macros
.TH control n 0.0 control "Tcl Control Flow Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
control \- Procedures for control flow structures.
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require control ?0.1?\fR
.sp
\fBcontrol::control \fIcommand option \fR?\fIarg arg ...\fR?
.sp
\fBcontrol::assert \fIexpr \fR?\fIarg arg ...\fR?
.sp
\fBcontrol::do \fIbody \fR?\fIoption test\fR?
.sp
\fBcontrol::no-op \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
The \fBcontrol\fR 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 \fIkeywords\fR,
or a part of the language itself.  In Tcl, control flow structures
are just commands like everything else.
.SH COMMANDS
.TP
\fBcontrol::control \fIcommand option \fR?\fIarg arg ...\fR?
The \fBcontrol\fR command is used as a configuration command
for customizing the other public commands of the control package.
The \fIcommand\fR argument names the command to be customized.
The set of valid \fIoption\fR and subsequent arguments are
determined by the command being customized, and are documented
with the command.
.TP
\fBcontrol::assert \fIexpr \fR?\fIarg arg ...\fR?
When disabled, the \fBassert\fR command behaves exactly like
the \fBno-op\fR command.
.sp
When enabled, the \fBassert\fR command evaluates \fIexpr\fR as
an expression (in the same way that \fBexpr\fR evaluates its
argument).  If evaluation reveals that \fIexpr\fR is not a valid
boolean expression (according to [\fBstring is boolean -strict\fR]),
an error is raised.  If \fIexpr\fR evaluates to a true boolean value
(as recognized by \fBif\fR), then \fBassert\fR returns an empty string.
Otherwise, the remaining arguments to \fBassert\fR 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 \fBjoin\fR 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.
.sp
The \fBassert\fR command can be customized by the \fBcontrol\fR
command in two ways:
.sp
[\fBcontrol::control assert enabled \fR?\fIboolean\fR?] queries or
sets whether \fBcontrol::assert\fR is enabled.  When called without
a \fIboolean\fR argument, a boolean value is returned indicating
whether the \fBcontrol::assert\fR command is enabled.  When called
with a valid boolean value as the \fIboolean\fR argument, the
\fBcontrol::assert\fR command is enabled or disabled to match the
argument, and an empty string is returned.
.sp
[\fBcontrol::control assert callback \fR?\fIcommand\fR?] queries or sets
the callback command that will be called by an enabled \fBassert\fR on
assertion failure.  When called without a \fIcommand\fR argument, the
current callback command is returned.  When called with a \fIcommand\fR
argument, that argument becomes the new assertion failure callback
command.  Note that an assertion failure callback command is always
defined, even when \fBassert\fR is disabled.  The default callback
command is [\fBreturn -code error\fR].
.sp
Note that \fBcontrol::assert\fR has been written so that in
combination with [\fBnamespace import\fR], it is possible to
use enabled \fBassert\fR commands in some namespaces and disabled
\fBassert\fR commands in other namespaces at the same time.  
This capability is useful so that debugging efforts can be independently
controlled module by module.
.sp
.CS
\fB% 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}\fR
.CE
.TP
\fBcontrol::do \fIbody \fR?\fIoption test\fR?  
The \fBdo\fR command evaluates the script \fIbody\fR repeatedly
\fBuntil\fR the expression \fBtest\fR becomes true or as long as
(\fBwhile\fR) \fBtest\fR is true, depending on the value of
\fIoption\fR being \fBuntil\fR or \fBwhile\fR. If \fIoption\fR and
\fItest\fR are omitted the body is evaluated exactly once. After
normal completion, \fBdo\fR returns an empty string.  Exceptional
return codes (\fBbreak\fR, \fBcontinue\fR, \fBerror\fR, etc.) during
the evaluation of \fIbody\fR are handled in the same way the
\fBwhile\fR command handles them, except as noted in
\fBLIMITATIONS\fR, below.
.TP
\fBcontrol::no-op \fR?\fIarg arg ...\fR?
The \fBno-op\fR command takes any number of arguments and does nothing.
It returns an empty string.

.SH LIMITATIONS

Several of the commands provided by the \fBcontrol\fR package
accept arguments that are scripts to be evaluated.  Due to
fundamental limitations of Tcl's \fBcatch\fR and \fBreturn\fR
commands, it is not possible for these commands to properly
evaluate the command [\fBreturn -code $code\fR] within one
of those script arguments for any value of \fI$code\fR other
than \fIok\fR.  In this way, the commands of the \fBcontrol\fR
package are limited as compared to Tcl's built-in control flow
commands (such as \fBif\fR, \fBwhile\fR, etc.) and those
control flow commands that can be provided by packages coded
in C.  An example of this difference:
.sp
.CS
\fB% 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
.CE

.SH "SEE ALSO"
expr, if, join, namespace, return, string, while, break, continue

.SH KEYWORDS
control, flow, structure, no-op, assert, do
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































Changes to modules/control/control.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# 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.
#
# RCS: @(#) $Id: control.tcl,v 1.11 2003/04/11 19:41:34 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::control {
    variable version 0.1.2
    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






|




|
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
# 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.
#
# RCS: @(#) $Id: control.tcl,v 1.9.6.2 2005/05/24 15:08:51 dgp Exp $

package require Tcl 8.2

namespace eval ::control {
    variable version 0.2
    namespace export assert control do no-op waitForAny

    proc control {command args} {
	# Need to add error handling here
	namespace eval [list $command] $args
    }

    # Set up for auto-loading the commands

Changes to modules/control/do.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17



18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44





45
46
47
48

49
50
51
52
53
54
55
56
57
58







59
60









61
62
63
64
65
66
67
68
69
70
71

72





73







74
75
76





77
78
79
80
81
# 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 <[email protected]>
#
# 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.5 2002/02/15 05:35:30 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
	
    }

}












|


>


>
>
>








>


<
















>
>
>
>
>
|
|
<
|
>










>
>
>
>
>
>
>
|
|
>
>
>
>
>
>
>
>
>







|



>
|
>
>
>
>
>

>
>
>
>
>
>
>
|
|
|
>
>
>
>
>
|




1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32

33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55

56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
# 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 <[email protected]>
#
# 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.5.2.2 2005/05/24 19:19:09 dgp Exp $
#
namespace eval ::control {
    variable ReturnOptions [package vsatisfies [package provide Tcl] 8.5]

    proc do {body args} {
	variable ReturnOptions
	variable DoResult
	variable DoOptions

	#
	# 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 proc [lindex [info level 0] 0]
	set len [llength $args]
	if {$len !=2 && $len != 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
	if {$ReturnOptions} {
	    set code [uplevel 1 [list ::catch $body \
		    [namespace which -variable DoResult] \
		    [namespace which -variable DoOptions]]]
	} else {
	    set code [catch { uplevel 1 $body } DoResult]
	}


	# 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 {
		if {$ReturnOptions} {
		    set line [dict get $DoOptions -errorline]
		    dict append DoOptions -errorinfo \
			    "\n    (\"$proc\" body line $line)"
		    dict incr DoOptions -level
		    return -options $DoOptions $DoResult
		} else {
		    return -errorinfo [ErrorInfoAsCaller uplevel do]  \
			    -errorcode $::errorCode -code error $DoResult
		}
	    }
	    2 {
		if {$ReturnOptions} {
		    dict incr DoOptions -level
		    return -options $DoOptions $DoResult
		} else {
		    return -code $code $DoResult
		}
	    }
	    3 {
		# FRINK: nocheck
		return
	    }
	    4 {}
	    default {
		return -code $code $DoResult
	    }
	}
	# the rest of the loop
	if {$ReturnOptions} {
	    set code [uplevel 1 [list ::catch [list ::while $test $body] \
		    [namespace which -variable DoResult] \
		    [namespace which -variable DoOptions]]]
	} else {
	    set code [catch { uplevel 1 [list ::while $test $body] } DoResult]
	}
	if {$code == 1} {
	    if {$ReturnOptions} {
		set line [dict get $DoOptions -errorline]
		dict append DoOptions -errorinfo \
			"\n    (\"$proc\" body line $line)"
		dict incr DoOptions -level
		return -options $DoOptions $DoResult
	    } else {
		return -errorinfo [ErrorInfoAsCaller while do]  \
			-errorcode $::errorCode -code error $DoResult
	    }
	}
	if {$ReturnOptions && $code} {
	    dict incr DoOptions -level
	    return -options $DoOptions $DoResult
	}
	return -code $code $DoResult
	
    }

}

Changes to modules/control/do.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# do.test --
#
#         Tests for [control::do]
# 
# RCS: @(#) $Id: do.test,v 1.5 2002/02/21 11:40:45 rmax Exp $
#

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.
source [file join [file dirname [info script]] control.tcl]
namespace import ::control::do

package require tcltest
namespace import -force tcltest::test ::tcltest::cleanupTests

# ----------------------------------------
test {do-1.0} {do ... while} {
    set x 0
    do {incr x} while {$x < 10}
    set x




|











|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
# do.test --
#
#         Tests for [control::do]
# 
# RCS: @(#) $Id: do.test,v 1.5.2.3 2005/05/24 19:19:09 dgp Exp $
#

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.
source [file join [file dirname [info script]] control.tcl]
namespace import ::control::do

package require tcltest 2
namespace import -force tcltest::test ::tcltest::cleanupTests

# ----------------------------------------
test {do-1.0} {do ... while} {
    set x 0
    do {incr x} while {$x < 10}
    set x
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
    invoked from within
"b"
    (procedure "a" line 1)
    invoked from within
"a"}

# ----------------------------------------
test do-1.14 {stack traces for errors in subsequent iterations} {
    proc a {} b
    proc b {} {
	set i 10
	do {
	    incr i -1
	    c $i
	} while {$i}







|







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
    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}
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
} 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"}}

# ----------------------------------------
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
} {1 {wrong # args: should be "do body args"
    while executing
"do"}}

# ----------------------------------------
test do-2.4 {one-shot do with error} {
    set x 0
    set res [catch {do {







|




|










|







214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
} 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 "do body" or "do body [until|while] test"
    while executing
"do {incr x} foo"}}

# ----------------------------------------
test do-2.3 {wrong no of arguments} -body {
    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
} -match glob -result {1 {wrong # args: should be "do body *"
    while executing
"do"}}

# ----------------------------------------
test do-2.4 {one-shot do with error} {
    set x 0
    set res [catch {do {

Changes to modules/control/no-op.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
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.1 2001/08/21 22:54:15 dgp Exp $

namespace eval ::control {

    proc no-op args {}

}







|







1
2
3
4
5
6
7
8
9
10
11
12
13
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.1.6.1 2005/05/24 14:21:00 dgp Exp $

namespace eval ::control {

    proc no-op args {}

}

Changes to modules/control/no-op.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# 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.1 2001/08/21 22:54:15 dgp Exp $

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.







|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
# 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.1.6.1 2005/05/24 14:21:00 dgp Exp $

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.

Changes to modules/control/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded control 0.1.2 [list source [file join $dir control.tcl]]

|
1
2
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded control 0.2 [list source [file join $dir control.tcl]]

Added modules/control/rswitch.tcl.

























































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
# rswitch.tcl - 
#	Originally written: 	2001 Nov 2
#	Original author:	Don Porter <[email protected]>
#
#	This software was developed at the National Institute of Standards
#	and Technology by employees of the Federal Government in the course
#	of their official duties. Pursuant to title 17 Section 105 of the
#	United States Code this software is not subject to copyright
#	protection and is in the public domain. 
#
#       The [rswitch] command of the package "control".
#	Inspired by TIP 70.  Amended to the syntax:
#
# 		rswitch $formatString {
#		    $sub1 $body1
#		    ...
#		    $subN $bodyN
#		}
#
#	See documentation in control.n
# -------------------------------------------------------------------------
#
# RCS: @(#) $Id: rswitch.tcl,v 1.3 2001/11/07 21:59:24 dgp Exp $

namespace eval ::control {

    namespace export rswitch

    proc rswitch {formatString actionList} {
	if {[catch {llength $actionList} actionListLength]} {
	    return -code error $actionListLength
	}
	if {$actionListLength % 2} {
	    return -code error "extra substitution with no body"
	}
	# Check for final "default" arm
	set hasDefault [string equal default [lindex $actionList end-1]]
	if {$hasDefault} {
	    set defaultBody [lindex $actionList end]
	    set actionList [lrange $actionList 0 end-2]
	}
	set evalBody 0
	foreach {sub body} $actionList {
	    if {!$evalBody} {
		if {[catch {linsert $sub 0 ::format $formatString} cmd]} {
		    return -code error -errorinfo "$cmd\n    (\"$sub\"\
		        arm substitution)" -errorcode $::errorCode $cmd
		}
		if {[catch {eval $cmd} expression]} {
		    return -code error -errorcode $::errorCode -errorinfo \
			    "$expression\n    (\"$sub\" arm substitution)" \
			    $expression
		}
		set cmd [list ::expr $expression]
		eval [CommandAsCaller cmd evalBody [format "%s\n%s" \
			{\"$sub\" arm expression)} \
			{    (expression: \"$expression\"}]]
		if {![string is boolean -strict $evalBody]} {
		    set msg "non-boolean expression"
		    return -code error -errorcode $::errorCode -errorinfo \
			    [format "%s\n%s\n%s" $msg \
			    "    (\"$sub\" arm expression)" \
			    "    (expression: \"$expression\")"] $msg
		}
		if {!$evalBody} {
		    continue
		}
		set match $sub
	    }
	    # We've found a successful expression.
	    # Evaluate the corresponding body.
	    if {[string equal - $body]} {
		continue
	    }
	    eval [BodyAsCaller body result code {\"$match\" arm}]
	    return -code $code $result
	}
	if {!$hasDefault && !$evalBody} {
	    return
	}
	if {!$evalBody} {
	    set match default
	}
	if {!$hasDefault || [string equal - $defaultBody]} {
	    return -code error \
		"no body specified for substitution \"$match\""
	}
	eval [BodyAsCaller defaultBody result code {\"$match\" arm}]
	return -code $code $result
    }

}

Added modules/control/rswitch.test.

















































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
# rswitch.test - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Provide a set of tests to excercise the control::rswitch command of
# tcllib.
#
# @(#)$Id: rswitch.test,v 1.3 2001/11/07 05:31:42 dgp Exp $

# Initialize the required packages
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::test ::tcltest::cleanupTests
}

package forget control
catch {namespace delete control}

# Direct loading of provide script -- support testing even
# when not installed.  And be sure we test the local copy
# and not some later version that may be installed.
source [file join [file dirname [info script]] control.tcl]
namespace import ::control::rswitch

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

# Test simple numeric relational switching.
proc rsinteger {value} {
    rswitch {$value %s} {
        <5      {set result <5}
        ==5     {set result 5}
        >5      {set result >5}
        default {set result default}
    }
    return $result
}

test rswitch-1.1 {switch < 5} {
    catch {rsinteger 0} result
    set result
} {<5}

test rswitch-1.2 {switch == 5} {
    catch {rsinteger 5} result
    set result
} {5}

test rswitch-1.3 {switch > 5} {
    catch {rsinteger 10} result
    set result
} {>5}

test rswitch-1.4 {switch non numeric} {
    catch {rsinteger A} result
    set result
} {>5}

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

proc rs:compare {lhs rhs} {
    rswitch {$lhs %s $rhs} {
        <   {return <}
        ==  {return ==}
        >   {return >}
    }
}

test rswitch-2.1 {switch string comparison} {
    catch {rs:compare "hello" "world"} result
    set result
} {<}

test rswitch-2.2 {switch string comparison} {
    catch {rs:compare "hello" "hello"} result
    set result
} {==}

test rswitch-2.3 {switch string comparison} {
    catch {rs:compare "hello" "all"} result
    set result
} {>}

# -------------------------------------------------------------------------
# Here are the test cases I used when developing [rswitch] to check on
# its errorInfo management.  They should be converted to proper tests,
# preferably checking ::errorInfo.  OK, I'll do the first one:

test rswitch-3.0 {rswitch argument checking} {
    list [catch {rswitch 1 \{} msg] $msg $::errorInfo
} {1 {unmatched open brace in list} {unmatched open brace in list
    while executing
"rswitch 1 \{"}}

#rswitch {1 %s} {
#        {{>[string length]}} {string length}
#    }} msg] $msg]
#}
#rswitch 1 foo
#rswitch {1 %s} {
#	{{&& ([string length a]
#	||
#	[string length]}} {string length}
#}
#rswitch {1 %s} {
#	{{&& ([string length a]
#	||
#	[string length])}} {string length}
#}
#rswitch {1 %s} {
#	{{&& ([string length]
#	||
#	[string length])}} {string length}
#}
#rswitch {1 %s 1} {
#    ==  {
#	    set a 1
#	    string length
#	    set b 2
#	}
#}
#rswitch {1 %s 1} {
#    ==  {
#	    set a 1
#	    expr {[string length]}
#	    set b 2
#	}
#}

# -------------------------------------------------------------------------
# Clean up the tests

::tcltest::cleanupTests
return

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

Changes to modules/control/tclIndex.

12
13
14
15
16
17
18

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]]








>
12
13
14
15
16
17
18
19
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]]
set auto_index(::control::waitForAny) [list source [file join $dir wait-for-any.tcl]]

Added modules/control/wait-for-any.tcl.







































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
# control.tcl --
#
#       The control package, providing a vwait that takes multiple
#       variables.
#
# Taken from the tcler's wiki (http://mini.net/tcl/1302.html) by kenstir
# and enhanced.  Submitted as a proposed new package to
# tcllib.sourceforge.net on 7/30/01.
#
# Original author: Donald Porter.  BBH added the timeout option.  Kenstir
# added the return value to detect what variables changed, the packaging,
# standard formatting, and the help text.
#
# TODO
#       * Write control::unwindProtect.  I've always wanted one.
#         --7/30/01 kenstir
#
# $Id: wait-for-any.tcl,v 1.1.2.1 2005/05/24 15:08:51 dgp Exp $

namespace eval control {
    variable WaitForAnyKey 0
}

# control::waitForAny --
#
#       Like [vwait], but takes multiple variables and/or optional
#       timeout.  Allows you to detect which variable or variables got set
#       during the vwait.
#
# Usage:
#       waitForAny ?timeout? variable ?variable ...?
#
# Arguments:
#       timeout  - If the first argument is an integer, it specifies a
#                  timeout.  If the timeout expires, waitForAny returns
#                  "timeout".
#       variable - One or more fully scoped variable names.  A change to
#                  any of these variables will cause waitForAny to
#                  return.
#
# Returns:
#       A list of the variables that got set, or the string "timeout" to
#       indicate that the timeout expired without any variables being
#       set.
#
proc control::waitForAny {args} {
    variable WaitForAnyArray
    variable WaitForAnyKey

    # If first arg is a number, it specifies the timeout.
    if {[string is integer [lindex $args 0]]} {
        set timeout [lindex $args 0]
        set args [lrange $args 1 end]
    }

    # Create a trigger script that will be cause vwait to return.  The
    # [lappend] command is used here to capture all args appended by
    # [trace].
    set index Key[incr WaitForAnyKey]
    set trigger [namespace code [list lappend WaitForAnyArray($index)]]

    # Create the traces.
    # Note that we use [concat $trigger $var] to make sure the trace gets
    # called with the original name of the variable.  Otherwise, the use
    # of an upvar'd alias could prevent us from knowing which variable got
    # set.
    foreach var $args {
        uplevel \#0 [list trace variable $var w [concat $trigger $var]]
    }

    # Set timer if user requested a timeout.
    if {[info exists timeout]} {
        set timerId [after $timeout $trigger]
    }
    vwait [namespace which -variable WaitForAnyArray]($index)

    # Figure out which triggers fired during the vwait.
    set ret {}
    if {[info exists WaitForAnyArray($index)]} {
        # Looks like a variable or variables got set.  But, we aren't
        # sure yet; the list can be empty.  The format of this list is
        # determined by the trace command.
        foreach {vwaitName name1 name2 op} $WaitForAnyArray($index) {
            # Avoid duplicates.  Sometimes the trace gets invoked
            # multiple times.  I would use [lsort -unique], but I have to
            # support tcl8.2.3 for now.
            if {[lsearch -exact $ret $vwaitName] == -1} {
                lappend ret $vwaitName
            }
        }
    }
    if {[llength $ret] == 0} {
        # No variables got set.  We timed out.
        set ret timeout
    }

    # Remove all traces.
    foreach var $args {
        uplevel \#0 [list trace vdelete $var w [concat $trigger $var]]
    }

    # Cancel the timer.
    if {[info exists timerId]} {
        after cancel $timerId
    }

    # Cleanup.
    unset WaitForAnyArray($index)

    return $ret
}

# Local Variables:
# tcl-indent-level:4
# End:

Added modules/control/wait-for-any.test.

































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
# control.test --
#
#       Unit tests for the control package.
#
# Original author: kenstir
#
# $Id: wait-for-any.test,v 1.1.2.1 2005/05/24 15:08:51 dgp Exp $

# Standard tcltest startup.
# 8/2/01 kenstir: Due to tcltest-1.0 strangeness, this doesn't successfully
# import the ::tcltest::test proc.  Switching to fully-qualified name.
#if {[lsearch [namespace children] ::tcltest] == -1} {
#    package require tcltest
#    namespace import ::tcltest::*
#}
package require tcltest

# Source our pkg file.
set dirname [file dirname [info script]]
source [file join $dirname control.tcl]
package require control
namespace import -force control::*

::tcltest::test wait-scalar {wait for 1 scalar} {
    after 0 {set ::a0 1}
    waitForAny ::a0
} {::a0}

::tcltest::test wait-scalar-namespace {wait for a scalar in a namespace} {
    after 0 {set ::control::a0 1}
    waitForAny ::control::a0
} {::control::a0}

::tcltest::test wait-multiple-scalars {wait for multiple scalars} {
    # Kick off a bunch of events to happen in the near future.  Keep track
    # of outstanding events in array `arr'.
    after 2000 {set ::a 1} ; set arr(::a) 1
    after 2000 {set ::b 1} ; set arr(::b) 1
    after 2000 {set ::c 1} ; set arr(::c) 1
    after 1000 {set ::d 1} ; set arr(::d) 1
    after 0000 {set ::e 1} ; set arr(::e) 1

    # Loop until no more events are outstanding.
    while {[array size arr] > 0} {
        puts "Waiting for: [lsort [array names arr]]"
        set r [eval waitForAny [array names arr]]
        puts "Got [llength $r] results: $r"
        foreach e $r {
            unset arr($e)
        }
    }

    # Any problems will manifest as errors, so we don't expect any results.
} {}

::tcltest::test wait-timeout {wait with timeout} {
    after 2000 {set ::f 1}

    set r [waitForAny 10 ::f]
    puts "Got [llength $r] results: $r"

    set r2 [waitForAny ::f]
    puts "Got [llength $r2] results: $r2"

    list $r $r2
} {timeout ::f}

::tcltest::test wait-timeout-2 {wait with timeout that doesn't generate a timeout} {
    after 0 {set ::f 1}

    set r [waitForAny 1000 ::f]
    puts "Got [llength $r] results: $r"

    set r
} {::f}

::tcltest::test wait-array-index {wait on array(index)} {
    after 2000 {set ::g(a) 1}
    set r [waitForAny ::g(a)]
    puts "Got [llength $r] results: $r"
    set r
} {::g(a)}

::tcltest::test wait-entire-array {wait on entire array} {
    set outstandingEvents 0
    after 0 {set ::h(a) 1} ; incr outstandingEvents
    after 0 {set ::i(a) 1} ; incr outstandingEvents
    while {$outstandingEvents > 0} {
        set r [waitForAny ::h ::i]
        puts "Got [llength $r] results: $r"
        incr outstandingEvents -[llength $r]
    }

    # Any problems will manifest as errors, so we don't expect any results.
} {}

::tcltest::test neg-extra-wait {wait when no events are outstanding} {knownBug} {
    # This wait should throw with "would wait forever".  I'm not sure why,
    # but that error doesn't happen on Windows 2000/tcl8.3.3; instead,
    # vwait waits forever.
    set caught [catch {waitForAny ::a} result]
    puts result=$result
    list $caught [string match {*would wait forever} $result]
} {1 1}

::tcltest::test wait-scalar-upvar {wait for 1 scalar aliased through an upvar} {
    upvar 0 ::a0 my_a
    after 0 {set my_a 1}
    waitForAny ::a0
} {::a0}

::tcltest::test wait-array-upvar {wait on array(index) aliased through an upvar} {
    upvar 0 ::g my_g
    after 0 {set my_g(a) 1}
    set r [waitForAny ::g(a)]
    puts "Got [llength $r] results: $r"
    set r
} {::g(a)}

# Waiting separately for two scalars does not work.  The 2nd waitForAny
# results in "would wait forever", because by that time, the 2nd `after'
# was already reaped.  This needs to be handled by one call to
# waitForAny.
#::tcltest::test wait-scalar-separately {wait for 2 scalars separately} {
#    after 0 {set a 1}
#    after 0 {set b 1}
#    set r [waitForAny a]
#    set r2 [waitForAny b]
#    list $r $r2
#} {a b}

::tcltest::test wait-no-duplicates {multiple sets still only cause a single return} {
    after 0 {set a 1 ; set a 2}
    after 0 {set a 3}
    set r [waitForAny a]
    list $r $a
} {a 3}

::tcltest::cleanupTests
return

# Local Variables:
# tcl-indent-level:4
# End:

Deleted modules/counter/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
2003-04-11  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* counter.tcl (counter::names): Use string map instead of regsub.
	Require Tcl 8.2 as a consequence.

2003-01-16  Andreas Kupries  <[email protected]>

	* counter.man: More semantic markup, less visual one.

2002-08-30  Andreas Kupries  <[email protected]>

	* counter.tcl: Updated 'info exist' to 'info exists'.

2002-04-16  Andreas Kupries  <[email protected]>

	* counter.man: Added doctools manpage.

2001-09-05  Andreas Kupries  <[email protected]>

	* counter.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-07-10  Andreas Kupries <[email protected]>

	* counter.tcl: Frink 2.2 run, fixed dubious code.

2001-07-09  Brent Welch <[email protected]>

	* counter.test: Fixed histlog test

2001-06-21  Andreas Kupries <[email protected]>

	* counter.tcl: Fixed dubious code reported by frink.

2000-10-04  Brent Welch <[email protected]>

	* counter.tcl: Fixed bug in counter::MergeDay

2000-10-03  Brent Welch <[email protected]>

	* counter.tcl: Fixed bug in label format for daily graph.

2000-10-02  Brent Welch <[email protected]>

	* NAME CHANGE from "stats" to "counter"
	* counter.tcl: Changed shading of histogram labels.

2000-10-02  Brent Welch <[email protected]>

	* modules/stats/stats.tcl: Added stats::htmlHistDisplayRow
	so that the calling page could define the overall table structure.

2000-10-01  Brent Welch <[email protected]>

	* modules/stats/stats.tcl: Fixed calculation of hourBase
	and minuteBase when secsPerMinute was not 60.

2000-09-23  Brent Welch <[email protected]>

	* modules/stats/stats.tcl: Time-based histograms were
	not displaying the 23rd hour nor the 59th minute.

2000-09-22  Brent Welch <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* Created this module.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































Deleted modules/counter/counter.man.

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

Keep a grouped counter where the name of the histogram bucket is
passed into [cmd ::counter::count].

[lst_item "[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.

[lst_item "[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.

[lst_item "[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.

[lst_item "[option -lastn] [arg N]"]

Save the last [arg N] values of the counter to maintain a "running
average" over the last [arg N] values.

[lst_item "[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]
[lst_item [option -total]]

Return the total value of the counter.  This is the default if

[arg args] is not specified.

[lst_item [option -totalVar]]

Return the name of the total variable.  Useful for specifying with
-textvariable in a Tk widget.

[lst_item [option -N]]

Return the number of samples accumulated into the counter.

[lst_item [option -avg]]

Return the average of samples accumulated into the counter.

[lst_item [option -avgn]]

Return the average over the last [arg N] samples taken.  The [arg N]
value is set in the [cmd ::counter::init] call.

[lst_item "[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.

[lst_item [option -histVar]]

Return the name of the histogram array variable.

[lst_item [option -histHour]]

Return the complete hourly histogram in array get format sorted by
bucket.

[lst_item [option -histHourVar]]

Return the name of the hourly histogram array variable.

[lst_item [option -histDay]]

Return the complete daily histogram in array get format sorted by
bucket.

[lst_item [option -histDayVar]]

Return the name of the daily histogram array variable.

[lst_item [option -resetDate]]

Return the clock seconds value recorded when the
counter was last reset.

[lst_item [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]
[lst_item "[option -title] [arg string]"]

Label to display above bar chart

[lst_item "[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.

[lst_item "[option -images] [arg url]"]

URL of /images directory.

[lst_item "[option -gif] [arg filename]"]

Image for normal histogram bars.  The [arg filename] is relative to
the [option -images] directory.

[lst_item "[option -ongif] [arg filename]"]

Image for the active histogram bar.  The [arg filename] is relative to
the [option -images] directory.

[lst_item "[option -max] [arg N]"]

Maximum number of value-based buckets to display.

[lst_item "[option -height] [arg N]"]

Pixel height of the highest bar.

[lst_item "[option -width] [arg N]"]

Pixel width of each bar.

[lst_item "[option -skip] [arg N]"]

Buckets to skip when labeling value-based histograms.

[lst_item "[option -format] [arg string]"]

Format used to display labels of buckets.

[lst_item "[option -text] [arg boolean]"]

If 1, a text version of the histogram is dumped, otherwise a graphical
one is generated.

[list_end]
[list_end]

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































Deleted modules/counter/counter.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: counter.n,v 1.3 2001/08/02 16:38:06 andreas_kupries Exp $
'\" 
.so man.macros
.TH counter n 1.0 Counter "Counters and Histograms"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::counter \- Procedures for counters and histograms.
.SH SYNOPSIS
\fBpackage require Tcl 8\fR
.sp
\fBpackage require counter ?2.0?\fR
.sp
\fBcounter::init\fR \fItag\fR \fIargs\fR
.sp
\fBcounter::count\fR \fItag {delta 1} args\fR
.sp
\fBcounter::reset\fR \fItag\fR
.sp
\fBcounter::get\fR \fItag args\fR
.sp
\fBcounter::start\fR \fItag\fR
.sp
\fBcounter::stop\fR \fItag\fR
.sp
\fBcounter::exists\fR \fItag\fR
.sp
\fBcounter::names\fR \fItag\fR
.sp
\fBcounter::histHtmlDisplay\fR \fItag args\fR
.BE
.SH DESCRIPTION
.PP
The \fB::counter\fR package provides a counter facility and
can compute statistics and histograms over the collected data.

.TP
\fBcounter::init\fR \fItag args\fR
This defines a counter with the name \fItag\fP.
The \fIargs\fP determines the characteristics of the counter.
The \fIargs\fP are

.TP
\fB-group\fR \fIname\fR
Keep a grouped counter where the name of the histogram bucket
is passed into \fBcounter::count\fP.

.TP
\fB-hist\fR \fIbucketsize\fR
Accumulate the counter into histogram buckets of size
\fIbucketsize\fP.  For example, if the samples are millisecond
time values and \fIbucketsize\fP 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.

.TP
\fB-hist2x\fR \fIbucketsize\fR
Accumulate the statistic into histogram buckets.
The size of the first bucket is 
\fIbucketsize\fP, each other bucket holds values
2 times the size of the previous bucket.
For example, if \fIbucketsize\fP 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.

.TP
\fB-hist10x\fR \fIbucketsize\fR
Accumulate the statistic into histogram buckets.
The size of the first bucket is 
\fIbucketsize\fP, each other bucket holds values
10 times the size of the previous bucket.
For example, if \fIbucketsize\fP 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.

.TP
\fB-lastn\fR \fIN\fR
Save the last \fIN\fP values of the counter to maintain
a "running average" over the last \fIN\fP values.

.TP
\fB-timehist\fR \fIsecsPerMinute\fR
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
\fIsecsPerMinute\fP, 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
\fIsecsPerMinute\fP value seen by the package is used for all subsequent
time-based histograms.

.TP
\fBcounter::count\fR \fItag {delta 1} {instance {}}\fR
Increment the counter identified by \fItag\fP.
The default increment is 1, although you can increment
by any value, integer or real, by specifying \fIdelta\fP.
You must declare each counter with \fBcounter::init\fP to define
the characteristics of counter before you start to use it.
If the counter type is \fB-group\fP, then the counter
identified by \fIinstance\fP is incremented.

.TP
\fBcounter::start\fR \fItag instance\fR
Record the starting time of an interval.
The \fItag\fP is the name of the counter defined as
a \fB-hist\fP value-based histogram.
The \fIinstance\fP is used to distinguish this interval from
any other intervals that might be overlapping this one.

.TP
\fBcounter::stop\fR \fItag instance\fR
Record the ending time of an interval.
The delta time since the corresponding \fBcountStart\fP call
for \fIinstance\fP is recorded in the histogram
identified by \fItag\fP.

.TP
\fBcounter::get\fR \fItag args\fR
Return statistics about a counter
identified by \fItag\fP.
The \fIargs\fP determine what value to return:
.TP
\fB-total\fP
Return the total value of the counter.  This is the default
if \fIargs\fP is not specified.
.TP
\fB-totalVar\fP
Return the name of the total variable.  Useful for
specifying with -textvariable in a Tk widget.
.TP
\fB-N\fP
Return the number of samples accumulated into the counter.
.TP
\fB-avg\fP
Return the average of samples accumulated into the counter.
.TP
\fB-avgn\fP
Return the average over the last \fIN\fP samples taken.
The \fIN\fP value is set in the \fBcounter::init\fP call.
.TP
\fB-hist\fP \fIbucket\fP
If \fIbucket\fP 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.
.TP
\fB-histVar\fP
Return the name of the histogram array variable.
.TP
\fB-histHour\fP
Return the complete hourly histogram
in array get format sorted by bucket.
.TP
\fB-histHourVar\fP
Return the name of the hourly histogram array variable.
.TP
\fB-histDay\fP
Return the complete daily histogram
in array get format sorted by bucket.
.TP
\fB-histDayVar\fP
Return the name of the daily histogram array variable.
.TP
\fB-resetDate\fP
Return the clock seconds value recorded when the
counter was last reset.
.TP
\fB-all\fP
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.

.TP
\fBcounter::exists\fR \fItag\fR
Returns 1 if the counter is defined.

.TP
\fBcounter::names\fR
Returns a list of all counters defined.

.TP
\fBcounter::histHtmlDisplay\fR \fItag args\fR
Generate HTML to display a histogram for a counter.
The \fIargs\fP control the format of the display.
They are:

.TP
\fB-title\fI string\fP
Label to display above bar chart
.TP
\fB-unit\fI unit\fP
Specify \fBminutes\fP, \fBhours\fP, or \fBdays\fP for the time-base histograms.
For value-based histograms, the \fIunit\fP is used in the title.
.TP
\fB-images\fI url\fP
URL of /images directory.
.TP
\fB-gif\fI filename\fP
Image for normal histogram bars.
The \fIfilename\fP is relative to the \fP-images\fP directory.
.TP
\fB-ongif\fI filename\fP
Image for the active histogram bar.
The \fIfilename\fP is relative to the \fP-images\fP directory.
.TP
\fB-max\fI N\fP
Maximum number of value-based buckets to display.
.TP
\fB-height\fI N\fP
Pixel height of the highest bar.
.TP
\fB-width\fI N\fP
Pixel width of each bar.
.TP
\fB-skip\fI N\fP
Buckets to skip when labeling value-based histograms.
.TP
\fB-format\fI string\fP
Format used to display labels of buckets.
.TP
\fB-text\fI boolean\fP
If 1, a text version of the histogram is dumped,
otherwise a graphical one is generated.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































Deleted modules/counter/counter.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
# 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.11 2003/04/11 19:01:06 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 {
	    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
	    set v [string map {{::counter::T-} {}} $v]
	    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 mx $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>Maxmum</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) 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
    set time($instance) [list [clock clicks] \
	    [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 now [list [clock clicks] \
	    [clock seconds]]
    set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}]
    set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}]
    unset time($instance)

    if {$delMicros < 0} {
	set delMicros [expr {1000000 + $delMicros}]
	incr delSecond -1
	if {$delSecond < 0} {
	    set delSecond 0
	}
    }
    counter::count $tag [$func $delSecond.[format %06d $delMicros]]
}

# ::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.1

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/counter/counter.test.

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

package require tcltest
namespace import -force ::tcltest::*

catch {namespace delete counter}

proc Stamp {tag} {
    puts stderr "[clock format [clock seconds]] [clock clicks -milliseconds] $tag"
}

set myFile [file join [file dirname [info script]] counter.tcl]
source $myFile
package require counter 2.0

test counter-1.1 {counter::init} {
    catch {counter::init} err
} {1}

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 {counter::count} {
    counter::init avg
    counter::count avg 2.2
    counter::count avg 3.3
    counter::count avg 9.8
    counter::get avg -avg
} {5.1}

test counter-avg {counter::count} {
    counter::init avg
    counter::get avg -avg
} {0}

test counter-lastn {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 {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 {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 {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 {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
    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} {
    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
	}
    }
    set result
} {0 2 1 4 2 8}

puts "timehist [time {counter::count hits} 100]"

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}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































Deleted modules/counter/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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.1 [list source [file join $dir counter.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/crc/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
2003-04-02  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* crc16.tcl: Fixed a bug in the option handling error info.

2003-01-25  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* crc32.man: More semantic markup, less visual one.
	* cksum.man:
	* sum.man:

2003-01-07  Pat Thoyts  <[email protected]>

	* crc32.test: Fixed another 8.3 - 8.4 wide integer problem.

2003-01-06  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* cksum.tcl: Enabled processing in chunks to reduce memory
	consumption.

2002-09-26  Pat Thoyts  <[email protected]>

	* crc32.tcl: Fix to SF bug #579026: implementing file processing
	in small chunks to reduce memory usage.

2002-01-23  Pat Thoyts  <[email protected]>

	* crc16.tcl, crc16.test, crc16.man: Added CRC16 package

2002-01-23  Pat Thoyts  <[email protected]>

	* crc32.test, sum.test, cksum.test: Fixed SF bug #507242: failing
	tests when running 'make test'

2002-01-17  Pat Thoyts  <[email protected]>

	* crc32.n: formatting fixes
	* sum.n: added new manual page for package sum

2002-01-16  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* crc32.tcl: implemented usage of Trf crc-zlib if available.

2002-01-09  Pat Thoyts  <[email protected]>

	* crc32.tcl: initial version modified from the Wiki source.
	* crc32.n: initial version of man page
	* crc32.test: initial version of crc32 tests.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































Deleted modules/crc/cksum.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
[manpage_begin cksum n 1.0.1]
[copyright {2002, Pat Thoyts}]
[moddesc   {cksum}]
[titledesc {calculate a cksum(1) compatible checksum}]
[require Tcl 8.2]
[require cksum [opt 1.0.1]]
[description]
[para]

This package provides a Tcl-only 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 "-format [arg format]"] [arg message]]
[call [cmd ::crc::cksum] [opt "-format [arg format]"] "-filename [arg file]"]

The command takes string data or a 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]

[lst_item "-filename [arg name]"]

Return a checksum for the file contents instead of for parameter data.

[lst_item "-format [arg string]"]

Return the checksum using an alternative format template.

[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
}]

[see_also sum(n) crc32(n)]
[section AUTHORS]
Pat Thoyts

[keywords cksum checksum crc crc32 {cyclic redundancy check} {data integrity} security]
[manpage_end]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































Deleted modules/crc/cksum.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
'\"
'\" Generated from file 'cksum.man' by tcllib/doctools with format 'nroff'
'\" Copyright (c) 2002, Pat Thoyts
'\"
.so man.macros
.TH "cksum" n 1.0.1  "cksum"
.BS
.SH "NAME"
cksum \- calculate a cksum(1) compatible checksum
.SH "SYNOPSIS"
package require \fBTcl  8.2\fR
.sp
package require \fBcksum  ?1.0.1?\fR
.sp
\fB::crc::cksum\fR ?-format \fIformat\fR? \fImessage\fR\fR
.sp
\fB::crc::cksum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
This package provides a Tcl-only 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.
.SH "COMMANDS"
.TP
\fB::crc::cksum\fR ?-format \fIformat\fR? \fImessage\fR\fR
.TP
\fB::crc::cksum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR
The command takes string data or a file name and returns a checksum
value calculated using the \fBcksum(1)\fR algorithm. The result is
formatted using the \fIformat\fR(n) specifier provided or as an
unsigned integer (%u) by default.
.SH "OPTIONS"
.TP
-filename \fIname\fR
Return a checksum for the file contents instead of for parameter data.
.TP
-format \fIstring\fR
Return the checksum using an alternative format template.
.SH "EXAMPLES"
.PP
.nf
% crc::cksum "Hello, World!"
2609532967
.fi
.PP
.nf
% crc::cksum -format 0x%X "Hello, World!"
0x9B8A5027
.fi
.PP
.nf
% crc::cksum -file cksum.tcl
1828321145
.fi
.SH "SEE ALSO"
sum(n), crc32(n)
.SH "AUTHORS"
Pat Thoyts
.SH "KEYWORDS"
cksum, checksum, crc, crc32, cyclic redundancy check, data integrity, security
.SH "COPYRIGHT"
.nf
Copyright (c) 2002, Pat Thoyts
.fi

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































Deleted modules/crc/cksum.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.
# -------------------------------------------------------------------------
# $Id: cksum.tcl,v 1.3 2003/01/26 00:16:03 patthoyts Exp $

package require Tcl 8.2;                # tcl minimum version

namespace eval ::crc {
    variable cksum_version 1.0.1

    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 ]
}

# Description:
#  Calculate a cksum(1) compatible 32 bit checksum for the input data.
#  
#  This procedure has been broken into two parts to permit working on
#  a file in small sections.
#
proc ::crc::Cksum {s} {
    set t 0
    set l 0
    Cksum_chunk s t l
    return [Cksum_finalize t l]
}

proc ::crc::Cksum_chunk {data_var sum_var len_var} {
    variable cksum_tbl
    upvar $data_var s
    upvar $sum_var t
    upvar $len_var l

    binary scan $s c* r
    foreach {n} $r {
        set t [expr {($t << 8)
                     ^ [lindex $cksum_tbl [expr {
                                                 (($t >> 24) \
                                                      ^ ($n & 0xFF)) & 0xFF
                                             }]]}]
        incr l
    }
}

proc ::crc::Cksum_finalize {sum_var len_var} {
    variable cksum_tbl
    upvar $sum_var t
    upvar $len_var l
    for {set i $l} {$i > 0} {set i [expr {$i>>8}]} {
        set t [expr {($t << 8) \
                         ^ [lindex $cksum_tbl \
                                [expr {(($t >> 24) ^ $i) & 0xFF}]]}]
    }
    return [expr {~$t & 0xFFFFFFFF}]
}

# 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} {
    set filename {}
    set format %u
    set chunksize 10240
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -fi* {
                set filename [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -fo* {
                set format [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -ch* -
            -bu* {
                set chunksize [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 -filename or -format"
            }
        }
        set args [lreplace $args 0 0]
    }

    if {$filename != {}} {
        set cksum 0
        set cklen 0
        set f [open $filename r]
        fconfigure $f -translation binary
        while {![eof $f]} {
            set chunk [read $f $chunksize]
            Cksum_chunk chunk cksum cklen
        }
        close $f
        set r [Cksum_finalize cksum cklen]
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong # args: should be \
                 \"cksum ?-format string? -file name | data\""
        }
        set r [Cksum [lindex $args 0]]
    }
    return [format $format $r]
}

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

package provide cksum $::crc::cksum_version

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




















































































































































































































































































































































































Deleted modules/crc/cksum.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
# cksum.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.2 2002/01/23 20:56:30 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require cksum

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

test cksum-1.0 {cksum with no parameters } {
    catch {::crc::cksum} result
    set result
} {wrong # args: should be  "cksum ?-format string? -file name | data"}

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

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}
::tcltest::cleanupTests

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































Deleted modules/crc/crc16.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
[manpage_begin crc16 n 1.0.1]
[copyright {2002, Pat Thoyts}]
[moddesc   {Cyclic Redundancy Check (crc16)}]
[titledesc {Perform a 16bit Cyclic Redundancy Check}]
[require Tcl 8.2]
[require crc16 [opt 1.0.1]]
[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]"]

The command takes 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.

[list_end]

[section OPTIONS]

[list_begin definitions]

[lst_item "-filename [arg name]"]

Return a checksum for the file contents instead of for parameter data.

[lst_item "-format [arg string]"]

Return the checksum using an alternative format template.

[lst_item "-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)

[lst_item "-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.

[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
}]

[see_also sum(n) cksum(n) crc32(n)]
[section AUTHORS]
Pat Thoyts

[keywords cksum checksum crc crc32 crc16 {cyclic redundancy check} {data integrity} security]
[manpage_end]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































Deleted modules/crc/crc16.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
# crc16.tcl -- Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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 CITT version of CRC-16.
#
# See http://www.microconsultants.com/tips/crc/crc.txt for the reference
# implementation and http://www.embedded.com/internet/0001/0001connect.htm
# for another good discussion of why things are the way they are.
#
# Checks: a crc for the string "123456789" should give:
#   CRC16:     0xBB3D
#   CRC-CCITT: 0x29B1
#   CRC-32:    0xCBF43926
#
# eg: crc::crc16 "123456789"
#     crc::crc-ccitt "123456789"
# or  crc::crc16 -file tclsh.exe
#
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
# $Id: crc16.tcl,v 1.5 2003/02/02 21:57:21 patthoyts Exp $

package require Tcl 8.2;                # tcl minimum version

namespace eval ::crc {
    
    namespace export crc16 crc-ccitt crc-32

    variable version_crc16 1.0.1

    # Standard CRC generator polynomials.
    variable polynomial
    set polynomial(crc16) [expr {(1<<16) | (1<<15) | (1<<2) | 1}]
    set polynomial(citt)  [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]} {
        for {set v 1} {$v != 0} {set signbit $v; set v [expr {$v<<1}]} {}
    }
}

# -------------------------------------------------------------------------
# Generate a CRC lookup table.
# This creates a CRC algorithm lookup lable 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/CITT: Crc_table 16 $crc::polynomial(citt)  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 0xFFFF}} {
    variable table
    if {![info exists table(citt)]} {
        variable polynomial
        set table(citt) [Crc_table 16 $polynomial(citt) 0]
    }

    return [Crc $s 16 [namespace current]::table(citt) $seed 0 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 {} 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] }
            -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] }
            -- { Pop args ; break }
            default {
                set options [join [lsort [array names opts]] ", -"]
                return -code error "bad option $option:\
                       must be one of -$options"
            }
        }
        Pop args
    }

    if {$opts(filename) != {}} {
        set r $opts(seed)
        set f [open $opts(filename) r]
        fconfigure $f -translation binary
        while {![eof $f]} {
            set chunk [read $f 4096]
            set r [$opts(impl) $chunk $r]
        }
        close $f
    } 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 crc -impl [namespace origin CRC16] $args]
}

proc ::crc::crc-ccitt {args} {
    return [eval crc -impl [namespace origin CRC-CCITT] -seed 0xFFFF $args]
}

proc ::crc::crc-32 {args} {
    return [eval crc -impl [namespace origin CRC-32] -seed 0xFFFFFFFF $args]
}

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

package provide crc16 $crc::version_crc16

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






















































































































































































































































































































































































































































































































































Deleted modules/crc/crc16.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
# crc16.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.1 2002/09/25 23:43:58 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require crc16

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

test crc16-1.0 {crc16 with no parameters } {
    catch {::crc::crc16} result
    string match "wrong # args: *" $result
} {1}

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

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} {
	::crc::crc16 $msg
    } $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} {
	::crc::crc16 -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 crc16-4.0 {crc16 file option} {
    set r1 [::crc::crc16 -file $crc::testfile]
    set r2 [::crc::crc16 [crc::loaddata $crc::testfile]]
    if {$r1 != $r2} {
        set r "differing results: $r1 != $r2"
    } else {
        set r ok
    }
} {ok}

test crc16-5.0 {crc implementation option} {
    proc crc::junk {s seed} {
        return 0
    }

    ::crc::crc16 -impl crc::junk {Hello, World!}
} {0}

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

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} {
	::crc::crc-ccitt -format 0x%X $msg
    } $expected
}

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

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} {
	::crc::crc-32 -format 0x%X $msg
    } $expected
}
# -------------------------------------------------------------------------

catch {unset crc::filename}
::tcltest::cleanupTests

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































Deleted modules/crc/crc32.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
[manpage_begin crc32 n 1.0.1]
[copyright {2002, Pat Thoyts}]
[moddesc   {Cyclic Redundancy Check (crc32)}]
[titledesc {Perform a 32bit Cyclic Redundancy Check}]
[require Tcl 8.2]
[require crc32 [opt 1.0.1]]
[description]
[para]

This package provides a Tcl-only implementation of the CRC-32
algorithm based upon information provided at
http://www.naaccr.org/standard/crc32/document.html

If the [package Trf] package is available then the [cmd crc-zlib]
command is used to perform the calculation.

[section COMMANDS]

[list_begin definitions]

[call [cmd ::crc::crc32] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] [arg message]]
[call [cmd ::crc::crc32] [opt "-format [arg format]"] [opt "-seed [arg value]"] [opt "-implementation [arg procname]"] "-filename [arg file]"]

The command takes string data or a file name and returns a checksum
value calculated using the CRC-32 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]

[lst_item "-filename [arg name]"]

Return a checksum for the file contents instead of for parameter data.

[lst_item "-format [arg string]"]

Return the checksum using an alternative format template.

[lst_item "-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.

[nl]

Note that as the [package Trf] command [cmd crc-zlib] cannot accept a
seed value, use of this option will force the use of the Tcl only
implementation.

[lst_item "-implementation [arg procname]"]

This hook is provided to allow users to provide their own
implementation (perhaps a C compiled extension) or to explicitly
request use of the Tcl only implementation when [package Trf] is
installed (by setting [arg "-implementation crc::Crc32_tcl"]. The
procedure specfied is called with two parameters. The first is the
data to be checksummed and the second is the seed value. A 32bit
integer is expected as the result.

[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
}]

[see_also sum(n) cksum(n) crc16(n)]
[section AUTHORS]
Pat Thoyts

[keywords cksum checksum crc crc32 {cyclic redundancy check} {data integrity} security]
[manpage_end]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































Deleted modules/crc/crc32.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
'\" crc32.n - Copyright (c) 2002 Pat Thoyts <[email protected]>
'\" 
'\" -------------------------------------------------------------------------
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" -------------------------------------------------------------------------
'\" RCS: @(#) $Id: crc32.n,v 1.5 2003/01/26 00:16:03 patthoyts Exp $
'\" 
.so man.macros
.TH "crc32" n 1.0.1 tcllib "Cyclic Redundancy Check (crc32)"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
::crc::crc32 \- Perform a 32bit Cyclic Redundancy Check
.SH "SYNOPSIS"
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require crc32 ?1.0.1?\fR
.sp
\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR
\fI?-implementation procname?\fR \fImessage\fR
.sp
\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR
\fI?-implementation procname?\fR \fI-filename file\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
This package provides a Tcl-only implementation of the CRC-32 algorithm
based upon information provided at 
http://www.naaccr.org/standard/crc32/document.html
If the Trf package is available then the crc-zlib command is used
to perform the calculation.
.SH "COMMANDS"
.TP
\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR
\fI?-implementation procname?\fR \fImessage\fR
.br
.TP
\fB::crc::crc32\fR \fI?-format string?\fR \fI?-seed value?\fR
\fI?-implementation procname?\fR \fI-filename file\fR
The command takes string data or a file name and returns
a checksum value calculated using the CRC-32 algorithm. The result is
formatted using the \fBformat\fR(n) specifier provided or as an unsigned
integer (%u) by default.
.SH "OPTIONS"
.TP
\fI-filename name\fR
Return a checksum for the file contents instead of for parameter data.
.TP
\fI-format string\fR
Return the checksum using an alternative format template.
.TP
\fI-seed value\fR
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.
.sp
Note that as the Trf crc-zlib cannot accept a seed value, use of this
option will force the use of the Tcl only implementation.
.TP
\fI-implementation procname\fR
This hook is provided to allow users to provide their own
implementation (perhaps a C compiled extension) or to explicitly
request use of the Tcl only implementation when Trf is installed (by
setting \fI-impl crc::Crc32_tcl\fR. The procedure specfied is called
with two parameters. The first is the data to be checksummed and the
second is the seed value. A 32bit integer is expected as the result.
.SH "EXAMPLES"
.PP
.CS
\fB% crc::crc32 "Hello, World!"\fR
3964322768
.CE
.PP
.CS
\fB% crc::crc32 -format 0x%X "Hello, World!"\fR
0xEC4AC3D0
.CE
.PP
.CS
\fB% crc::crc32 -file crc32.tcl\fR
483919716
.CE
.SH "SEE ALSO"
sum(n), cksum(n)

.SH "AUTHORS"
Wayland Augur, Pat Thoyts

.SH "KEYWORDS"
cksum, checksum, crc, crc32, cyclic redundancy check, data integrity, security
'\"
'\" Local Variables:
'\"   mode: nroff
'\" End:

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































Deleted modules/crc/crc32.tcl.

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

namespace eval ::crc {
    variable crc32_version 1.0.1

    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]} {
        for {set v 1} {$v != 0} {set signbit $v; set v [expr {$v<<1}]} {}
    }
}

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

# Description:
#  Calculate the CRC-32 checksum of the input data.
#
proc ::crc::Crc32_tcl {s {seed 0xFFFFFFFF}} {
    variable crc32_tbl
    variable signbit
    set signmask [expr {~$signbit>>7}]
    set crcval $seed

    binary scan $s 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}]
}

# Select the Trf using version if Trf is available
if {![catch {package require Trf 2.0}]} {
    # Description:
    #  Use the Trf crc-zlib function to calculate the CRC-32 checksum
    #  and return the correct value according to our byte order.
    #
    proc ::crc::Crc32_trf {s {seed 0xFFFFFFFF}} {
        if {$seed != 0xFFFFFFFF} {
            return -code error "invalid option: the Trf crc32 command cannot\
                                 accept a seed value"
        }
        binary scan [crc-zlib $s] i r
        return $r
    }

    interp alias {} ::crc::Crc32 {} ::crc::Crc32_trf
} else {
    interp alias {} ::crc::Crc32 {} ::crc::Crc32_tcl
}

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

# Description:
#  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} {
    set filename {}
    set format %u
    set seed 0xffffffff
    set impl [namespace origin Crc32]

    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -fi* {
                set filename [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -fo* {
                set format [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -s* {
                set seed [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -i* {
                set impl [uplevel 1 namespace origin [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 -filename, -format, -implementation or -seed"
            }
        }
        set args [lreplace $args 0 0]
    }

    # The Trf implementation doesn't accept an alternative CRC seed so
    # use the Tcl implementation if this is set (unless the user has
    # set it to some other impl).
    if {$seed != 0xffffffff && [string match [namespace origin Crc32] $impl]} {
        set impl [namespace origin Crc32_tcl]
    }

    if {$filename != {}} {
        set r $seed
        set f [open $filename r]
        fconfigure $f -translation binary
        # If we are using Trf - we cannot chunk
        if {[package provide Trf] != {} \
                && [string match [namespace origin Crc32] $impl]} {
            set data [read $f]
            set r [$impl $data $r]
        } else {
            # Process the chunks. We need to undo the final xor
            # to obtain the seed for the following chunk. Then re-apply
            # for the final result.
            while {![eof $f]} {
                set data [read $f 4096]
                set r [$impl $data $r]
                set r [expr {$r ^ 0xFFFFFFFF}]
            }
            set r [expr {$r ^ 0xFFFFFFFF}]
        }
        close $f
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong # args: should be \
                 \"crc32 ?-format string? ?-seed value? ?-impl procname?\
                 -file name | data\""
        }
        set r [$impl [lindex $args 0] $seed]
    }
    
    return [format $format $r]
}

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

package provide crc32 $::crc::crc32_version

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








































































































































































































































































































































































































































































Deleted modules/crc/crc32.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
# crc32.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.5 2003/01/07 00:40:03 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require crc32

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

test crc32-1.0 {crc32 with no parameters } {
    catch {::crc::crc32} result
    string match "wrong # args: *" $result
} {1}

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

foreach {n msg expected} {
    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"
} {
    test crc32-2.$n {crc32 and unsigned integer} {
	::crc::crc32 $msg
    } $expected
}

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

foreach {n msg expected} {
    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"
} {
    test crc32-3.$n {crc32 as hexadecimal string} {
	::crc::crc32 -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 crc32-4.0 {crc32 file option} {
    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}

foreach {n seed msg expected} {
    1    0  ""
    "4294967295"
    2    1  ""
    "4294967294"
    3    0  "Hello, World!"
    "482441901"
    4    1  "Hello, World!"
    "3243746088"
} {
    test crc32-4.$n {crc32 seed option} {
	::crc::crc32 -seed $seed $msg
    } $expected
}


if {![catch {package present Trf 2.0}]} {
    test crc32-5.0 {crc32 check Tcl and Trf version identity} {
        set data [crc::loaddata $crc::testfile]
        set r1 [::crc::Crc32_trf $data]
        set r2 [::crc::Crc32_tcl $data]
        if {int($r1) != int($r2)} {
            set r "differing results: $r1 != $r2"
        } else {
            set r ok
        }
    } {ok}
}

test crc32-6.0 {crc implementation option} {
    proc crc::junk {s seed} {
        return 0
    }

    ::crc::crc32 -impl crc::junk {Hello, World!}
} {0}

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

catch {unset crc::filename}
::tcltest::cleanupTests

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































Deleted modules/crc/crc32bugs.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
# crc32bugs.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.1 2003/04/02 21:24:12 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require crc32
package require crc16

if {[catch {package present Trf}]} {
    puts "crc32bugs (pure Tcl) $::tcl_platform(byteOrder)"
} else {
    puts "crc32bugs (Trf based) $::tcl_platform(byteOrder)"
}

foreach {n msg expected} {
    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"
} {
    test crc32bugs-2.$n {crc32 (Trf and and crc-32 comparison} {
	list [catch {
            list \
                [::crc::crc32 -format %x $msg] \
                [format %x [::crc::Crc32_tcl $msg]] \
                [::crc::crc-32 -format %x $msg]
        } msg] $msg
    } [list 0 [list $expected $expected $expected]]
}

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

::tcltest::cleanupTests

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































Deleted modules/crc/pkgIndex.tcl.

1
2
3
4
5
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded cksum 1.0.1 [list source [file join $dir cksum.tcl]]
package ifneeded crc16 1.0.1 [list source [file join $dir crc16.tcl]]
package ifneeded crc32 1.0.1 [list source [file join $dir crc32.tcl]]
package ifneeded sum 1.0.1 [list source [file join $dir sum.tcl]]
<
<
<
<
<










Deleted modules/crc/sum.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
[manpage_begin sum n 1.0.1]
[copyright {2002, Pat Thoyts}]
[moddesc   {sum}]
[titledesc {calculate a sum(1) compatible checksum}]
[require Tcl 8.2]
[require sum [opt 1.0.1]]
[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 "-format [arg format]"] [arg message]]
[call [cmd ::crc::sum] [opt "-format [arg format]"] "-filename [arg file]"]

The command takes string data or a file name 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]

[lst_item "-filename [arg name]"]

Return a checksum for the file contents instead of for parameter data.

[lst_item "-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
}]

[see_also sum(1) cksum(n) crc32(n)]
[section AUTHORS]
Pat Thoyts

[keywords sum cksum checksum crc crc32 {cyclic redundancy check} {data integrity} security]
[manpage_end]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































Deleted modules/crc/sum.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
'\"
'\" Generated from file 'sum.man' by tcllib/doctools with format 'nroff'
'\" Copyright (c) 2002, Pat Thoyts
'\"
.so man.macros
.TH "sum" n 1.0.1  "sum"
.BS
.SH "NAME"
sum \- calculate a sum(1) compatible checksum
.SH "SYNOPSIS"
package require \fBTcl  8.2\fR
.sp
package require \fBsum  ?1.0.1?\fR
.sp
\fB::crc::sum\fR ?-format \fIformat\fR? \fImessage\fR\fR
.sp
\fB::crc::sum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
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.
.SH "COMMANDS"
.TP
\fB::crc::sum\fR ?-format \fIformat\fR? \fImessage\fR\fR
.TP
\fB::crc::sum\fR ?-format \fIformat\fR? -filename \fIfile\fR\fR
The command takes string data or a file name and returns a checksum
value calculated using the \fBsum(1)\fR algorithm. The result is
formatted using the \fIformat\fR(n) specifier provided or as an
unsigned integer (%u) by default.
.SH "OPTIONS"
.TP
-filename \fIname\fR
Return a checksum for the file contents instead of for parameter data.
.TP
-format \fIstring\fR
Return the checksum using an alternative format template.
.SH "EXAMPLES"
.PP
.nf
% crc::sum "Hello, World!"
37287
.fi
.PP
.nf
% crc::sum -format 0x%X "Hello, World!"
0x91A7
.fi
.PP
.nf
% crc::sum -file sum.tcl
13392
.fi
.SH "SEE ALSO"
sum(1), cksum(n), crc32(n)
.SH "AUTHORS"
Pat Thoyts
.SH "KEYWORDS"
sum, cksum, checksum, crc, crc32, cyclic redundancy check, data integrity, security
.SH "COPYRIGHT"
.nf
Copyright (c) 2002, Pat Thoyts
.fi

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































Deleted modules/crc/sum.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
# sum.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.
# -------------------------------------------------------------------------
# $Id: sum.tcl,v 1.2 2003/01/26 00:16:03 patthoyts Exp $

package require Tcl 8.2;                # tcl minimum version

namespace eval ::crc {
    variable sum_version 1.0.1
    namespace export sum
}

# 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.
#  This is pretty dependant on using a 32 bit accumulator.
#
proc ::crc::sum-sysv {s} {
    set t 0
    binary scan $s c* r
    foreach n $r {
        incr t [expr {$n & 0xFF}]
    }
    return [expr {$t % 0xFFFF}]
}

# 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.
# Notes:
#  Once again this depends upon a 32 bit accumulator.
#
proc ::crc::sum-bsd {s} {
    set t 0
    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
}

# 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} {
    set algorithm [namespace current]::sum-bsd
    set filename {}
    set format %u
    while {[string match -* [lindex $args 0]]} {
        switch -glob -- [lindex $args 0] {
            -b* {
                set algorithm [namespace current]::sum-bsd
            }
            -s* {
                set algorithm [namespace current]::sum-sysv
            }
            -fi* {
                set filename [lindex $args 1]
                set args [lreplace $args 0 0]
            }
            -fo* {
                set format [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 -bsd, -sysv, -filename or -format"
            }
        }
        set args [lreplace $args 0 0]
    }

    if {$filename != {}} {
        set f [open $filename r]
        fconfigure $f -translation binary
        set data [read $f]
        close $f
        set r [$algorithm $data]
    } else {
        if {[llength $args] != 1} {
            return -code error "wrong # args: should be \
                 \"sum ?-bsd|-sysv? ?-format string? -file name | data\""
        }
        set r [$algorithm [lindex $args 0]]
    }
    return [format $format $r]
}

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

package provide sum $::crc::sum_version

# -------------------------------------------------------------------------    
# Local Variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































Deleted modules/crc/sum.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
# sum.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.2 2002/01/23 20:56:30 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require sum

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

test sum-1.0 {sum with no parameters } {
    catch {::crc::sum} result
    set result
} {wrong # args: should be  "sum ?-bsd|-sysv? ?-format string? -file name | data"}

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

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} {
	::crc::sum -bsd $msg
    } $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} {
	::crc::sum -sysv $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 sum-4.0 {sum file option (BSD)} {
    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
    }
} {ok}

test sum-4.1 {sum file option (SysV)} {
    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
    }
} {ok}

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

test sum-5.0 {sum format option (BSD)} {
    crc::sum -bsd -format 0x%X [string repeat x 200]
} {0xF8EE}

test sum-5.1 {sum format option (SysV)} {
    crc::sum -sysv -format 0x%X [string repeat x 200]
} {0x5DC0}

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

catch {unset crc::testfile}
::tcltest::cleanupTests

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

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































Deleted modules/csv/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
2003-03-31  Andreas Kupries  <[email protected]>

	* csv.tcl (split): Fixed bug #709123 reported by Jamie Honan
	  <[email protected]>. The separator character is used
	  in regular epxressions, but was not protected against special
	  interpretation by the RE engine.

2003-01-16  Andreas Kupries  <[email protected]>

	* csv.man: More semantic markup, less visual one.

2002-06-24  Andreas Kupries  <[email protected]>

	* csv.tcl (csv::split): Fixed bug #565051, found by Tod A. olson
	  <[email protected]>. 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  <[email protected]>

	* csv.man: Fixed formatting errors in the doctools manpage.

2002-02-01  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* Bumped version to 0.2

2001-11-16  Andreas Kupries  <[email protected]>

	* csv.n: Applied patch #482570 correcting a typo and adding more
	  cross-references (see also, keywords). Patch provided by Larry
	  Virden <[email protected]>.

2001-11-12  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* csv.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-07-10  Andreas Kupries <[email protected]>

	* csv.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* csv.tcl: Fixed dubious code reported by frink and procheck.

2001-06-19  Andreas Kupries <[email protected]>

	* csv.n: Fixed nroff trouble.

2001-05-01  Andreas Kupries <[email protected]>

	* Committed to CVS head at SF.

2001-04-18  Andreas Kupries <[email protected]>

	* 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 <[email protected]>

	* New module for the processing of CSV lines and files.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































Deleted modules/csv/csv.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
[manpage_begin csv n 0.3]
[copyright {2002 Andreas Kupries <[email protected]>}]
[moddesc   {CSV processing}]
[titledesc {Procedures to handle CSV data.}]
[require Tcl 8.3]
[require csv [opt 0.3]]
[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::join] [arg values] "{[arg sepChar] ,}"]

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 ",".

[call [cmd ::csv::joinlist] [arg values] "{[arg sepChar] ,}"]

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 ",". 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::read2matrix] [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] [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] [arg line] "{[arg sepChar] ,}"]

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 ",".

[call [cmd ::csv::split2matrix] [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]

[lst_item [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.

[lst_item [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.

[lst_item [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] [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"] "{[arg sepChar] ,}"]

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"] "{[arg sepChar] ,}"]

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]

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
(The functions provided here allow any separator character).

[para]

If a value contains itself the separator ",", then it (the value) is
put between "".

[para]

If a value contains ", it is replaced by "".

[section EXAMPLE]

The record

[para]
[example {
123,"123,521.2","Mary says ""Hello, I am Mary"""
}]

[para]
is parsed as follows:

[para]
[example {
a) 123
b) 123,521.2
c) Mary says "Hello, I am Mary"
}]

[see_also matrix queue]
[keywords csv matrix queue package tcllib]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































Deleted modules/csv/csv.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
'\" 
'\" Copyright (c) 2001 by Andreas Kupries <[email protected]>
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: csv.n,v 1.9 2002/02/01 22:59:08 andreas_kupries Exp $
'\" 
.so man.macros
.TH csv n 0.3 Csv "CSV processing"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::csv \- Procedures to handle CSV data
.SH SYNOPSIS
\fBpackage require Tcl 8.3\fR
.sp
\fBpackage require csv ?0.3?\fR
.sp
\fB::csv::join\fR \fIvalues {sepChar ,}\fR
.sp
\fB::csv::joinlist\fR \fIvalues {sepChar ,}\fR
.sp
\fB::csv::read2matrix\fR \fIchan m {sepChar ,} {expand none}\fR
.sp
\fB::csv::read2queue\fR \fIchan q {sepChar ,}\fR
.sp
\fB::csv::report\fR \fIcmd matrix ?chan?\fR
.sp
\fB::csv::split\fR \fIline {sepChar ,}\fR
.sp
\fB::csv::split2matrix\fR \fIq line {sepChar ,} {expand none}\fR
.sp
\fB::csv::split2queue\fR \fIq line {sepChar ,}\fR
.sp
\fB::csv::writematrix\fR \fIm chan {sepChar ,}\fR
.sp
\fB::csv::writequeue\fR \fIq chan {sepChar ,}\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::csv\fR package provides commands to manipulate information in
CSV format (CSV = Comma Separated Values).
.SH COMMANDS
.PP
The following commands are available:
.TP
\fB::csv::join\fR \fIvalues {sepChar ,}\fR
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 ",".
.TP
\fB::csv::joinlist\fR \fIvalues {sepChar ,}\fR
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 ",". 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
\fB::csv::join\fR).
.TP
\fB::csv::read2matrix\fR \fIchan m {sepChar ,} {expand none}\fR
A wrapper around \fB::csv::split2matrix\fR (see below) reading from
CSV-formatted lines from the specified channel (until EOF) and adding
it to the given matrix. For an explanation of the \fIexpand\fR
argument see \fB::csv::split2matrix\fR.
.TP
\fB::csv::read2queue\fR \fIchan q {sepChar ,}\fR
A wrapper around \fB::csv::split2queue\fR (see below) reading from
CSV-formatted lines from the specified channel (until EOF) and adding
it to the given queue.
.TP
\fB::csv::report\fR \fIcmd matrix ?chan?\fR
A report command which can be used by the matrix methods
\fBformat 2string\fR and \fBformat 2chan\fR. For the latter this
command delegates the work to \fB::csv::writematrix\fR. \fIcmd\fR is
expected to be either "printmatrix" or "printmatrix2channel". The
channel argument, \fIchan\fR, has to be present for the latter and
must not be present for the first.
.TP
\fB::csv::split\fR \fIline {sepChar ,}\fR
converts a \fIline\fR 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 \fIsepChar\fR, but this
is optional. The default is ",".
.TP
\fB::csv::split2matrix\fR \fIm line {sepChar ,} {expand none}\fR
The same as \fB::csv::split\fR, but appends the resulting list as a
new row to the matrix \fIm\fR, using the method \fBadd row\fR. The
expansion mode specified via \fIexpand\fR determines how the command
handles a matrix with less columns than contained in \fIline\fR. The
allowed modes are:
.RS
.TP
\fBnone\fR
This is the \fBdefault mode\fR. 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.
.TP
\fBempty\fR
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
\fBnone\fR was set.
.TP
\fBauto\fR
In this mode the command expands the matrix as needed to hold all
columns contained in \Iline\fR. 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.
.RE
.TP
\fB::csv::split2queue\fR \fIq line {sepChar ,}\fR
The same as \fB::csv::split\fR, but appending the resulting list as a
single item to the queue \fIq\fR, using the method \fBput\fR.
.TP
\fB::csv::writematrix\fR \fIm chan {sepChar ,}\fR
A wrapper around \fB::csv::join\fR taking all rows in the matrix
\fIm\fR and writing them CSV formatted into the channel \fIchan\fR.
.TP
\fB::csv::writequeue\fR \fIq chan {sepChar ,}\fR
A wrapper around \fB::csv::join\fR taking all items in the queue
\fIq\fR (assumes that they are lists) and writing them CSV formatted
into the channel \fIchan\fR.
.SH FORMAT
.PP
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
(The functions provided here allow any separator character).
.PP
If a value contains itself the separator ",", then it (the value) is
put between "".
.PP
If a value contains ", it is replaced by "".
.SH EXAMPLE
.PP
The record
.TP
*
123,"123,521.2","Mary says ""Hello, I am Mary"""
.PP
is parsed as follows:
.TP
a)
123
.TP
b)
123,521.2
.TP
c)
Mary says "Hello, I am Mary"
.SH SEE ALSO
.PP
matrix, queue
.SH KEYWORDS
.PP
csv, matrix queue, package, tcllib
'\" -*- nroff -*-
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































Deleted modules/csv/csv.tcl.

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

package require Tcl 8.3
package provide csv 0.3

namespace eval ::csv {
    namespace export join joinlist read2matrix read2queuen 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
#
# Results:
#	A string containing the values in CSV format.

proc ::csv::join {values {sepChar ,}} {
    set out ""
    set sep {}
    foreach val $values {
	if {[string match "*\[\"$sepChar\]*" $val]} {
	    append out $sep\"[string map [list \" \"\"] $val]\"
	} 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
#
# Results:
#	A string containing the values in CSV format, the records
#	separated by newlines.

proc ::csv::joinlist {values {sepChar ,}} {
    set out ""
    foreach record $values {
	# note that this is ::csv::join
	append out "[join $record $sepChar]\n"
    }
    return $out
}

# ::csv::read2matrix --
#
#	A wrapper around "::csv::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 {chan m {sepChar ,} {expand none}} {
    # FR #481023
    # See 'split2matrix' for the available expansion modes.

    while {![eof $chan]} {
	if {[gets $chan line] < 0} {continue}
	if {$line == {}} {continue}
	split2matrix $m $line $sepChar $expand
    }
    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 {chan q {sepChar ,}} {
    while {![eof $chan]} {
	if {[gets $chan line] < 0} {continue}
	if {$line == {}} {continue}
	split2queue $q $line $sepChar
    }
    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 {line {sepChar ,}} {
    # Protect the sepchar from special interpretation by
    # the regex calls below.

    set sepRE \\$sepChar
    regsub -- "$sepRE\"\"$" $line $sepChar\0\"\"\0 line
    regsub -- "^\"\"$sepRE" $line \0\"\"\0$sepChar line
    regsub -all -- {(^\"|\"$)} $line \0 line
    set line [string map [list \
	    $sepChar\"\"\" $sepChar\0\" \
	    \"\"\"$sepChar \"\0$sepChar \
	    \"\"           \" \
	    \"             \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 {m line {sepChar ,} {expand none}} {
    # FR #481023

    set csv [split $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 {q line {sepChar ,}} {
    $q put [split $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 ,}} {
    set n [$m rows]
    for {set r 0} {$r < $n} {incr r} {
	puts $chan [join [$m get row $r] $sepChar]
    }

    # Memory intensive alternative:
    # puts $chan [joinlist [m get rect 0 0 end end] $sepChar]
    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 ,}} {
    while {[$q size] > 0} {
	puts $chan [join [$q get] $sepChar]
    }

    # Memory intensive alternative:
    # puts $chan [joinlist [$q get [$q size]] $sepChar]
    return
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































Deleted modules/csv/csv.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

package require csv
package require struct
puts "csv [package present csv]"
puts "- struct [package present struct]"

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}

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 :
} {
    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

# 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-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}}

tcltest::makeFile {} eval-out1.csv
tcltest::makeFile {} eval-out2.csv
tcltest::makeFile {} eval-out3.csv

test csv-6.1 {writing csv files} {
    set f [open [file join $::tcltest::testsDirectory eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set f [open eval-out1.csv w]
    ::csv::writematrix m $f
    close $f

    set result [tcltest::viewFile eval-out1.csv]
    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-6.2 {writing csv files} {
    set f [open [file join $::tcltest::testsDirectory eval.csv] r]
    ::struct::queue q
    ::csv::read2queue $f q
    close $f

    set f [open eval-out2.csv w]
    ::csv::writequeue q $f
    close $f

    set result [tcltest::viewFile eval-out2.csv]
    q 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.1 {reporting} {
    set f [open [file join $::tcltest::testsDirectory 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 [file join $::tcltest::testsDirectory eval.csv] r]
    ::struct::matrix m
    m add columns 5
    ::csv::read2matrix $f m
    close $f

    set f [open eval-out3.csv w]
    m format 2chan csv::report $f
    close $f

    set result [tcltest::viewFile eval-out3.csv]
    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.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}



::tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/csv/eval.csv.

1
2
3
4
5
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
<
<
<
<
<
<












Deleted modules/csv/mem_debug_bench.csv.

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






















































































































































































































































































































































































































































































































Deleted modules/csv/mem_debug_bench_a.csv.

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
































































































































































































































































































































































































































































































































Deleted modules/csv/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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.3]} {return}
package ifneeded csv 0.3 [list source [file join $dir csv.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/des/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
2003-04-11  Andreas Kupries  <[email protected]>

	* des.tcl:  Fixed bug #614591.

2003-02-11  Pat Thoyts  <[email protected]>

	* 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.
<
<
<
<
<
<
<
<
<
<
<






















Deleted modules/des/des.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
[manpage_begin des n 0.8.0]
[copyright {2003, Jochen C Loewer}]
[moddesc {Data Encryption Standard (DES)}]
[titledesc {Perform DES encryption of Tcl data}]
[require Tcl 8.3]
[require des 0.8]
[description]
[para]

This is a Tcl implementation of the Data Encryption Standard (DES)
written by Jochen Loewer and based upon an implementation by Eric
Young.

[para]

NOTE: this version only implements the Electronic Code Book (ECB) mode
of DES. This is NOT suitable for general use encryption of large
blocks or streams of data. Until Cipher Block Chaining (CBC) or
Cipher/Output Feed Back (CFB / OFB) modes are implemented this should
not be considered for real encryption. The Trfcrypt package has
C-based implementations of these modes.

[section COMMANDS]

[list_begin definitions]
[call [cmd ::DES::des] -mode [arg encode|decode] -key [arg string] "(-file [arg filename] | [opt --] [arg string])"]

Encode or decode a string or file.

[list_end]

[section EXAMPLES]
[para]

[example {
% set ciphertext [DES::des -mode encode -key $secret $plaintext]
% set plaintext [DES::des -mode decode -key $secret $ciphertext]
}]

[para]

[example {
% set ciphertext [DES::des -mode encode -key $secret -file $filename]
% set f [open $filename.des w] ; puts -nonewline $ciphertext ; close $f
% set plaintext [DES::des -mode decode -key $secret -file $filename.des]
}]


[see_also md5(n) sha1(n) ]
[section AUTHORS]
Jochen C Loewer

[keywords DES encryption {data integrity} security]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































Deleted modules/des/des.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
#-----------------------------------------------------------------------------
#   Copyright (C) 1999 Jochen C. Loewer   ([email protected],[email protected])
#-----------------------------------------------------------------------------
#   
#   A pure-Tcl DES implementation.
#
#
#   <OriginalCopyrightNotice>
#   This DES class has been extracted from package Acme.Crypto for use in VNC.
#   The bytebit[] array has been reversed so that the most significant bit
#   in each byte of the key is ignored, not the least significant.  Also the
#   unnecessary odd parity code has been removed.
#   
#   These changes are:
#    Copyright (C) 1999 AT&T Laboratories Cambridge.  All Rights Reserved.
#   
#   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.  
#   
#   DesCipher - the DES encryption method
#   
#   The meat of this code is by Dave Zimmerman <[email protected]>, and is:
#   
#   Copyright (c) 1996 Widget Workshop, Inc. All Rights Reserved.
#   
#   Permission to use, copy, modify, and distribute this software
#   and its documentation for NON-COMMERCIAL or COMMERCIAL purposes and
#   without fee is hereby granted, provided that this copyright notice is kept 
#   intact. 
#   WIDGET WORKSHOP MAKES NO REPRESENTATIONS OR WARRANTIES ABOUT THE SUITABILITY
#   OF THE SOFTWARE, EITHER EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED
#   TO THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
#   PARTICULAR PURPOSE, OR NON-INFRINGEMENT. WIDGET WORKSHOP SHALL NOT BE LIABLE
#   FOR ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
#   DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES.
#   
#   THIS SOFTWARE IS NOT DESIGNED OR INTENDED FOR USE OR RESALE AS ON-LINE
#   CONTROL EQUIPMENT IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE
#   PERFORMANCE, SUCH AS IN THE OPERATION OF NUCLEAR FACILITIES, AIRCRAFT
#   NAVIGATION OR COMMUNICATION SYSTEMS, AIR TRAFFIC CONTROL, DIRECT LIFE
#   SUPPORT MACHINES, OR WEAPONS SYSTEMS, IN WHICH THE FAILURE OF THE
#   SOFTWARE COULD LEAD DIRECTLY TO DEATH, PERSONAL INJURY, OR SEVERE
#   PHYSICAL OR ENVIRONMENTAL DAMAGE ("HIGH RISK ACTIVITIES").  WIDGET WORKSHOP
#   SPECIFICALLY DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR
#   HIGH RISK ACTIVITIES.
#   
#   The rest is:
#   
#   Copyright (C) 1996 by Jef Poskanzer <[email protected]>.  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 THE AUTHOR AND CONTRIBUTORS `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 THE AUTHOR 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.
#   
#   Visit the ACME Labs Java page for up-to-date versions of this and other
#   fine Java utilities: http:#   www.acme.com/java/
#   </OriginalCopyrightNotice>
#
#
#   $Log: des.tcl,v $
#   Revision 1.2  2003/04/11 18:55:43  andreas_kupries
#
#   	* des.tcl:  Fixed bug #614591.
#
#   Revision 1.1  2003/02/11 23:32:44  patthoyts
#   Initial import of des package.
#
#
#
#   written by Jochen Loewer
#   January 17, 2002
#
#-----------------------------------------------------------------------------


#-----------------------------------------------------------------------------
#  usage:
#
#    to encrypt a 8 byte block:
#    --------------------------
# 
#      DES::GetKey -encrypt <password> encryptKeysArray
#      DES::GetKey -encryptVNC <password> encryptKeysArray
#    
#      set encryptedBlock [DES::DoBlock <PlainText8ByteBlock> encryptKeysArray]
#
#
#    to encrypt a 8 byte block:
#    --------------------------
# 
#      DES::GetKey -decrypt <password> decryptKeysArray
#    
#      set plainText [DES::DoBlock <Encrypted8ByteBlock> decryptKeysArray]
#
#-----------------------------------------------------------------------------


## TODO: Check for weak keys: see http://www.cs.wm.edu/~hallyn/des/weak

namespace eval ::DES {

  variable version 0.8.0

  namespace export GetKey DesBlock

  #-------------------------------------------------------------------------
  #   setup lookup tables once
  #
  #-------------------------------------------------------------------------
  foreach { varName values } {
      bytebitOrig { 0x80 0x40 0x20 0x10 0x08 0x04 0x02 0x01 }
      bytebitVNC  { 0x01 0x02 0x04 0x08 0x10 0x20 0x40 0x80 } 
      bigbyte {
        0x800000 0x400000 0x200000 0x100000
        0x080000 0x040000 0x020000 0x010000
        0x008000 0x004000 0x002000 0x001000
        0x000800 0x000400 0x000200 0x000100
        0x000080 0x000040 0x000020 0x000010
        0x000008 0x000004 0x000002 0x000001
      }
      pc1 {
        56 48 40 32 24 16  8
         0 57 49 41 33 25 17
         9  1 58 50 42 34 26
        18 10  2 59 51 43 35
        62 54 46 38 30 22 14
         6 61 53 45 37 29 21
        13  5 60 52 44 36 28
        20 12  4 27 19 11  3
      }
      pc2 {
        13 16 10 23  0  4 
         2 27 14  5 20  9  
        22 18 11  3 25  7 
        15  6 26 19 12  1  
        40 51 30 36 46 54 
        29 39 50 44 32 47 
        43 48 38 55 33 52 
        45 41 49 35 28 31
      }
      totrot { 1 2 4 6 8 10 12 14 15 17 19 21 23 25 27 28 }      
      SP1A {
        0x01010400 0x00000000 0x00010000 0x01010404
        0x01010004 0x00010404 0x00000004 0x00010000
        0x00000400 0x01010400 0x01010404 0x00000400
        0x01000404 0x01010004 0x01000000 0x00000004
        0x00000404 0x01000400 0x01000400 0x00010400
        0x00010400 0x01010000 0x01010000 0x01000404
        0x00010004 0x01000004 0x01000004 0x00010004
        0x00000000 0x00000404 0x00010404 0x01000000
        0x00010000 0x01010404 0x00000004 0x01010000
        0x01010400 0x01000000 0x01000000 0x00000400
        0x01010004 0x00010000 0x00010400 0x01000004
        0x00000400 0x00000004 0x01000404 0x00010404
        0x01010404 0x00010004 0x01010000 0x01000404
        0x01000004 0x00000404 0x00010404 0x01010400
        0x00000404 0x01000400 0x01000400 0x00000000
        0x00010004 0x00010400 0x00000000 0x01010004 }
      SP2A {
        0x80108020 0x80008000 0x00008000 0x00108020
        0x00100000 0x00000020 0x80100020 0x80008020
        0x80000020 0x80108020 0x80108000 0x80000000
        0x80008000 0x00100000 0x00000020 0x80100020
        0x00108000 0x00100020 0x80008020 0x00000000
        0x80000000 0x00008000 0x00108020 0x80100000
        0x00100020 0x80000020 0x00000000 0x00108000
        0x00008020 0x80108000 0x80100000 0x00008020
        0x00000000 0x00108020 0x80100020 0x00100000
        0x80008020 0x80100000 0x80108000 0x00008000
        0x80100000 0x80008000 0x00000020 0x80108020
        0x00108020 0x00000020 0x00008000 0x80000000
        0x00008020 0x80108000 0x00100000 0x80000020
        0x00100020 0x80008020 0x80000020 0x00100020
        0x00108000 0x00000000 0x80008000 0x00008020
        0x80000000 0x80100020 0x80108020 0x00108000 }
      SP3A {
        0x00000208 0x08020200 0x00000000 0x08020008
        0x08000200 0x00000000 0x00020208 0x08000200
        0x00020008 0x08000008 0x08000008 0x00020000
        0x08020208 0x00020008 0x08020000 0x00000208
        0x08000000 0x00000008 0x08020200 0x00000200
        0x00020200 0x08020000 0x08020008 0x00020208
        0x08000208 0x00020200 0x00020000 0x08000208
        0x00000008 0x08020208 0x00000200 0x08000000
        0x08020200 0x08000000 0x00020008 0x00000208
        0x00020000 0x08020200 0x08000200 0x00000000
        0x00000200 0x00020008 0x08020208 0x08000200
        0x08000008 0x00000200 0x00000000 0x08020008
        0x08000208 0x00020000 0x08000000 0x08020208
        0x00000008 0x00020208 0x00020200 0x08000008
        0x08020000 0x08000208 0x00000208 0x08020000
        0x00020208 0x00000008 0x08020008 0x00020200 }
      SP4A {
        0x00802001 0x00002081 0x00002081 0x00000080
        0x00802080 0x00800081 0x00800001 0x00002001
        0x00000000 0x00802000 0x00802000 0x00802081
        0x00000081 0x00000000 0x00800080 0x00800001
        0x00000001 0x00002000 0x00800000 0x00802001
        0x00000080 0x00800000 0x00002001 0x00002080
        0x00800081 0x00000001 0x00002080 0x00800080
        0x00002000 0x00802080 0x00802081 0x00000081
        0x00800080 0x00800001 0x00802000 0x00802081
        0x00000081 0x00000000 0x00000000 0x00802000
        0x00002080 0x00800080 0x00800081 0x00000001
        0x00802001 0x00002081 0x00002081 0x00000080
        0x00802081 0x00000081 0x00000001 0x00002000
        0x00800001 0x00002001 0x00802080 0x00800081
        0x00002001 0x00002080 0x00800000 0x00802001
        0x00000080 0x00800000 0x00002000 0x00802080 }
      SP5A {
        0x00000100 0x02080100 0x02080000 0x42000100
        0x00080000 0x00000100 0x40000000 0x02080000
        0x40080100 0x00080000 0x02000100 0x40080100
        0x42000100 0x42080000 0x00080100 0x40000000
        0x02000000 0x40080000 0x40080000 0x00000000
        0x40000100 0x42080100 0x42080100 0x02000100
        0x42080000 0x40000100 0x00000000 0x42000000
        0x02080100 0x02000000 0x42000000 0x00080100
        0x00080000 0x42000100 0x00000100 0x02000000
        0x40000000 0x02080000 0x42000100 0x40080100
        0x02000100 0x40000000 0x42080000 0x02080100
        0x40080100 0x00000100 0x02000000 0x42080000
        0x42080100 0x00080100 0x42000000 0x42080100
        0x02080000 0x00000000 0x40080000 0x42000000
        0x00080100 0x02000100 0x40000100 0x00080000
        0x00000000 0x40080000 0x02080100 0x40000100 }
      SP6A {
        0x20000010 0x20400000 0x00004000 0x20404010
        0x20400000 0x00000010 0x20404010 0x00400000
        0x20004000 0x00404010 0x00400000 0x20000010
        0x00400010 0x20004000 0x20000000 0x00004010
        0x00000000 0x00400010 0x20004010 0x00004000
        0x00404000 0x20004010 0x00000010 0x20400010
        0x20400010 0x00000000 0x00404010 0x20404000
        0x00004010 0x00404000 0x20404000 0x20000000
        0x20004000 0x00000010 0x20400010 0x00404000
        0x20404010 0x00400000 0x00004010 0x20000010
        0x00400000 0x20004000 0x20000000 0x00004010
        0x20000010 0x20404010 0x00404000 0x20400000
        0x00404010 0x20404000 0x00000000 0x20400010
        0x00000010 0x00004000 0x20400000 0x00404010
        0x00004000 0x00400010 0x20004010 0x00000000
        0x20404000 0x20000000 0x00400010 0x20004010 }
      SP7A {
        0x00200000 0x04200002 0x04000802 0x00000000
        0x00000800 0x04000802 0x00200802 0x04200800
        0x04200802 0x00200000 0x00000000 0x04000002
        0x00000002 0x04000000 0x04200002 0x00000802
        0x04000800 0x00200802 0x00200002 0x04000800
        0x04000002 0x04200000 0x04200800 0x00200002
        0x04200000 0x00000800 0x00000802 0x04200802
        0x00200800 0x00000002 0x04000000 0x00200800
        0x04000000 0x00200800 0x00200000 0x04000802
        0x04000802 0x04200002 0x04200002 0x00000002
        0x00200002 0x04000000 0x04000800 0x00200000
        0x04200800 0x00000802 0x00200802 0x04200800
        0x00000802 0x04000002 0x04200802 0x04200000
        0x00200800 0x00000000 0x00000002 0x04200802
        0x00000000 0x00200802 0x04200000 0x00000800
        0x04000002 0x04000800 0x00000800 0x00200002 }
      SP8A {
        0x10001040 0x00001000 0x00040000 0x10041040
        0x10000000 0x10001040 0x00000040 0x10000000
        0x00040040 0x10040000 0x10041040 0x00041000
        0x10041000 0x00041040 0x00001000 0x00000040
        0x10040000 0x10000040 0x10001000 0x00001040
        0x00041000 0x00040040 0x10040040 0x10041000
        0x00001040 0x00000000 0x00000000 0x10040040
        0x10000040 0x10001000 0x00041040 0x00040000
        0x00041040 0x00040000 0x10041000 0x00001000
        0x00000040 0x10040040 0x00001000 0x00041040
        0x10001000 0x00000040 0x10000040 0x10040000
        0x10040040 0x10000000 0x00040000 0x10001040
        0x00000000 0x10041040 0x00040040 0x10000040
        0x10040000 0x10001000 0x10001040 0x00000000
        0x10041040 0x00041000 0x00041000 0x00001040
        0x00001040 0x00040040 0x10000000 0x10041000 }
   } { 
      set i -1
      foreach v $values { set ${varName}([incr i]) [expr $v] }
  }

  #-------------------------------------------------------------------------
  #   get internal keys for a later de-/encrypt phase
  #
  #-------------------------------------------------------------------------
  proc GetKey { mode keyString keys_var } {

      upvar $keys_var keys

      # fill keyString up to at least 8 bytes (pad with NULL bytes!)
      append keyString "\0\0\0\0\0\0\0\0"
      binary scan $keyString c8 bytes
      set i  -1
      foreach b $bytes {
         set keyBlock([incr i]) [expr { $b & 0x0ff }]
      }
      switch -- $mode {
          -encrypt { 
              array set keys [makeInternalKeys keyBlock 1 0]
          }
          -encryptVNC { 
              array set keys [makeInternalKeys keyBlock 1 1]
          }
          -decrypt { 
              array set keys [makeInternalKeys keyBlock 0 0]
          }
          -decryptVNC { 
              array set keys [makeInternalKeys keyBlock 0 1]
          }
          default {
              error "mode must be '-encrypt|-encryptVNC|-decrypt|-decryptVNC' !"
          }
      }    
  }

  #-------------------------------------------------------------------------
  #   appplies DES algorithm on a 8 byte block
  #
  #-------------------------------------------------------------------------
  proc DesBlock { in keys_var } {

      upvar $keys_var keys

      if {[info tclversion] == "8.0"} {
          set l [string length $in]
      } else {
          #set l [string bytelength $in]
          set l [string length $in]
      }
      if {$l != 8} {
          error "DES operates only on blocks of 8 bytes, but got $l bytes!"
      }
      binary scan $in II left right
      return [binary format I* [desAlgorithm $left $right keys]]
  }

  #-------------------------------------------------------------------------
  #   generate internal key array
  #
  #-------------------------------------------------------------------------
  proc makeInternalKeys { keyBlock_var encDec useVNC } {
 
      upvar $keyBlock_var keyBlock

      variable pc1
      variable pc2
      variable totrot
      variable bigbyte
      variable bytebitOrig
      variable bytebitVNC
     
      for { set j  0 } { $j < 56 } { incr j } {
          set l $pc1($j)
          set m [expr $l & 07]
          if {$useVNC} {
              set pc1m($j) [expr { ( ($keyBlock([expr {$l >> 3}]) & $bytebitVNC($m)) != 0 ) ? 1: 0 }]
          } else {
              set pc1m($j) [expr { ( ($keyBlock([expr {$l >> 3}]) & $bytebitOrig($m)) != 0 ) ? 1: 0 }]
          }
      }
      for { set i 0 } { $i < 16 } { incr i } {

          set m [expr { $encDec ? ($i << 1) : ((15-$i) << 1) }]
          set n [expr $m + 1]
          set kn($m) 0 
          set kn($n) 0
          for { set j 0 } { $j < 28 } { incr j } {

              set l [expr { $j + $totrot($i) }]
              if { $l < 28 } { 
                  set pcr($j) $pc1m($l)
              } else {
                  set pcr($j) $pc1m([expr { $l - 28 }])
              }
          }
          for { set j 28 } { $j < 56 } { incr j } {
              set l [expr { $j + $totrot($i) }]
              if { $l < 56 } { 
                  set pcr($j) $pc1m($l)
              } else {
                  set pcr($j) $pc1m([expr { $l - 28 }])
              }
          }
          for { set j 0 } { $j < 24 } { incr j } {
              if {$pcr($pc2($j)) != 0} { 
                  set kn($m) [expr { $kn($m) | $bigbyte($j) }] 
              }
              if {$pcr($pc2([expr $j+24])) != 0} {
                  set kn($n) [expr { $kn($n) | $bigbyte($j) }]
              }
          }
      }
      for { set i 0; set rawi 0; set KnLi 0 } { $i < 16 } { incr i } {
          set raw0 $kn($rawi); incr rawi
          set raw1 $kn($rawi); incr rawi
          set KnL($KnLi) [expr { (($raw0 & 0x00fc0000) <<  6)
                                |(($raw0 & 0x00000fc0) << 10)
                                |(($raw1 & 0x00fc0000) >> 10)
                                |(($raw1 & 0x00000fc0) >>  6) }]
          incr KnLi
          set KnL($KnLi) [expr { (($raw0 & 0x0003f000) <<  12)
                                |(($raw0 & 0x0000003f) <<  16)
                                |(($raw1 & 0x0003f000) >>  4)
                                |( $raw1 & 0x0000003f)        }] 
          incr KnLi
      }
      return [array get KnL]
  }


  #-------------------------------------------------------------------------
  #   applies the DES algorithm to two 4 byte integers (8 byte block)
  #   using the internal de-/encrypt keys
  #
  #-------------------------------------------------------------------------
  proc desAlgorithm { leftt right keys_var } {

      upvar $keys_var keys

      variable SP1A
      variable SP2A
      variable SP3A
      variable SP4A
      variable SP5A
      variable SP6A
      variable SP7A
      variable SP8A

      set keysi 0

      set work  [expr { ((($leftt >> 4)&0x0fffffff) ^ $right) & 0x0f0f0f0f }]
      set right [expr { $right ^ $work }]
      set leftt [expr { $leftt ^ ($work << 4) }]

      set work  [expr { ((($leftt >> 16)&0x0000ffff) ^ $right) & 0x0000ffff }]
      set right [expr { $right ^ $work }]
      set leftt [expr { $leftt ^ ($work << 16) }]

      set work  [expr { ((($right >> 2)&0x3fffffff) ^ $leftt) & 0x33333333 }]
      set leftt [expr { $leftt ^ $work }]
      set right [expr { $right ^ ($work << 2) }]

      set work  [expr { ((($right >> 8)&0x00ffffff) ^ $leftt) & 0x00ff00ff }]
      set leftt [expr { $leftt ^ $work }]
      set right [expr { $right ^ ($work << 8) }]
      set right [expr { ($right << 1) | (($right >> 31) & 1)  }]

      set work  [expr { ($leftt ^ $right) & 0xaaaaaaaa }]
      set leftt [expr { $leftt ^ $work }]
      set right [expr { $right ^ $work }]
      set leftt [expr { ($leftt << 1) | (($leftt >> 31) & 1) }]
  
      for { set round 0 } { $round < 8 } { incr round } {
          set work [expr { ($right << 28) | (($right >> 4)&0x0fffffff) }]
          set work [expr { $work ^ $keys($keysi) } ]
          incr keysi
          set fval [expr {  $SP7A([expr {  $work        & 0x0000003f }])
                          | $SP5A([expr { ($work >>  8) & 0x0000003f }])
                          | $SP3A([expr { ($work >> 16) & 0x0000003f }])
                          | $SP1A([expr { ($work >> 24) & 0x0000003f }]) }]
          set work [expr { $right ^ $keys($keysi) }]
          incr keysi
          set fval [expr {  $fval 
                          | $SP8A([expr {  $work        & 0x0000003f }])
                          | $SP6A([expr { ($work >>  8) & 0x0000003f }])
                          | $SP4A([expr { ($work >> 16) & 0x0000003f }])
                          | $SP2A([expr { ($work >> 24) & 0x0000003f }]) }]
          set leftt [expr { $leftt ^ $fval }]
          set work  [expr { ($leftt << 28) | (($leftt >> 4)&0x0fffffff) }]
          set work  [expr { $work ^ $keys($keysi) }]
          incr keysi
          set fval [expr {  $SP7A([expr {  $work        & 0x0000003f }])
                          | $SP5A([expr { ($work >>  8) & 0x0000003f }])
                          | $SP3A([expr { ($work >> 16) & 0x0000003f }])
                          | $SP1A([expr { ($work >> 24) & 0x0000003f }]) }]
          set work [expr { $leftt ^ $keys($keysi) }]
          incr keysi
          set fval [expr {  $fval 
                          | $SP8A([expr {  $work        & 0x0000003f }])
                          | $SP6A([expr { ($work >>  8) & 0x0000003f }])
                          | $SP4A([expr { ($work >> 16) & 0x0000003f }])
                          | $SP2A([expr { ($work >> 24) & 0x0000003f }]) }]
          set right [expr { $right ^ $fval }]
      }
      set right [expr { ($right << 31) | (($right >> 1)&0x7fffffff) }]
      set work  [expr { ($leftt ^ $right) & 0xaaaaaaaa }]
      set leftt [expr { $leftt ^ $work }]
      set right [expr { $right ^ $work }]

      set leftt [expr { ($leftt << 31) | (($leftt >> 1)&0x7fffffff) }]

      set work  [expr { ((($leftt >> 8)&0x00ffffff) ^ $right) & 0x00ff00ff }]
      set right [expr { $right ^ $work }]
      set leftt [expr { $leftt ^ ($work << 8) }]

      set work  [expr { ((($leftt >> 2)&0x3fffffff) ^ $right) & 0x33333333 }]
      set right [expr { $right ^ $work }]
      set leftt [expr { $leftt ^ ($work << 2) }]

      set work  [expr { ((($right >> 16)&0x0000ffff) ^ $leftt) & 0x0000ffff }]
      set leftt [expr { $leftt ^ $work }]
      set right [expr { $right ^ ($work << 16) }]
      
      set work  [expr { ((($right >>  4)&0x0fffffff) ^ $leftt) & 0x0f0f0f0f }]
      set leftt [expr { ($leftt ^ $work) &0xffffffff }]
      set right [expr { ($right ^ ($work << 4)) & 0xffffffff }]
      
      return [list $right $leftt]
  }

}

# -------------------------------------------------------------------------
# Description:
#  Pop the nth element off a list. Used in options processing.
#
proc ::DES::Pop {varname {nth 0}} {
    upvar $varname args
    set r [lindex $args $nth]
    set args [lreplace $args $nth $nth]
    return $r
}

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

proc ::DES::des {args} {
    array set opts [list filename {} mode {encode} key {I love Tcl!}]
    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]}
            -k* {set opts(key) [Pop args 1]}
            --   {Pop args ; break }
            default {
                set err [join [lsort [array names opts]] ", -"]
                return -code error "bad option [lindex $args 0]:\
                       must be one of -$options"
            }
        }
        Pop args
    }

    # Build the key
    switch -exact -- $opts(mode) {
        encode { GetKey -encrypt $opts(key) key }
        decode { GetKey -decrypt $opts(key) key }
        default {
            return -code error "bad option \"$opts(mode)\": \
                   must be either \"encode\" or \"decode\""
        }
    }

    set r {}
    if {$opts(filename) != {}} {
        set f [open $opts(filename) r]
        fconfigure $f -translation binary
        while {![eof $f]} {
            set d [read $f 8]
            if {[set n [string length $d]] < 8} {
                append d [string repeat \0 [expr {8 - $n}]]
            }
            append r [DesBlock $d key]
        }
        close $f
    } else {
        set data [lindex $args 0]
        if {[set n [expr {[string length $data] % 8}]] != 0} {
            append data [string repeat \0 [expr {8 - $n}]]
        }
        for {set n 0} {$n < [string length $data]} {incr n 8} {
            append r [DesBlock [string range $data $n [expr {$n + 7}]] key]
        }
    }

    return $r
}

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

package provide des $DES::version

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




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/des/des.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require des

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

catch {unset in out key}

array set key {
    1	0000000000000000
    2	FFFFFFFFFFFFFFFF
    3	3000000000000000
    4	1111111111111111
    5	0123456789ABCDEF
    6	1111111111111111
    7	0000000000000000
    8	FEDCBA9876543210
    9	7CA110454A1A6E57
    10	0131D9619DC1376E
    11	07A1133E4A0B2686
    12	3849674C2602319E
    13	04B915BA43FEB5B6
    14	0113B970FD34F2CE
    15	0170F175468FB5E6
    16	43297FAD38E373FE
    17	07A7137045DA2A16
    18	04689104C2FD3B2F
    19	37D06BB516CB7546
    20	1F08260D1AC2465E
    21	584023641ABA6176
    22	025816164629B007
    23	49793EBC79B3258F
    24	4FB05E1515AB73A7
    25	49E95D6D4CA229BF
    26	018310DC409B26D6
    27	1C587F1C13924FEF
    28	0101010101010101
    29	1F1F1F1F0E0E0E0E
    30	E0FEE0FEF1FEF1FE
    31	0000000000000000
    32	FFFFFFFFFFFFFFFF
    33	0123456789ABCDEF
    34	FEDCBA9876543210
}

array set in {
    1	0000000000000000
    2	FFFFFFFFFFFFFFFF
    3	1000000000000001
    4	1111111111111111
    5	1111111111111111
    6	0123456789ABCDEF
    7	0000000000000000
    8	0123456789ABCDEF
    9	01A1D6D039776742
    10	5CD54CA83DEF57DA
    11	0248D43806F67172
    12	51454B582DDF440A
    13	42FD443059577FA2
    14	059B5E0851CF143A
    15	0756D8E0774761D2
    16	762514B829BF486A
    17	3BDD119049372802
    18	26955F6835AF609A
    19	164D5E404F275232
    20	6B056E18759F5CCA
    21	004BD6EF09176062
    22	480D39006EE762F2
    23	437540C8698F3CFA
    24	072D43A077075292
    25	02FE55778117F12A
    26	1D9D5C5018F728C2
    27	305532286D6F295A
    28	0123456789ABCDEF
    29	0123456789ABCDEF
    30	0123456789ABCDEF
    31	FFFFFFFFFFFFFFFF
    32	0000000000000000
    33	0000000000000000
    34	FFFFFFFFFFFFFFFF
}

array set out {
    1	8CA64DE9C1B123A7
    2	7359B2163E4EDC58
    3	958E6E627A05557B
    4	F40379AB9E0EC533
    5	17668DFC7292532D
    6	8A5AE1F81AB8F2DD
    7	8CA64DE9C1B123A7
    8	ED39D950FA74BCC4
    9	690F5B0D9A26939B
    10	7A389D10354BD271
    11	868EBB51CAB4599A
    12	7178876E01F19B2A
    13	AF37FB421F8C4095
    14	86A560F10EC6D85B
    15	0CD3DA020021DC09
    16	EA676B2CB7DB2B7A
    17	DFD64A815CAF1A0F
    18	5C513C9C4886C088
    19	0A2AEEAE3FF4AB77
    20	EF1BF03E5DFA575A
    21	88BF0DB6D70DEE56
    22	A1F9915541020B56
    23	6FBF1CAFCFFD0556
    24	2F22E49BAB7CA1AC
    25	5A6B612CC26CCE4A
    26	5F4C038ED12B2E41
    27	63FAC0D034D9F793
    28	617B3A0CE8F07100
    29	DB958605F8C8C606
    30	EDBFD1C66C29CCC7
    31	355550B2150E2451
    32	CAAAAF4DEAF1DBAE
    33	D5D44FF720683D0D
    34	2A2BB008DF97C2F2
}


foreach i [lsort [array names key]] {
    test des-1.$i {des encryption (ECB)} {
        set k [binary format H* $key($i)]
        set p [binary format H* $in($i)]
        set s [DES::des -mode encode -key $k $p]
        binary scan $s H* h
        string toupper $h
    } $out($i)
}

foreach i [lsort [array names key]] {
    test des-2.$i {des decryption (ECB)} {
        set k [binary format H* $key($i)]
        set p [binary format H* $out($i)]
        set s [DES::des -mode decode -key $k $p]
        binary scan $s H* h
        string toupper $h
    } $in($i)
}

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

#catch {unset in out key}
::tcltest::cleanupTests

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































Deleted modules/des/pkgIndex.tcl.

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

package ifneeded des 0.8 [list source [file join $dir des.tcl]]
<
<
<
<
<
<
<
<
<
<
<






















Deleted modules/devtools/ChangeLog.

1
2
3
4
2003-04-09  Andreas Kupries  <[email protected]>

	* New module. 
	* First contents are support for sub-processes in testsuites.
<
<
<
<








Deleted modules/devtools/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

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. Well, one actually,
currently, "pop3".
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































Deleted modules/devtools/microserv.tcl.

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

# ####################################################################

# Code for a simple server listening on one part for a connection and
# then performing a fixed sequence of responses, independent of the
# queries sent to it. This should make the testing of servers and
# clients for a particular protocol easier. Especially as this
# micro-server is better suited to push data tailored to generating
# boundary conditions on the other side of the connection than a true
# client/server for the protoco.

# ####################################################################

package require log

namespace eval ::muserv {
    variable port      ; # Port to listen on for protocol connections.
    variable responses ; # Script to run for a protocol connection.
    variable sock      ; # Channel of the protocol connection.
    variable lastline  ; # Last line received on the protocol connection.
    variable ctrlsock  ; # Channel of the control connection.
    variable trace     ; # Recorded trace of activity.
}

# ####################################################################
# Public functionality

# ::muserv::listen --
#
#	Setup the server to listen for a connection

proc ::muserv::listen {theport theresponses} {
    variable port      $theport
    variable responses $theresponses
    set lsock [socket -server ::muserv::New $theport]
    set port  [lindex [fconfigure $lsock -sockname] end]
    log::log debug "muserv | Listening on :: $port"
    return $port
}

proc ::muserv::control {control} {
    variable ctrlsock $control
    return
}

proc ::muserv::control {control} {
    variable ctrlsock $control
    return
}

proc ::muserv::gettrace {} {
    variable ctrlsock
    variable trace

    puts  $ctrlsock [join $trace \n]
    puts  $ctrlsock __EOTrace__
    flush $ctrlsock
    return
}

# ####################################################################
# Private functionality

# ::muserv::New --
#
#	Store the connection information and setup the dialog

proc ::muserv::New {thesock addr port} {
    variable sock $thesock
    log::log debug "muserv | Connected    :: $addr $port :: $sock"
    after 0 ::muserv::Dialog
    return
}

# ::muserv::Dialog --
#
#	Run the pre-programmed responses on the connection

proc ::muserv::Dialog {} {
    variable responses
    variable sock

    log::log debug "muserv | Dialog       :: ..."
    catch {eval  $responses}
    log::log debug "muserv | Dialog       :: ... done"
    catch {close $sock}
    set sock ""
    log::log debug "muserv | Connection   :: Closed"
    return
}

# ####################################################################
# Low-level interaction and configuration commands

proc ::muserv::__Trace       {line} {
    variable trace
    log::log debug "muserv | Logging ____ :: == $line"
    lappend trace $line
    return
}
proc ::muserv::__Send        {line} {
    log::log debug "muserv | Sending ____ :: >> $line"
    variable sock ; puts $sock $line ; flush $sock
    return
}
proc ::muserv::__Wait        {}     {
    variable lastline
    variable sock ; gets $sock line ; set lastline $line
    log::log debug "muserv | Received ___ :: << $line"
    return
}
proc ::muserv::__Reconfigure {args} {
    log::log debug "muserv | Reconfigure  :: [join $args]"
    variable sock ; eval fconfigure $sock $args
    return
}
proc ::muserv::__Got {} {variable lastline ; __Trace $lastline}

# ####################################################################
# Semi-public functionality: Commands available to program the dialog.

proc ::muserv::CrLf        {}     {__Reconfigure -translation crlf   ; return}
proc ::muserv::Binary      {}     {__Reconfigure -translation binary ; return}
proc ::muserv::Send        {line} {         __Send $line ; return}
proc ::muserv::Respond     {line} {__Wait ; __Send $line ; return}
proc ::muserv::Wait        {}     {__Wait ;                return}
proc ::muserv::RespondLog  {line} {__Wait ; __Got ; __Send $line ; return}
proc ::muserv::WaitLog     {}     {__Wait ; __Got ;                return}

# ####################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































Deleted modules/devtools/musub.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

# Generic framework for a microserv.tcl based server/
#
# Copyright (c) 2003 by Andreas Kupries <[email protected]>

# A server using this framework can be controlled through a socket
# connection they open to a listening socket which was opened by the
# creator of the server. The port to connect to is provided in the
# variable 'ctrlport'.
#
# The port the server will be listening on is specified through the
# contents of the variable 'port'. The actual port chosen is written
# to the control connection, as the first information. This also
# serves as a signal that the server is ready.
#
# The server will exit when the control connection is closed by the
# spawning process.
#
#           | data to be set by the creator of a full server.
#           |
# logfile   |
# port      |
# responses |
# ctrlport  |

# ##########################################################
# Setup logging
# Prevent log messages for now, or log into server log.

set         log [open $logfile w]
fconfigure $log -buffering none
proc log {txt} {global log ; puts $log $txt}
proc log__ {l t} {log "$l $t"}

log__ debug "musub  | framework entered"

package require log ; # tcllib | logging
::log::lvCmdForall log__
#::log::lvSuppress info
#::log::lvSuppress notice
#::log::lvSuppress debug
#::log::lvSuppress warning

log__ debug "musub  | logging activated"

# ##########################################################
# Handle activity on the control connection
# - closing => exit server
# - read single line, evaluate command in that line ! trusted

proc done {chan} {
    if {[eof $chan]} {
	log__ debug "musub  | shutdown through caller, control connection was closed"
	exit
    }

    set n [gets $chan line]
    log__ debug "musub  | gets = $n ($line)"

    if {$n < 0} {return}
    set line [string trim $line]
    if {$line == {}} {return}

    log__ debug "musub  | eval ($line)"
    uplevel #0 $line
    return
}

# ##########################################################
# Setup the control connection.

set         control [socket localhost $ctrlport]
fileevent  $control readable [list done $control]
fconfigure $control -blocking 0

muserv::control $control

log__ debug "musub  | control connection up"

# ##########################################################
# Start server ...
# If the incoming port number is 0 the return value
# will contain the actual port the server is listening on.

set             port [muserv::listen $port $responses]
puts  $control $port
flush $control

log__ debug "musub  | server ready and waiting ..."

vwait __forever__
log__ debug "musub  | reached infinity, closing :)"
exit

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































Deleted modules/devtools/subserv.tcl.

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

# ####################################################################

# Code for the easy creation of sub-processes from a testsuite to
# perform some actions on behalf of it. General sub-processes and
# socket servers, the latter are based on "microserv.tcl".

# ####################################################################

namespace eval ::subserv {
    set here [file dirname [info script]] ; # To find muserv.tcl

    variable mPipe ; set mPipe ""
    variable mCtrl ; set mCtrol 0
    variable mLog  ; set mLog ""
}

package require log ; # tracing | tcllib

# ####################################################################
# API

# ::subserv::pipe --
#
#	Start a generic sub-process, controllable by its pipe.

proc ::subserv::pipe {pathToScriptFile} {
    log::log debug "subserv | pipe         | $pathToScriptFile"
    global tcl_platform
    switch -exact $tcl_platform(platform) {
	windows {return [open "|\"[info nameofexecutable]\" $pathToScriptFile" r+]}
	default {return [open "|[info nameofexecutable]     $pathToScriptFile" r+]}
    }
}

# ::subserv::exec --
#
#	Start a generic sub-process, via plain exec, asked to listen on port for
#	control commands.

proc ::subserv::exec {pathToScriptFile port} {
    global tcl_platform
    exec [info nameofexecutable] $pathToScriptFile $port &
    after 100
    return [socket localhost $port]
}

# ::subserv::muserv --
#
#	Create a micro server which can be run later.

proc ::subserv::muserv {pathToScriptFile ctrlport port responses} {
    variable here

    log::log debug "subserv | muserv       | $pathToScriptFile $ctrlport $port [llength $responses]"

    catch {file delete -force $pathToScriptFile}
    set script [open $pathToScriptFile w]

    puts $script ""
    puts $script "# -----------------------------------------------"
    puts $script "# Configuration of \"musub.tcl\""
    puts $script ""
    puts $script [list set logfile   $pathToScriptFile.log]
    puts $script [list set port      $port]
    puts $script [list set responses $responses]
    puts $script [list set ctrlport  $ctrlport]
    puts $script ""
    puts $script "# -----------------------------------------------"
    puts $script ""

    set in [open [file join $here microserv.tcl] r]
    fcopy $in $script
    close $in
    set in [open [file join $here musub.tcl] r]
    fcopy $in $script
    close $in
    close $script
    return
}

# ::subserv::muservSpawn --
#
#	Create a micro server and run it immediately.

proc ::subserv::muservSpawn {pathToScriptFile port responses} {
    variable mPipe
    variable mCtrl

    log::log debug "subserv | muserv spawn | $pathToScriptFile $port [llength $responses]"

    set lsock    [socket -server ::subserv::muservCtrl 0]
    set ctrlport [lindex [fconfigure $lsock -sockname] end]

    log::log debug "subserv | muserv spawn | control on $ctrlport"

    muserv $pathToScriptFile $ctrlport $port $responses

    muservStop
    set mPipe [pipe $pathToScriptFile]

    log::log debug "subserv | muserv spawn | pipe on $mPipe"

    vwait ::subserv::mCtrl
    set     port [gets $mCtrl]

    log::log debug "subserv | muserv spawn | server waiting on $port"

    return $port
}

proc ::subserv::muservCtrl {thesock addr port} {
    variable mCtrl $thesock
    log::log debug "subserv | muserv ctrl  | $addr $port :: $mCtrl"
    return
}

# ::subserv::muservStop --
#
#	Stop a running micro server

proc ::subserv::muservStop {} {
    variable mPipe
    variable mCtrl

    if {$mPipe == {}} {return}

    log::log debug "subserv | muserv stop  | request"

    catch {close $mCtrl}
    catch {close $mPipe}

    log::log debug "subserv | muserv stop  | done"

    after 100 ; # sleep for a 1/10th second to make sure it is gone.
    set mPipe {}
    return
}

# ::subserv::muservLog --
#
#	Get a trace from the micro server

proc ::subserv::muservLog {} {
    variable mCtrl

    log::log debug "subserv | muserv log   | request"

    puts  $mCtrl ::muserv::gettrace
    flush $mCtrl

    log::log debug "subserv | muserv log   | collect"

    set res [list]
    while {1} {
	gets $mCtrl line
	log::log debug "subserv | muserv log   | __ $line"
	if {[string equal __EOTrace__ $line]} {break}
	lappend res $line
    }

    log::log debug "subserv | muserv log   | ok"
    return $res
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































Deleted modules/dns/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
2003-04-14  Pat Thoyts  <[email protected]>

	* dns.tcl: Added error message to the timeout.
	* resolv.tcl: incorporated some of Emmanuel's updated code.

2003-04-12  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* dns.tcl: converted from the log package to logger. Enable UDP as
	the default if available.

2003-02-27  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* dns.tcl: Implemented UDP transmission. Currently not tested
	because tcludp doesn't handle binary data.

2003-01-24  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* dns.man: More semantic markup, less visual one.

2002-08-30  Andreas Kupries  <[email protected]>

	* dns.tcl: Updated 'info exist' to 'info exists'.

2002-06-07  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* dns.man: Added note to manpage regarding DNS via TCP and
	  possible pitfalls.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































Deleted modules/dns/dns-url.txt.

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


Network Working Group                                       S. Josefsson
Internet-Draft                                              RSA Security
Expires: March 29, 2002                               September 28, 2001


                             DNS URI scheme
                        draft-josefsson-dns-url

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 March 29, 2002.

   Distribution of this document is unlimited.  Comments and
   suggestions on this document are encouraged. 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 [3].

Copyright Notice

   Copyright (C) The Internet Society (2001). All Rights Reserved.

Abstract

   This draft describes a URI scheme to locate DNS resources.








Josefsson                Expires March 29, 2002                 [Page 1]

Internet-Draft               DNS URI scheme               September 2001


Table of Contents

   1.  Introduction and Background  . . . . . . . . . . . . . . . . .  3
   2.  URI Scheme . . . . . . . . . . . . . . . . . . . . . . . . . .  3
   3.  URI Scheme Syntax  . . . . . . . . . . . . . . . . . . . . . .  3
   4.  Character Encoding Considerations  . . . . . . . . . . . . . .  4
   5.  Intended Usage . . . . . . . . . . . . . . . . . . . . . . . .  4
   6.  Applications and/or Protocols Using This Scheme  . . . . . . .  4
   7.  Interoperability Considerations  . . . . . . . . . . . . . . .  4
   8.  Security Considerations  . . . . . . . . . . . . . . . . . . .  4
   9.  IANA Considerations  . . . . . . . . . . . . . . . . . . . . .  5
   10. Examples . . . . . . . . . . . . . . . . . . . . . . . . . . .  5
       Author's Address . . . . . . . . . . . . . . . . . . . . . . .  6
       References . . . . . . . . . . . . . . . . . . . . . . . . . .  5
   A.  IANA URI Registration Template . . . . . . . . . . . . . . . .  6
       Full Copyright Statement . . . . . . . . . . . . . . . . . . .  8



































Josefsson                Expires March 29, 2002                 [Page 2]

Internet-Draft               DNS URI scheme               September 2001


1. Introduction and Background

   DNS [1][2] is a widely deployed protocol used to, among other
   things, translate domain names into IP addresses.  More recent work
   has added support for storing cryptographic keys and certificates in
   DNS [6][7].  To be able to locate, for example, certificates via a
   network resource, URIs are often used.  This document describes a
   URI scheme to locate DNS information.  The DNS URI scheme described
   here can be used to reference any DNS data, not only certificates.  

   The following sections are modelled after the Registration Template
   in [8].  The template can be found in Appendix A.

2. URI Scheme

   The name of the URI scheme defined in this document is "dns".

   A DNS URI designates a DNS resource record: By domain name, type and
   class and optionally server.  The DNS URI follows the generic syntax
   from RFC 2396 [5], and is described using ABNF [4] in section 3.

   A DNS URI is of the following general form.  This is intended to
   illustrate, not define, the scheme.

   dns:[//server/]domain[?type=TYPE;class=CLASS]

3. URI Scheme Syntax

   Strings are not case sensitive and free insertion of
   linear-white-space is not permitted.

   dnsurl       = "dns:" [ "//" hostport "/" ] dnsname ["?" query]
                                ; See RFC 2396 for "hostport"  definition

   domainname   = uric
                                ; See RFC 2396 for "uric" definition

   query        = queryelement [";" query]

   queryelement = ( "CLASS=" classval ) | ( "TYPE=" typeval ) |
                  ( 1*alphanum "=" 1*alphanum )

   classval     = 1*digit / "IN" / "CH" / ...
                                ; Any standard DNS class expressed as
                                ; mnemonic or as decimal integer

   typeval      = 1*digit / "A" / "NS" / "MD" / ...
                                ; Any standard DNS type expressed as
                                ; mnemonic or as decimal integer


Josefsson                Expires March 29, 2002                 [Page 3]

Internet-Draft               DNS URI scheme               September 2001


   The digit representation of types and classes SHOULD NOT be used
   when a defined mnemonic for the corresponding value is known.

   Of the "reserved" characters in the "dnsname" element, the "?"
   character MUST be escaped, the rest MAY be escaped. Otherwise, it
   would be impossible to separate a domain name containing "?" from
   the "query" delimiter.

   Unless specified, the "server" is assumed to be locally
   (pre-)configured, and "class" to be the Internet class ("IN"), and
   "type" to be the Address (A) type.

   To resolve a DNS URI using the DNS protocol [2] a query is formed by
   using the domainname, classval and typeval from the URI string (or
   the previously mentioned default values if either classval or
   typeval is missing from the string).  If hostport is given in the
   URI string, this server should receive the DNS query, otherwise the
   default DNS server should receive it.

4. Character Encoding Considerations

   The characters in the URI, in particular the "dnsname", MUST be
   encoded as per the "URI Generic Syntax" RFC [5].

   This URI specification allows all possible DNS names to be encoded
   (of course following the encoding rules of [5]), 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, hostnames in DNS often have certain
   restrictions.  It is up to these application to limit this subset,
   this URI scheme places no restrictions.

5. Intended Usage

   Broad usage. 

6. Applications and/or Protocols Using This Scheme

   E.g. CNRP.

7. Interoperability Considerations

   The data referenced by this URI scheme might be transferred by
   protocols that aren't URI aware (such as the DNS protocol). This is
   not anticipated to have any serious interoperability impact though.

8. Security Considerations

   A DNS URI does not embed confidential information.  If it references


Josefsson                Expires March 29, 2002                 [Page 4]

Internet-Draft               DNS URI scheme               September 2001


   domains in the Internet DNS environment, even the information
   referenced by the URI is public information.  If a DNS URI is used
   within an "internal" DNS environment, the same security
   considerations of the DNS environment apply to the use and handling
   of DNS URIs themselves as well as the data returned by looking up
   these URIs.

   If security related information is referenced by DNS URIs (such as
   certificates stored in DNS), care must be taken to prevent for
   man-in-the-middle attacks that maliciously replace the certificate. 
   Techniques such as Secure DNS may be used.

   This draft does not affect the security considerations related to
   DNS itself.

9. IANA Considerations

   The IANA is asked to register the DNS URI scheme using this document
   as the template in accordance with RFC 2717 [8].

10. Examples

   The following illustrate a DNS query for "www.example.org" for the
   Internet (IN) class and the Address (A) type:

   dns:www.example.org?class=IN;type=A

   The following illustrate a DNS query for "simon.example.org" for the
   CERT type in the Internet (IN) class:

   dns:simon.example.org?type=CERT

   The following illustrate a DNS query for "ftp.example.org" from the
   DNS server "internal-dns.example.org" server, in the Internet (IN)
   class and the address (A) type:

   dns://internal-dns.example.org/ftp.example.org?type=A

   The following illustrate a strange, albeit valid, DNS query:

   dns://internal-dns.example.org/*.%3f%20 %00%25+?type=TXT

Acknowledgement

   Thanks to Michael Mealling, Steve Mattson and Stuart Cheshire for
   comments.

References



Josefsson                Expires March 29, 2002                 [Page 5]

Internet-Draft               DNS URI scheme               September 2001


   [1]  Mockapetris, P., "Domain Names - Concepts and Facilities", RFC
        1034, November 1987.

   [2]  Mockapetris, P., "Domain Names - Implementation and
        Specification", RFC 1035, November 1987.

   [3]  Bradner, S., "Key words for use in RFCs to Indicate Requirement
        Levels", RFC 2119, March 1997.

   [4]  Crocker, D. and P. Overell, "Augmented BNF for Syntax
        Specifications: ABNF", RFC 2234, November 1997.

   [5]  Berners-Lee, T., Fielding, R. and L. Masinter, "Uniform
        Resource Identifiers (URI): Generic Syntax", RFC 2396, August
        1998.

   [6]  Eastlake, D., "Domain Name System Security Extensions", RFC
        2535, March 1999.

   [7]  Eastlake, D. and O. Gudmundsson, "Storing Certificates in the
        Domain Name System (DNS)", RFC 2538, March 1999.

   [8]  Petke, R. and I. King, "Registration Procedures for URL Scheme
        Names", RFC 2717, November 1999.


Author's Address

   Simon Josefsson
   RSA Security
   Arenav�gen 29
   Stockholm  121 29
   Sweden

   Phone: +46 8 7250914
   EMail: [email protected]

Appendix A. IANA URI Registration Template

   URL scheme name: dns

   URL scheme syntax: Section 3

   Character encoding considerations: Section 4

   Intended usage: Section 5

   Applications and/or protocols which use this scheme: Section 5.



Josefsson                Expires March 29, 2002                 [Page 6]

Internet-Draft               DNS URI scheme               September 2001


   Interoperability considerations: Section 7.

   Security considerations: Section 8

   Contact: [email protected]

   Author/Change Controller: IESG












































Josefsson                Expires March 29, 2002                 [Page 7]

Internet-Draft               DNS URI scheme               September 2001


Full Copyright Statement

   Copyright (C) The Internet Society (2001). 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 assigns.

   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
   HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED WARRANTIES OF
   MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
























Josefsson                Expires March 29, 2002                 [Page 8]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/dns/dns.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
# dns.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.
#
# TODO:
#  - When using tcp we should make better use of the open connection and
#    send multiple queries along the same connection.
#
# -------------------------------------------------------------------------
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# -------------------------------------------------------------------------
#
# $Id: dns.tcl,v 1.13 2003/04/13 23:04:00 patthoyts Exp $

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

namespace eval ::dns {
    variable version 1.0.4
    variable rcsid {$Id: dns.tcl,v 1.13 2003/04/13 23:04:00 patthoyts Exp $}

    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}::enable $options(loglevel)
    }

    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
    }

    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
        AXFR 252  MAILB 253  MAILA 254  * 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}::enable $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]
    }
    variable $token
    upvar 0 $token state

    # Setup token/state defaults.
    set state(id)          $id
    set state(query)       $query
    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}
            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 {[package provide udp] == {}} {
            return -code error "udp support is not available, get tcludp"
        }
    }

    BuildMessage $token
    
    if {$state(-protocol) == "tcp"} {
        TcpTransmit $token
        if {$state(-command) == {}} {
            wait $token
        }
    } else {
        UdpTransmit $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 {
                        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)]} {
            if {$AN(type) == "A"} {
                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:
#  Get the status of the request.
#
proc ::dns::status {token} {
    variable $token
    upvar 0 $token state
    return $state(status)
}

# Description:
#  Get the error message. Empty if no error.
#
proc ::dns::error {token} {
    variable $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} {
    variable $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 {}}} {
    variable $token
    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} {
    variable $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} {
    variable $token
    upvar 0 $token state
    if {[info exists state]} {
        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 {
        error "wrong # args: should be \"dump ?option? methodName\""
    }

    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} {
    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 {}

    # 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 {}] ...

    set qname [string trim $state(query) .]
    
    # break up the name into length tagged 'labels'
    foreach part [split $qname .] {
        set label [binary format c [string length $part]]
        append qsection $label $part
    }
    # append the root label and the type flag and query class.
    append qsection [binary format cSS 0 \
            $types($state(-type))\
            $classes($state(-class))]
    incr qdcount

    switch -exact -- $state(opcode) {
        0 {
            # QUERY
            set state(request) [binary format SSSSSS $state(id) \
                [expr {($state(opcode) << 11) | ($state(-recurse) << 8)}] \
                $qdcount 0 0 0]
            append state(request) $qsection
        }
        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) .]]
                }
                default {
                    return -code "inverse query not supported for this type"
                }
            }
        }
        default {
            return -code error "operation not supported"
        }
    }

    return
}

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

# Description:
#  Transmit a DNS request over a tcp connection.
#
proc ::dns::TcpTransmit {token} {
    variable $token
    upvar 0 $token state

    # 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)

    # setup the timeout
    if {$state(-timeout) > 0} {
        set state(after) [after $state(-timeout) \
                              [list [namespace origin reset] \
                                   $token timeout\
                                   "operation timed out"]]
    }

    set s [socket $state(-nameserver) $state(-port)]
    fconfigure $s -blocking 0 -translation binary -buffering none
    set state(sock) $s
    set state(status) connect

    puts -nonewline $s $req

    fileevent $s readable [list [namespace current]::TcpEvent $token]
    
    return $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} {
    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"]]
    }
    
    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 ""}} {
    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} {
    variable $token
    upvar 0 $token state
    set state(status) eof
    Finish $token
}

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

# Description:
#  Process a DNS reply packet (protocol independent)
#
proc ::dns::Receive {token} {
    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
    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 $tok "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}]
                Receive [namespace current]::$id
            } else {
                ${log}::debug "Incomplete tcp read:\
                   [string length $state(reply)] should be $state(size)"
            }
        } err]} {
            Finish $tok "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 $tok "Event error: this can't happen!"
    }
}

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

# Description:
#  file event handler for udp sockets.
proc ::dns::UdpEvent {token} {
    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}]
    Receive [namespace current]::$id
}
    
# -------------------------------------------------------------------------

proc ::dns::Flags {token {varname {}}} {
    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 flafs(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
    variable $token
    upvar 0 $token state

    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]
    lappend r AN $AN
    set NS [ReadAnswer $nNS $state(reply) ndx]
    lappend r NS $NS
    set AR [ReadAnswer $nAR $state(reply) ndx]
    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
}

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

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} {
    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}]]

        switch -- $type {
            A {
                set rdata [join [Expand $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]
            }
        }

        incr index $rdlength
        lappend r type $type class $class ttl $ttl rdlength $rdlength rdata $rdata
        lappend result $r
    }
    return $result
}


# 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 .]
}

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

# Experimental support for finding the nameservers to use on a Windows
# machine
# For unix we can just parse the /etc/resolv.conf if it exists.
# Of couse, some unices use /etc/resolver and other things (NIS for instance)
#
if {$::tcl_platform(platform) == "Windows"} {

proc ::dns::Win32_NameServers {} {
    package require registry
    set base {HKEY_LOCAL_MACHINE\System\CurrentControlSet\Services\Tcpip}
    set param "$base\\Parameters"
    set interfaces "$param\\Interfaces"
    set nameservers {}
    AppendRegistryValue $param NameServer nameservers
    AppendRegistryValue $param DhcpNameServer nameservers
    foreach i [registry keys $interfaces] {
        AppendRegistryValue "$interfaces\\$i" NameServer nameservers
        AppendRegistryValue "$interfaces\\$i" DhcpNameServer nameservers
    }

    # FIX ME: this doesn't preserve the original preference ordering
    return [lsort -unique $nameservers]
}


proc ::dns::AppendRegistryValue {key val listName} {
    upvar $listName lst
    if {![catch {registry get $key $val} v]} {
        set lst [concat $lst $v]
    }
}

}


# -------------------------------------------------------------------------
# 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} {
        set escape     [set [namespace parent [namespace current]]::basic::escape]
        set host       [set [namespace parent [namespace current]]::basic::host]
        set hostOrPort [set [namespace parent [namespace current]]::basic::hostOrPort]

        set class [string map {* \\\\*} \
                       "class=([join [array names ::dns::classes] {|}])"]
        set type  [string map {* \\\\*} \
                       "type=([join [array names ::dns::types] {|}])"]
        set classOrType "(?:${class}|${type})"
        set classOrTypeSpec "(?:${class}|${type})(?:;(?:${class}|${type}))?"

        set 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"
}

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

package provide dns $dns::version

# -------------------------------------------------------------------------
# Local Variables:
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/dns/dns.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
# dns.test - Copyright (C) 2002 Pat Thoyts <[email protected]>
#
# 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.1 2003/01/25 21:05:52 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require dns

# -------------------------------------------------------------------------
# Helpers
# -------------------------------------------------------------------------

proc ::OrderedArrayGet {arrayName} {
    upvar $arrayName a
    set result {}
    foreach name [lsort [array names a]] {
        lappend result $name $a($name)
    }
    return $result
}

# -------------------------------------------------------------------------
# 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 [OrderedArrayGet 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
}


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

rename ::OrderedArrayGet {}
::tcltest::cleanupTests

# Local Variables:
#  mode: tcl
#  indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































Deleted modules/dns/pkgIndex.tcl.

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

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded dns    1.0.4 [list source [file join $dir dns.tcl]]
package ifneeded resolv 1.0.2 [list source [file join $dir resolv.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted modules/dns/resolv.tcl.

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

package require dns 1.0;                # tcllib 1.3

namespace eval ::resolv {
    variable version 1.0.2
    variable rcsid {$Id: resolv.tcl,v 1.4 2003/04/13 23:04:00 patthoyts Exp $}

    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 - [email protected]
#
# 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 - [email protected]
#
# 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 - [email protected]
#
# 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 $::resolv::version

# -------------------------------------------------------------------------
# Local Variables:
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted modules/dns/tcllib_dns.man.

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

The dns package provides a Tcl only Domain Name Service client. You should
refer to RFC 1034 and RFC 1035 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
or 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 get the tcludp
package and get a version that correctly handles binary
data. This should be publicly available shortly.

[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]
[lst_item "[cmd -nameserver] [arg hostname] or [cmd -server] [arg hostname]"]
  Specify an alternative name server for this request.
[lst_item "[cmd -protocol] [arg tcp|udp]"]
  Specify the network protocol to use for this request. Can be one of
  [arg tcp] or [arg udp]. 
[lst_item "[cmd -port] [arg portnum]"]
  Specify an alternative port.
[lst_item "[cmd -search] [arg domainlist]"]
[lst_item "[cmd -timeout] [arg milliseconds]"]
  Override the default timeout.
[lst_item "[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, AXFR, MAILB,
  MAILA and *. See RFC1035 for details about the return values.
[lst_item "[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.
[lst_item "[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].
[lst_item "[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]

[nl]
[call [cmd ::dns::configure] [opt [arg "options"]]]

The ::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]
[lst_item "[cmd -nameserver] [arg hostname]"]
  Set the default name server to be used by all queries. The default is
  localhost.
[lst_item "[cmd -protocol] [arg tcp|udp]"]
  Set the default network protocol to be used. Defaults to tcp.
[lst_item "[cmd -port] [arg portnum]"]
  Set the default port to use on the name server. The default is 53.
[lst_item "[cmd -search] [arg domainlist]"]
  Set the domain search list. This is currently not used.
[lst_item "[cmd -timeout] [arg milliseconds]"]
  Set the default timeout value for DNS lookups. Defaults to 30 seconds.
[list_end]


[nl]
[call [cmd ::dns::name] [arg token]]
  Returns a list of all domain names returned as an answer to your query.

[nl]
[call [cmd ::dns::address] [arg token]]
  Returns a list of the address records that match your query.

[nl]
[call [cmd ::dns::cname] [arg token]]
  Returns a list of canonical names (usually just one) matching your query.

[nl]
[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]

[nl]
[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.

[nl]
[call [cmd ::dns::reset] [arg token]]
  Reset or cancel a DNS query.

[nl]
[call [cmd ::dns::wait] [arg token]]
  Wait for a DNS query to complete and return the status upon completion.

[nl]
[call [cmd ::dns::cleanup] [arg token]]
  Remove all state variables associated with the request.

[list_end]




[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"]
}]

[see_also resolver(5)]
[section AUTHORS]
Pat Thoyts

[keywords DNS resolver {domain name service}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































Deleted modules/doctools/ChangeLog.

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

	* 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  <[email protected]>

	* 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  <[email protected]>

	* cvs.tcl (scanLog): Applied fix for Bug #712951 reported by Joe
	  English <[email protected]>.

2003-03-29  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* doctools_fmt.man: Fixed documentation bug #704187 reported by
	  Roy Terry <[email protected]>.

2003-03-13  Andreas Kupries  <[email protected]>

	* checker.tcl:        Fixed incorrect signature of 'usage'.
	* mpformats/fmt.null: Bugfix in naming of the procedures.

2003-03-13  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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
		                 <[email protected]> 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* mpformats/fmt.html: Modified generation of section titles to
	  make the resulting HTML more conformant and less
	  troublesome. Thanks to Larry Virden
	  <[email protected]> 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* mpexpand: Corrected example formatting, have to run argument
	  through plain text handling.
	* mpformats/fmt.wiki: Added Wiki formatting.

2002-07-08  Andreas Kupries  <[email protected]>

	* mpformats/fmt.html: Changed bug #578465 which caused
	  mis-generation of angle-brackets and quotes.

2002-06-06  Andreas Kupries  <[email protected]>

	* mpformats/fmt.html: 
	* mpformats/_html.tcl: Added the missing handling of " (&quot;) to
	  the format.

2002-05-27  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>
	
	* mpformats/fmt.nroff: Accepted patch for bug #556509, both by Joe
	  English <[email protected]>.

2002-05-09  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* format.man: Added descriptions for all the commands performing
	  semantic markup. This closes bug #527025.

2002-04-10  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* mpformats/fmt.html: Removed 'center' alignment from
	  examples. Tcllib Bug #528390.

2002-03-09  Andreas Kupries  <[email protected]>

	* 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 <[email protected]> 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* mpformats/_common.tcl: Frink run.

2002-02-13  Andreas Kupries  <[email protected]>

	* mpformats/fmt.html: Added detection of section cross-references
	  in [emph] and [strong] based on the code for TMML.

2002-02-13  Joe English  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* Added [example_begin] and [example_end] commands.
	  Also [example { code ... }] command.

2001-12-13  Andreas Kupries  <[email protected]>

	* Added formatter for LaTeX.

2001-12-12  Andreas Kupries  <[email protected]>

	* 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).
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/NOTES.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
======
 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.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































Deleted modules/doctools/api.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# -*- tcl -*-
# api.tcl -- API placeholders
#
# Copyright (c) 2001 Andreas Kupries <[email protected]>
# Copyright (c) 2002 Andreas Kupries <[email protected]>
# Copyright (c) 2003 Andreas Kupries <[email protected]>

################################################################
# 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
} {
    proc fmt_$__cmd {args} [list return  "return -code error \"Unimplemented API command $__cmd\""]
}
unset __cmd

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted modules/doctools/api_idx.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# -*- tcl -*-
# api_idx.tcl -- API placeholders
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>

################################################################
# 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

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































Deleted modules/doctools/api_toc.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# -*- tcl -*-
# api_toc.tcl -- API placeholders
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>

################################################################
# 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

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































Deleted modules/doctools/changelog.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin doctools::changelog n 0.1]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation tools}]
[titledesc {Handle text in Emacs ChangeLog format}]
[require Tcl 8.2]
[require textutil]
[require doctools::changelog [opt 0.1]]
[description]

This package provides tcl commands which are able to process and
reformat text in the [file ChangeLog] format generated [syscmd emacs].

[section COMMANDS]


[list_begin definitions]

[call [cmd ::doctools::changelog::scan] [arg {text}]]

The command takes the [arg text], parses it under the assumption that
it contains a ChangeLog as generated by [syscmd emacs] and returns a
data structure describing this ChangeLog.

[nl]

This data structure is a list whose elements describe one entry in the
ChangeLog each. Each entry is a list of three elements describing date
of the entry, its author, and the comments made, in this order.  The
last element of each entry, the comments, is a list of sections. Each
section is described by two elements, a list of file names, and a
string containing the true comment associated with the files of the
section.


[call [cmd ::doctools::changelog::toDoctools] [arg {title module version entries}]]

This command converts the pre-parsed ChangeLog [arg entries] (as
generated by [cmd ::doctools::changelog::scan]) into a document in
[term doctools] format and returns it as the result of the command.

[nl]

The other three arguments supply 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 [cmd ::doctools::changelog::scan]). The command merges
all of them into a single structure, collapsing 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]

[keywords changelog emacs doctools]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































Deleted modules/doctools/changelog.tcl.

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

# ::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 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 clist clist comment comment files files first first
    upvar 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 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































Deleted modules/doctools/checker.tcl.

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

# 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		|
# --------------+-----------------------+----------------------
# manpage_begin	| manpage_begin		| header
# --------------+-----------------------+----------------------
# header	| moddesc titledesc	| header
#		| copyright		|
#		+-----------------------+-----------
#		| require		| requirements
#		+-----------------------+-----------
#		| description		| body
# --------------+-----------------------+----------------------
# requirements	| require		| requirements
#		+-----------------------+-----------
#		| 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	|
#		+-----------------------+-----------
#		| example_begin		| example
#		+-----------------------+-----------
#		| manpage_end		| done
# --------------+-----------------------+----------------------
# example	| example_end		| body
# --------------+-----------------------+----------------------
# done		|			|
# --------------+-----------------------+----------------------
#
# Additional checks
# --------------------------------------+----------------------
# list_begin/list_end			| Are allowed to nest.
# --------------------------------------+----------------------
# 	lst_item/call			| Only in 'definition list'.
# 	enum				| Only in 'enum list'.
# 	bullet				| Only in 'bullet list'.
#	arg_def				| Only in 'argument list'.
#	cmd_def				| Only in 'command list'.
#	opt_def				| Only in 'option list'.
#	tkoption_def			| Only in 'tkoption list'.
#	nl				| Only in list item context.
#	para section			| Not allowed in list context
# --------------------------------------+----------------------

# -------------------------------------------------------------
# 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 text} {
    set msg [::msgcat::mc $code]
    dt_warning "Manpage warning ($code): [join [split [format $msg $text] \n] "\nManpage 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 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 != {}}
}
proc LValid {what} {
    switch -exact -- $what {
	arg - definitions -
	opt - bullet -
	cmd - tkoption -
	enum    {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 {} {
    global state   ; set state manpage_begin
    global lstctx  ; set lstctx [list]
    global lstitem ; set lstitem 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
	    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}
    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] && [IsNot requirements]} {Error reqcmd}
    Go requirements
    fmt_require $pkg $version
}
proc description {} {
    Enter description
    if {[IsNot header] && [IsNot requirements]} {Error reqcmd}
    Go body
    fmt_description
}
proc section {name} {
    Enter section
    if {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {Error nolistcmd}
    fmt_section $name
}
proc para {} {
    Enter para
    if {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {Error nolistcmd}
    fmt_para
}
proc list_begin {what {hint {}}} {
    Enter "list_begin $what $hint"
    if {[IsNot body]}        {Error bodycmd}
    if {[LOpen] && ![LItem]} {Error nolisthdr}
    if {![LValid $what]}     {Error invalidlist $what}
    LPush        $what
    fmt_list_begin $what $hint
}
proc list_end {} {
    Enter list_end
    if {[IsNot body]} {Error bodycmd}
    if {![LOpen]}     {Error listcmd}
    LPop
    fmt_list_end
}
proc lst_item {{text {}}} {
    Enter lst_item
    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 arg]}         {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 cmd]}         {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 opt]}         {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 tkoption]}    {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]
}
proc bullet {} {
    Enter bullet
    if {[IsNot body]}  {Error bodycmd}
    if {![LOpen]}      {Error listcmd}
    if {![LIs bullet]} {Error bulletlist}
    LSItem
    fmt_bullet
}
proc enum {} {
    Enter enum
    if {[IsNot body]} {Error bodycmd}
    if {![LOpen]}     {Error listcmd}
    if {![LIs enum]}  {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 {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {Error nolistcmd}
    eval [linsert $args 0 fmt_see_also]
}
proc keywords {args} {
    Enter keywords
    if {[IsNot body]} {Error bodycmd}
    if {[LOpen]}      {Error nolistcmd}
    eval [linsert $args 0 fmt_keywords]
}
proc nl {} {
    Enter nl
    if {[IsNot body]} {Error bodycmd}
    if {![LOpen]}     {Error listcmd}
    if {![LItem]}     {Error nolisthdr}
    fmt_nl
}
proc emph {text} {
    if {[Is done]}       {Error nodonecmd}
    fmt_emph $text
}
proc strong {text} {
    if {[Is done]}       {Error nodonecmd}
    if {[dt_deprecated]} {Warn depr_strong "\[strong \{$text\}\]"}
    fmt_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}
    fmt_comment $text
}
proc sectref {name} {
    if {[IsNot body]}        {Error bodycmd}
    if {[LOpen] && ![LItem]} {Error nolisthdr}
    fmt_sectref $name
}
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}
    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
}
proc uri {text} {
    if {[Is done]} {Error nodonecmd}
    fmt_uri $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
}

# -------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/checker_idx.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
# -*- tcl -*-
# checker_idx.tcl
#
# Code used inside of a checker interpreter to ensure correct usage of
# docidx formatting commands.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>

# 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]} {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}
    fmt_comment $text
}

# -------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































Deleted modules/doctools/checker_toc.tcl.

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

# 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			| -> item_series
#		+-----------------------+-----------
#		| division_start	| -> end, PUSH division
# --------------+-----------------------+----------------------
# item_series	| item			| -> item_series
#		+-----------------------+-----------
#		| toc_end		| -> done
# --------------+-----------------------+----------------------
# division	| item			| -> div_items
#		+-----------------------+-----------
#		| division_start	| -> div_series, PUSH division
# --------------+-----------------------+----------------------
# div_series	| division_start	| -> div_series, PUSH division
# --------------+-----------------------+----------------------
# div_items	| item			| -> div_items
#		+-----------------------+-----------
#		| division_end		| POP (-> div_series / -> 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			| -> item_series
# item_series	|			| -> item_series
# div_items	|			| -> div_items
# division      |                       | -> div_items
# --------------+-----------------------+----------------------
# contents	| division_start	| -> end, PUSH division
# div_series	|			| -> div_series, PUSH division
# end		|			| PUSH division
# division      |                       | PUSH division
# --------------+-----------------------+----------------------
# div_items	| division_end		| POP (-> div_series / -> end)
# --------------+-----------------------+----------------------
# item_series	| 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 item_series]} {Error toc/endcmd}
    Go done
    fmt_toc_end
}
proc division_start {title} {
    Enter division_start
    if {
	[IsNot contents] && [IsNot div_series] && [IsNot end] && [IsNot division]
    } {Error toc/sectcmd}
    if {[Is contents] || [Is end]} {Go end} else {Go div_series}
    Push div_series
    fmt_division_start $title
}
proc division_end {} {
    Enter division_end
    if {[IsNot div_items] && [IsNot div_series]} {Error toc/sectecmd [State]}
    Pop
    fmt_division_end
}
proc item {file label desc} {
    Enter item
    if {
	[IsNot div_series] && [IsNot contents] && [IsNot item_series] && [IsNot div_items]
    } {
	Error toc/itemcmd
    }
    if {[Is div_items] || [Is div_series]} {Go div_items} else {Go item_series}
    fmt_item $file $label $desc
}
proc comment {text} {
    if {[Is done]} {Error toc/nodonecmd}
    fmt_comment $text
}

# -------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































Deleted modules/doctools/cvs.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin doctools::cvs n 0.1]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation tools}]
[titledesc {Handle text in 'cvs log' format}]
[require Tcl 8.2]
[require textutil]
[require doctools::cvs [opt 0.1]]
[description]

This package provides tcl commands which are able to process and
reformat text in the format as generated by the [syscmd {cvs log}]
command.

[para]


The commands [cmd scanLog] and [cmd toChangeLog] are derived from code
found on the Tcl'ers Wiki ([uri http://wiki.tcl.tk]). See the
references at the end of the page.


[section COMMANDS]


[list_begin definitions]

[call [cmd ::doctools::cvs::scanLog] [arg {text evar cvar fvar}]]

The command takes the [arg text] and fills the variables whose names
were specified through [arg evar], [arg cvar], and [arg fvar] with
information from the CVS log.

[nl]

Existing information is preserved, allowing the caller to merge data
from multiple logs into one database.

[list_begin definitions]
[lst_item [arg evar]]

Expected to refer to a scalar variable. After the call it contains 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.

[nl]

Note 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.

[nl]

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 of the form
year/month/day

[lst_item [arg cvar]]

Expected to refer to an array variable. Keys into the array are the
date and author of log entries, in this order, separated by a
comma.

[nl]

The value per key is a list of comments made for the entry.



[lst_item [arg fvar]]

Expected to refer to an array variable. Keys into the array are the
date, author of a log entry, and a comment for that entry, in this
order, separated by commas.

[nl]

The value per key is a list of files the entry is touching.

[list_end]
[nl]

[call [cmd ::doctools::cvs::toChangeLog] [arg {evar cvar fvar}]]

The three arguments are the same as the last three arguments of

[cmd ::doctools::cvs::scanLog]. This command however expects them to
be filled with information about one or more logs. It takes this
information and constructs a text in the format of a ChangeLog as
accepted by [syscmd emacs]. The constructed text is returned as the
result of the command.

[list_end]

[see_also [uri http://wiki.tcl.tk/log2changelog]]
[keywords changelog cvs log {cvs log}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































Deleted modules/doctools/cvs.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
# cvs.tcl --
#
#	Handling of various cvs output formats.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
#
# 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.3 2003/03/31 22:00:13 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 $evar entries  ;    #set       entries  [list]
    upvar $cvar comments ;    #array set comments {}
    upvar $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 $evar entries
    upvar $cvar comments
    upvar $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 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































Deleted modules/doctools/docidx.man.

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

This package provides objects which can be used to convert text
written in the doctoc format as specified in [syscmd docidx_fmt] into
any output format X, assuming that a formatting engine for X is
available and provides the interface specified in [syscmd docidx_api].

[section API]

[list_begin definitions]

[call [cmd ::doctools::idx::new] [arg objectName] [opt [arg "option value"]...]]

Creates a new docidx object with an associated global Tcl command
whose name is [arg objectName]. This command is explained in full
detail in the sections [sectref {OBJECT COMMAND}] and

[sectref {OBJECT METHODS}].

[nl]

The list of options and values coming after the name of the object is
used to set the initial configuration of the object.

[call [cmd ::doctools::idx::help]]

This is a pure convenience command for applications which want to
provide their user with a reminder of the available formatting
commands and their meanings. It returns a string containing a standard
help for this purpose.


[call [cmd ::doctools::idx::search] [arg path]]

Whenever the package has to map the name of a format to the file
containing the code for its formatting engine it will search the file
in a number of directories. Three such directories are declared by the
package itself.

[nl]

However the list is extensible by the user of the package and the
command above is the means to do so. When given a [arg path] to an
existing and readable directory it will prepend that directory to the
existing list. This means that the path added last is searched through
first.

[nl]

An error will be thrown if the [arg path] either does not excist, is
not a directory, or is not readable.

[list_end]

[section {OBJECT COMMAND}]

All commands created by [cmd ::doctools::idx::new] have the following
general form and may be used to invoke various operations on the
object they are associated with.

[list_begin definitions]

[call [cmd objectName] [arg option] [opt [arg "arg arg ..."]]]

The [arg option] and its [arg arg]s determine the exact behavior of
the command. See section [sectref {OBJECT METHODS}] for more
explanations.

[list_end]

[section {OBJECT METHODS}]

[list_begin definitions]

[call [arg objectName] [method configure]]

When called without argument this method returns a list of all known
options and their current values.

[call [arg objectName] [method configure] [arg option]]

When called with a single argument this method behaves like
[method cget].

[call [arg objectName] [method configure] [arg "option value"]...]

When called with more than one argument the method reconfigures the
object using the [arg option]s and [arg value]s given to it.

[nl]

The legal configuration options are described in section
[sectref {OBJECT CONFIGURATION}].

[call [arg objectName] [method cget] [arg option]]

This method expects a legal configuration option as argument and
returns the current value of that option for the object the method was
invoked for.

[nl]

The legal configuration options are described in section
[sectref {OBJECT CONFIGURATION}].

[call [arg objectName] [method destroy]]

Destroys the object it is invoked for.

[call [arg objectName] [method format] [arg text]]

Takes the [arg text] and runs it through the configured formatting
engine. The resulting string is returned as the result of this
method. An error will be thrown if no [option -format] was configured
for the object.

[nl]

The method assumes that the [arg text] is in docidx format as
specified in [cmd dtformat(n)]. Errors will be thrown otherwise.


[call [arg objectName] [method search] [arg path]]

This method extends the per-object list of paths searched for
formatting engines. See also [cmd ::doctools::idx::search] on how to extend
the global (per-package) list of paths.

[nl]

The path entered last is searched through first.

[call [arg objectName] [method warnings]]

Returns a list containing all the warnings generated by the engine
during the last invocation of method [method format].

[list_end]

[section {OBJECT CONFIGURATION}]

All docidx objects understand the following configuration options:

[list_begin definitions]

[lst_item "[option -file] [arg file]"]

The argument of this option is stored in the object and can be
retrieved by the formatting engine via the command [cmd dt_file] (see
[cmd dtformatter(n)]). Its default value is the empty string.

[nl]

It will be interpreted as the name of the file containing the text
currently processed by the engine.

[lst_item "[option -module] [arg text]"]

The argument of this option is stored in the object and can be
retrieved by the formatting engine via the command [cmd dt_module]
(see [cmd dtformatter(n)]). Its default value is the empty string.

[nl]

It will be interpreted as the name of the module the file containing
the text currently processed by the engine belongs to.

[lst_item "[option -format] [arg text]"]

The argument of this option specifies the format and thus the engine
to use when converting text via [method format]. Its default value is
the empty string. No formatting is possible if this
option is not set at least once.

[nl]

The package will immediately try to map the name of the format to a
file containing the implementation of the engine for that format. An
error will be thrown if this mapping fails and a previously configured
format is left untouched.

[nl]

Section [sectref {FORMAT MAPPING}] explains how
the package looks for engine implementations.

[lst_item "[option -deprecated] [arg boolean]"]

This option is a flag. If set the object will generate warnings when
formatting a text containing the deprecated markup command [cmd strong]
Its default value is [const FALSE]. In other words, no warnings will
be generated.

[list_end]

[section {FORMAT MAPPING}]

When trying to map a format name [term foo] to the file containing
the implementation of formatting engine for [term foo] the package
will perform the following algorithm:

[list_begin enum]
[enum]

If [term foo] is the name of an existing file 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, that file is taken as the
implementation.

[nl]

This list of paths is initially empty and can be extended through the
object method [method search].

[enum]

If not, the list of global (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, that file is taken as the
implementation.

[nl]

This list of paths contains initially one path and can be extended
through the command [cmd ::doctools::idx::search].

[nl]

The initial (standard) path is the sub directory [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 {ENGINES}]

The package comes with the following predefined formatting engines

[list_begin definitions]
[lst_item html]

This engine generates HTML markup, for processing by web browsers and
the like.

[lst_item latex]

This engine generates output suitable for the [syscmd latex] text
processor coming out of the TeX world.

[lst_item 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.

[lst_item 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.

[lst_item null]

This engine generates no outout at all. This can be used if one just
wants to validate some input.

[lst_item tmml]

This engine generates TMML markup as specified by Joe English. The Tcl
Manpage Markup Language is a derivate of XML.

[lst_item wiki]

This engine generates Wiki markup as understood by Jean Claude
Wippler's [syscmd wikit] application.

[list_end]

[see_also docidx_api docidx_fmt]
[keywords toc {table of contents} index documentation manpage TMML HTML nroff conversion markup]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































Deleted modules/doctools/docidx.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
# docidx.tcl --
#
#	Implementation of docidx objects for Tcl.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
#
# 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.3 2003/04/01 23:38:19 andreas_kupries Exp $

package require Tcl 8.2
package require textutil::expander

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 ::doctools::idx::docidx${name}::file    file
	upvar ::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 ::doctools::idx::docidx${name}::file file
		return $file
	    }
	    -format {
		upvar ::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 ::doctools::idx::docidx${name}::file file
		    set file $value
		}
		-format {
		    if {[catch {
			set fmtfile [LookupFormat $name $value]
			SetupFormatter $name $fmtfile
			upvar ::doctools::idx::docidx${name}::format format
			set format $value
		    } msg]} {
			return -code error "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 ::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 ::doctools::idx::docidx${name}::format format
    if {$format == ""} {
	return -code error "$name: No format was specified"
    }

    upvar ::doctools::idx::docidx${name}::format_ip format_ip
    upvar ::doctools::idx::docidx${name}::chk_ip    chk_ip
    upvar ::doctools::idx::docidx${name}::ex_ok     ex_ok
    upvar ::doctools::idx::docidx${name}::expander  expander
    upvar ::doctools::idx::docidx${name}::passes    passes
    upvar ::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 @$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 ::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 ::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 ::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 ::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]} {
	return $format
    }

    upvar ::doctools::idx::docidx${name}::paths opaths
    foreach path $opaths {
	set f [file join $path idx.$format]
	if {[file exists $f]} {
	    return $f
	}
    }

    variable paths
    foreach path $paths {
	set f [file join $path idx.$format]
	if {[file exists $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 manipulaye
#	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_package  {} ::doctools::Package $mpip
    interp alias $mpip file        {} ::doctools::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 ::doctools::idx::docidx${name}::formatfile formatfile
    upvar ::doctools::idx::docidx${name}::format_ip  format_ip
    upvar ::doctools::idx::docidx${name}::chk_ip     chk_ip
    upvar ::doctools::idx::docidx${name}::expander   expander
    upvar ::doctools::idx::docidx${name}::passes     xpasses
    upvar ::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 manipulaye
#
# 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 ::doctools::idx::docidx${name}::chk_ip    chk_ip
    if {$chk_ip != ""} {return}

    upvar ::doctools::idx::docidx${name}::expander  expander
    upvar ::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 manipulaye
#
# Results:
#	None.

proc ::doctools::idx::SetupExpander {name} {
    upvar ::doctools::idx::docidx${name}::ex_ok    ex_ok
    if {$ex_ok} {return}

    upvar ::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 ::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 occured.
#
# 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 ::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 ::doctools::idx::docidx${name}::chk_ip chk_ip

    # Handle the [include] command directly
    if {[string match include* $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 ::doctools::idx::docidx${name}::file file

    set ipath [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 ::doctools::idx::docidx${name}::expander  expander

    return [$expander expand $text]
}

# ::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 ::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 ::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
}

#------------------------------------
# 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 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/docidx.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
# -*- 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 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: docidx.test,v 1.1 2003/03/05 06:50:33 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require doctools::idx
puts "doctools::idx [package present doctools::idx]"

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::getErrorMessage "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::getErrorMessage "::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::tooManyMessage "::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::getErrorMessage "::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::getErrorMessage "::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::tooManyMessage "::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::getErrorMessage "::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::tooManyMessage "::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 manpage syntax .......................................................

test docidx-9.0 {docidx syntax} {
    new mydocidx -format null
    catch {mydocidx format foo} result
    mydocidx destroy
    set result
} {IDX error (idx/plaintext), "plain_text foo" : Plain text beyond whitespace is not allowed..}


namespace forget ::doctools::idx::new
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































Deleted modules/doctools/docidx_api.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin docidx_api n 1.0]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation tools}]
[titledesc {Interface specification for index formatting code}]
[description]
[para]

This manpage specifies the interface between formatting engines for
data in the [syscmd docidx] format as specified in
[syscmd docidx_fmt], and [package doctools::idx], the package for the
generic handling of such data, as described in [syscmd docidx].

[para]

Each formatting engine has to implement the conversion of input in
[syscmd docidx] format to one particular output format as chosen by
the author of the formatting engine.

[section INTERFACE]

Each formatting engine has to provide

[list_begin enum]
[enum]

Implementations of all the formatting commands as specified in

[syscmd docidx_fmt], using the defined names, but prefixed with the
string [const fmt_]. The sole exceptions to this are the formatting
commands [cmd vset] and [cmd include]. These two commands are
processed by the generic layer and will never be seen by the
formatting engine.

[enum]
and additionally implementations for

[list_begin definitions]

[lst_item "[cmd idx_numpasses]"]

This command is called immediately after the formatter is loaded and
has to return the number of passes required by this formatter to
process a manpage. This information has to be an integer number
greater or equal to one.

[lst_item "[cmd idx_initialize]"]

This command is called at the beginning of every conversion run and is
responsible for initializing the general state of the formatting
engine.

[lst_item "[cmd idx_setup] [arg n]"]

This command is called at the beginning of each pass over the input
and is given the id of the current pass as its first argument. It is
responsible for setting up the internal state of the formatting for
this particular pass.

[lst_item "[cmd idx_postprocess] [arg text]"]

This command is called immediately after the last pass, with the
expansion result of that pass as argument, and can do any last-ditch
modifications of the generated result.  Its result will be the final
result of the conversion.

[nl]

Most formats will use [emph identity] here.

[lst_item "[cmd idx_shutdown]"]

This command is called at the end of every conversion run and is
responsible for cleaning up of all the state in the formatting engine.

[lst_item "[cmd fmt_plain_text] [arg text]"]

This command is called for any plain text encountered by the processor
in the input and can do any special processing required for plain
text. Its result is the string written into the expansion.

[nl]

Most formats will use [emph identity] here.

[lst_item [cmd idx_listvariables]]

The command is called after loading a formatting engine to determine
which parameters are supported by that engine. The return value is a
list containing the names of these parameters.

[lst_item "[cmd idx_varset] [arg varname] [arg text]"]

The command is called by the generic layer to set the value of an
engine specific parameter. The parameter to change is specified by
[arg varname], and the value to set is given in [arg text].

[nl]

The command will throw an error if an unknown [arg varname] is
used. Only the names returned by [cmd idx_listvariables] are
considered known.

[list_end]
[list_end]

[para]

The tcl code of a formatting engine implementing all of the above can
make the following assumptions about its environment

[list_begin enum]
[enum]

It has full access to its own safe interpreter.  In other words, the
engine cannot damage the other parts of the processor, nor can it
damage the filesystem.

[enum]

The surrounding system provides the engine with the following
commands:

[list_begin definitions]

[lst_item "Doctools commands"]
[list_begin definitions]
[lst_item [cmd dt_format]]
Returns the name of format loaded into the engine
[lst_item "[cmd dt_fmap] [arg fname]"]
Returns the actual name to use in the output in place of the symbolic
filename [arg fname].
[lst_item "[cmd dt_source] [arg file]"]
This command allows the engine to load additional tcl code. The file
being loaded has to be in the same directory as the file the format
engine was loaded from. Any path specified for [arg file] is ignored.
[list_end]

[lst_item "Expander commands"]

All of the commands below are methods of the expander object (without
the prefix [const ex_]) handling the input. Their arguments and
results are described in [package expander(n)].


[list_begin definitions]
[lst_item [cmd ex_cappend]]
[lst_item [cmd ex_cget]]
[lst_item [cmd ex_cis]]
[lst_item [cmd ex_cname]]
[lst_item [cmd ex_cpop]]
[lst_item [cmd ex_cpush]]
[lst_item [cmd ex_cset]]
[lst_item [cmd ex_lb]]
[lst_item [cmd ex_rb]]
[list_end]

[lst_item "_idx_common.tcl commands"]

Any engine loading ([cmd dt_source]) the file [file _idx_common.tcl] has
default implementations of the [const idx_] commands explicitly
listed in this document and of [cmd fmt_plaint_text].

[list_end]
[list_end]

[see_also docidx_fmt docidx]
[keywords markup {generic markup} index keywords TMML HTML nroff LaTeX]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































Deleted modules/doctools/docidx_fmt.man.

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

This manpage specifies a documentation format for indices. It is
intended to complement both the [syscmd doctools] format for writing
manpages and the [syscmd doctoc] format for writing tables of
contents. See [syscmd doctools_fmt] and [syscmd doctoc_fmt] for the
specification of these two formats.

[para]

This format is called [syscmd docidx].

It provides all the necessary commands to write an index for a group
of manpages.

Like for the [syscmd doctools] and [syscmd doctoc] formats a package
is provided implementing a generic framework for the conversion of
[syscmd docidx] to a number of different output formats, like HTML,
TMML, nroff, LaTeX, etc.

The package is called [package doctools::idx], its documentation can
be found in [syscmd docidx].

People wishing to write a formatting engine for the conversion of
[syscmd docidx] into a new output format have to read
[syscmd docidx_api]. This manpage will explain the interface between
the generic package and such engines.


[section OVERVIEW]

[syscmd docidx] is similar to LaTex in that it consists primarily of
text, with markup commands embedded into it. The format used to mark
something as command is different from LaTeX however. All text between
matching pairs of [lb] and [rb] is a command, possibly with
arguments. Note that both brackets have to be on the same line for a
command to be recognized.

[para]

In this format plain text is not allowed, except for whitespace, which
can be used to separate the formatting commands described in the next
section ([sectref {FORMATTING COMMANDS}]).


[section {FORMATTING COMMANDS}]

First a number of generic commands useable anywhere in a
[syscmd docidx] file.

[list_begin definitions]

[call [cmd vset] [arg varname] [arg value] ]

Sets the formatter variable [arg varname] to the specified
[arg value]. Returns the empty string.

[call [cmd vset] [arg varname]]

Returns the value associated with the formatter variable
[arg varname].

[call [cmd include] [arg filename]]

Instructs the system to insert the expanded contents of the file named
[arg filename] in its own place.

[call [cmd comment] [arg text]]

Declares that the marked [arg text] is a comment.

[list_end]


Commands to insert special plain text. These bracket commands are
necessary as plain brackets are used to denote the beginnings and
endings of the formatting commands and thus cannot be used as normal
characters anymore.

[list_begin definitions]

[call [cmd lb]]

Introduces a left bracket into the output.

[call [cmd rb]]

Introduces a right bracket into the output.

[list_end]



And now the relevant markup commands.

[list_begin definitions]

[call [cmd index_begin] [arg text] [arg title]]

This command starts an index. It has to be the very first

[term markup] command in a [syscmd docidx] file. Plain text is not
allowed to come before this command. Only the generic commands (see
above: [cmd vset], [cmd include], [cmd comment]) can be used before
it.

[nl]

The [arg text] argument provides a label for the whole group of
manpages the index refers to. Often this is the name of the package
(or extension) the manpages belong to.

[nl]

The [arg title] argument provides the title for the index.

[nl]

Each index has to contain at least one [cmd key].


[call [cmd index_end]]

This command closes an index. Nothing is allowed to follow it.


[call [cmd key] [arg text]]

This commands starts the list of manpages and other entities which
refer to the keyword named by the argument [arg text].

[nl]

Each key section has to contain at least one index element, either
[cmd manpage] or [cmd url].


[call [cmd manpage] [arg file] [arg label]]

This command describes an individual index element. Each such element
belongs to the last occurence of a [cmd key] command coming before the
index.

[nl]

The [arg file] argument refers to the file containing the actual
manpage refering to that key. The second argument is used to label the
reference.

[nl]

To preserve convertibility of this format to various output formats
the filename argument [arg file] is considered to contain a symbolic
name. The actual name of the file will be inserted by the formatting
engine used to convert the input, based on a mapping from symbolic to
actual names given to it.


[call [cmd url] [arg url] [arg label]]

This is the second command to describe an index element. The
association to the key it belongs to is done in the same way as for
the [cmd manpage] command. The first however is not the symbolic name
of the file refering to that key, but an url describing the exact
location of the document indexed here.

[list_end]

[section NOTES]

[list_begin enum]
[enum]

Using an appropriate formatting engine and some glue code it is
possible to automatically generate a document in [syscmd docidx]
format from a collection of manpages in [syscmd doctools] format.


[list_end]

[section EXAMPLE]

As an example an index for all manpages belonging to this module
(doctools) of package [package tcllib].

[para]

[example {
[index_begin tcllib/doctools {Documentation tools}]
 [key HTML]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtformatter]
  [manpage dtocengine]
  [manpage dtocformat]
  [manpage mpexpand]
 [key TMML]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtformatter]
  [manpage dtocengine]
  [manpage dtocformat]
  [manpage mpexpand]
 [key conversion]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtformatter]
  [manpage dtocengine]
  [manpage dtocformat]
  [manpage mpexpand]
 [key documentation]
  [manpage doctools]
  [manpage dtformatter]
 [key index]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtocformat]
 [key interface]
  [manpage didxengine]
  [manpage dtformatter]
  [manpage dtocengine]
 [key manpage]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtformatter]
  [manpage dtocengine]
  [manpage dtocformat]
  [manpage mpexpand]
 [key markup]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtformatter]
  [manpage dtocengine]
  [manpage dtocformat]
  [manpage mpexpand]
 [key nroff]
  [manpage didxengine]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtformatter]
  [manpage dtocengine]
  [manpage dtocformat]
  [manpage mpexpand]
 [key {table of contents}]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtocengine]
  [manpage dtocformat]
 [key toc]
  [manpage didxformat]
  [manpage doctools]
  [manpage dtformat]
  [manpage dtocengine]
  [manpage dtocformat]
[index_end]
}]

[see_also doctools_fmt doctoc_fmt docidx_api docidx]
[keywords markup {generic markup} index keywords TMML HTML nroff LaTeX]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctoc.man.

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

This package provides objects which can be used to convert text
written in the doctoc format as specified in [syscmd doctoc_fmt] into
any output format X, assuming that a formatting engine for X is
available and provides the interface specified in [syscmd doctoc_api].

[section API]

[list_begin definitions]

[call [cmd ::doctools::toc::new] [arg objectName] [opt [arg "option value"]...]]

Creates a new doctoc object with an associated global Tcl command
whose name is [arg objectName]. This command is explained in full
detail in the sections [sectref {OBJECT COMMAND}] and

[sectref {OBJECT METHODS}].

[nl]

The list of options and values coming after the name of the object is
used to set the initial configuration of the object.

[call [cmd ::doctools::toc::help]]

This is a pure convenience command for applications which want to
provide their user with a reminder of the available formatting
commands and their meanings. It returns a string containing a standard
help for this purpose.


[call [cmd ::doctools::toc::search] [arg path]]

Whenever the package has to map the name of a format to the file
containing the code for its formatting engine it will search the file
in a number of directories. Three such directories are declared by the
package itself.

[nl]

However the list is extensible by the user of the package and the
command above is the means to do so. When given a [arg path] to an
existing and readable directory it will prepend that directory to the
existing list. This means that the path added last is searched through
first.

[nl]

An error will be thrown if the [arg path] either does not excist, is
not a directory, or is not readable.

[list_end]

[section {OBJECT COMMAND}]

All commands created by [cmd ::doctools::toc::new] have the following
general form and may be used to invoke various operations on the
object they are associated with.

[list_begin definitions]

[call [cmd objectName] [arg option] [opt [arg "arg arg ..."]]]

The [arg option] and its [arg arg]s determine the exact behavior of
the command. See section [sectref {OBJECT METHODS}] for more
explanations.

[list_end]

[section {OBJECT METHODS}]

[list_begin definitions]

[call [arg objectName] [method configure]]

When called without argument this method returns a list of all known
options and their current values.

[call [arg objectName] [method configure] [arg option]]

When called with a single argument this method behaves like
[method cget].

[call [arg objectName] [method configure] [arg "option value"]...]

When called with more than one argument the method reconfigures the
object using the [arg option]s and [arg value]s given to it.

[nl]

The legal configuration options are described in section
[sectref {OBJECT CONFIGURATION}].

[call [arg objectName] [method cget] [arg option]]

This method expects a legal configuration option as argument and
returns the current value of that option for the object the method was
invoked for.

[nl]

The legal configuration options are described in section
[sectref {OBJECT CONFIGURATION}].

[call [arg objectName] [method destroy]]

Destroys the object it is invoked for.

[call [arg objectName] [method format] [arg text]]

Takes the [arg text] and runs it through the configured formatting
engine. The resulting string is returned as the result of this
method. An error will be thrown if no [option -format] was configured
for the object.

[nl]

The method assumes that the [arg text] is in doctoc format as
specified in [cmd dtformat(n)]. Errors will be thrown otherwise.


[call [arg objectName] [method search] [arg path]]

This method extends the per-object list of paths searched for
formatting engines. See also [cmd ::doctools::toc::search] on how to extend
the global (per-package) list of paths.

[nl]

The path entered last is searched through first.

[call [arg objectName] [method warnings]]

Returns a list containing all the warnings generated by the engine
during the last invocation of method [method format].

[list_end]

[section {OBJECT CONFIGURATION}]

All doctoc objects understand the following configuration options:

[list_begin definitions]

[lst_item "[option -file] [arg file]"]

The argument of this option is stored in the object and can be
retrieved by the formatting engine via the command [cmd dt_file] (see
[cmd dtformatter(n)]). Its default value is the empty string.

[nl]

It will be interpreted as the name of the file containing the text
currently processed by the engine.

[lst_item "[option -module] [arg text]"]

The argument of this option is stored in the object and can be
retrieved by the formatting engine via the command [cmd dt_module]
(see [cmd dtformatter(n)]). Its default value is the empty string.

[nl]

It will be interpreted as the name of the module the file containing
the text currently processed by the engine belongs to.

[lst_item "[option -format] [arg text]"]

The argument of this option specifies the format and thus the engine
to use when converting text via [method format]. Its default value is
the empty string. No formatting is possible if this
option is not set at least once.

[nl]

The package will immediately try to map the name of the format to a
file containing the implementation of the engine for that format. An
error will be thrown if this mapping fails and a previously configured
format is left untouched.

[nl]

Section [sectref {FORMAT MAPPING}] explains how
the package looks for engine implementations.

[lst_item "[option -deprecated] [arg boolean]"]

This option is a flag. If set the object will generate warnings when
formatting a text containing the deprecated markup command [cmd strong]
Its default value is [const FALSE]. In other words, no warnings will
be generated.

[list_end]

[section {FORMAT MAPPING}]

When trying to map a format name [term foo] to the file containing
the implementation of formatting engine for [term foo] the package
will perform the following algorithm:

[list_begin enum]
[enum]

If [term foo] is the name of an existing file 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, that file is taken as the
implementation.

[nl]

This list of paths is initially empty and can be extended through the
object method [method search].

[enum]

If not, the list of global (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, that file is taken as the
implementation.

[nl]

This list of paths contains initially one path and can be extended
through the command [cmd ::doctools::toc::search].

[nl]

The initial (standard) path is the sub directory [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 {ENGINES}]

The package comes with the following predefined formatting engines

[list_begin definitions]
[lst_item html]

This engine generates HTML markup, for processing by web browsers and
the like.

[lst_item latex]

This engine generates output suitable for the [syscmd latex] text
processor coming out of the TeX world.

[lst_item 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.

[lst_item 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.

[lst_item null]

This engine generates no outout at all. This can be used if one just
wants to validate some input.

[lst_item tmml]

This engine generates TMML markup as specified by Joe English. The Tcl
Manpage Markup Language is a derivate of XML.

[lst_item wiki]

This engine generates Wiki markup as understood by Jean Claude
Wippler's [syscmd wikit] application.

[list_end]

[see_also doctoc_api doctoc_fmt]
[keywords toc {table of contents} index documentation manpage TMML HTML nroff conversion markup]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctoc.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
# doctoc.tcl --
#
#	Implementation of doctoc objects for Tcl.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
#
# 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.3 2003/04/01 23:38:19 andreas_kupries Exp $

package require Tcl 8.2
package require textutil::expander

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 ::doctools::toc::doctoc${name}::file    file
	upvar ::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 ::doctools::toc::doctoc${name}::file file
		return $file
	    }
	    -format {
		upvar ::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 ::doctools::toc::doctoc${name}::file file
		    set file $value
		}
		-format {
		    if {[catch {
			set fmtfile [LookupFormat $name $value]
			SetupFormatter $name $fmtfile
			upvar ::doctools::toc::doctoc${name}::format format
			set format $value
		    } msg]} {
			return -code error "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 ::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 ::doctools::toc::doctoc${name}::format format
    if {$format == ""} {
	return -code error "$name: No format was specified"
    }

    upvar ::doctools::toc::doctoc${name}::format_ip format_ip
    upvar ::doctools::toc::doctoc${name}::chk_ip    chk_ip
    upvar ::doctools::toc::doctoc${name}::ex_ok     ex_ok
    upvar ::doctools::toc::doctoc${name}::expander  expander
    upvar ::doctools::toc::doctoc${name}::passes    passes
    upvar ::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 @$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 ::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 ::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 ::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 ::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]} {
	return $format
    }

    upvar ::doctools::toc::doctoc${name}::paths opaths
    foreach path $opaths {
	set f [file join $path toc.$format]
	if {[file exists $f]} {
	    return $f
	}
    }

    variable paths
    foreach path $paths {
	set f [file join $path toc.$format]
	if {[file exists $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 manipulaye
#	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_package  {} ::doctools::Package $mpip
    interp alias $mpip file        {} ::doctools::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 ::doctools::toc::doctoc${name}::formatfile formatfile
    upvar ::doctools::toc::doctoc${name}::format_ip  format_ip
    upvar ::doctools::toc::doctoc${name}::chk_ip     chk_ip
    upvar ::doctools::toc::doctoc${name}::expander   expander
    upvar ::doctools::toc::doctoc${name}::passes     xpasses
    upvar ::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 manipulaye
#
# 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 ::doctools::toc::doctoc${name}::chk_ip    chk_ip
    if {$chk_ip != ""} {return}

    upvar ::doctools::toc::doctoc${name}::expander  expander
    upvar ::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 manipulaye
#
# Results:
#	None.

proc ::doctools::toc::SetupExpander {name} {
    upvar ::doctools::toc::doctoc${name}::ex_ok    ex_ok
    if {$ex_ok} {return}

    upvar ::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 ::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 occured.
#
# 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 ::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 ::doctools::toc::doctoc${name}::chk_ip chk_ip

    # Handle the [include] command directly
    if {[string match include* $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 ::doctools::toc::doctoc${name}::file file

    set ipath [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 ::doctools::toc::doctoc${name}::expander  expander

    return [$expander expand $text]
}

# ::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 ::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 ::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
}

#------------------------------------
# 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 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctoc.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
# -*- 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 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: doctoc.test,v 1.1 2003/03/05 06:50:33 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require doctools::toc
puts "doctools::toc [package present doctools::toc]"

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::getErrorMessage "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::getErrorMessage "::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::tooManyMessage "::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::getErrorMessage "::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::getErrorMessage "::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::tooManyMessage "::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::getErrorMessage "::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::tooManyMessage "::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 manpage syntax .......................................................

test doctoc-9.0 {doctoc syntax} {
    new mydoctoc -format null
    catch {mydoctoc format foo} result
    mydoctoc destroy
    set result
} {TOC error (toc/plaintext), "plain_text foo" : Plain text beyond whitespace is not allowed..}


namespace forget ::doctools::toc::new
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctoc_api.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin doctoc_api n 1.0]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation tools}]
[titledesc {Interface specification for toc formatting code}]
[description]
[para]


This manpage specifies the interface between formatting engines for
data in the [syscmd doctoc] format as specified in
[syscmd doctoc_fmt], and [package doctools::toc], the package for the
generic handling of such data, as described in [syscmd doctoc].

[para]

Each formatting engine has to implement the conversion of input in
[syscmd doctoc] format to one particular output format as chosen by
the author of the formatting engine.

[section INTERFACE]

Each formatting engine has to provide

[list_begin enum]
[enum]

Implementations of all the formatting commands as specified in

[syscmd doctoc_fmt], using the defined names, but prefixed with the
string [const fmt_]. The sole exceptions to this are the formatting
commands [cmd vset] and [cmd include]. These two commands are
processed by the generic layer and will never be seen by the
formatting engine.

[enum]
and additionally implementations for

[list_begin definitions]

[lst_item "[cmd toc_numpasses]"]

This command is called immediately after the formatter is loaded and
has to return the number of passes required by this formatter to
process a manpage. This information has to be an integer number
greater or equal to one.

[lst_item "[cmd toc_initialize]"]

This command is called at the beginning of every conversion run and is
responsible for initializing the general state of the formatting
engine.

[lst_item "[cmd toc_setup] [arg n]"]

This command is called at the beginning of each pass over the input
and is given the id of the current pass as its first argument. It is
responsible for setting up the internal state of the formatting for
this particular pass.

[lst_item "[cmd toc_postprocess] [arg text]"]

This command is called immediately after the last pass, with the
expansion result of that pass as argument, and can do any last-ditch
modifications of the generated result.  Its result will be the final
result of the conversion.

[nl]

Most formats will use [emph identity] here.

[lst_item "[cmd toc_shutdown]"]

This command is called at the end of every conversion run and is
responsible for cleaning up of all the state in the formatting engine.

[lst_item "[cmd fmt_plain_text] [arg text]"]

This command is called for any plain text encountered by the processor
in the input and can do any special processing required for plain
text. Its result is the string written into the expansion.

[nl]

Most formats will use [emph identity] here.

[lst_item [cmd toc_listvariables]]

The command is called after loading a formatting engine to determine
which parameters are supported by that engine. The return value is a
list containing the names of these parameters.

[lst_item "[cmd toc_varset] [arg varname] [arg text]"]

The command is called by the generic layer to set the value of an
engine specific parameter. The parameter to change is specified by
[arg varname], and the value to set is given in [arg text].

[nl]

The command will throw an error if an unknown [arg varname] is
used. Only the names returned by [cmd toc_listvariables] are
considered known.

[list_end]
[list_end]

[para]

The tcl code of a formatting engine implementing all of the above can
make the following assumptions about its environment

[list_begin enum]
[enum]

It has full access to its own safe interpreter.  In other words, the
engine cannot damage the other parts of the processor, nor can it
damage the filesystem.

[enum]

The surrounding system provides the engine with the following
commands:

[list_begin definitions]

[lst_item "Doctools commands"]
[list_begin definitions]
[lst_item [cmd dt_format]]
Returns the name of format loaded into the engine
[lst_item "[cmd dt_fmap] [arg fname]"]
Returns the actual name to use in the output in place of the symbolic
filename [arg fname].
[lst_item "[cmd dt_source] [arg file]"]
This command allows the engine to load additional tcl code. The file
being loaded has to be in the same directory as the file the format
engine was loaded from. Any path specified for [arg file] is ignored.
[list_end]

[lst_item "Expander commands"]

All of the commands below are methods of the expander object (without
the prefix [const ex_]) handling the input. Their arguments and
results are described in [package expander(n)].


[list_begin definitions]
[lst_item [cmd ex_cappend]]
[lst_item [cmd ex_cget]]
[lst_item [cmd ex_cis]]
[lst_item [cmd ex_cname]]
[lst_item [cmd ex_cpop]]
[lst_item [cmd ex_cpush]]
[lst_item [cmd ex_cset]]
[lst_item [cmd ex_lb]]
[lst_item [cmd ex_rb]]
[list_end]

[lst_item "_toc_common.tcl commands"]

Any engine loading ([cmd dt_source]) the file [file _toc_common.tcl] has
default implementations of the [const toc_] commands explicitly
listed in this document and of [cmd fmt_plaint_text].

[list_end]
[list_end]

[see_also doctoc_fmt doctoc]
[keywords markup {generic markup} toc {table of contents} TMML HTML nroff LaTeX]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































Deleted modules/doctools/doctoc_fmt.man.

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

This manpage specifies a documentation format for tables of
contents. It is intended to complement both the [syscmd doctools]
format for writing manpages and the [syscmd docidx] format for writing
indices.  See [syscmd doctools_fmt] and [syscmd docidx_fmt] for the
specification of these two formats

[para]

This format is called [syscmd doctoc].

It provides all the necessary commands to write a table of contents
for a group of manpages. It is simpler than TMML, but convertible into
it.

Like for the [syscmd doctools] and [syscmd docidx] formats a package
is provided implementing a generic framework for the conversion of
[syscmd doctoc] to a number of different output formats, like HTML,
TMML, nroff, LaTeX, etc.

The package is called [package doctools::toc], its documentation can
be found in [syscmd doctoc].


People wishing to write a formatting engine for the conversion of
[syscmd doctoc] into a new output format have to read
[syscmd doctoc_api]. This manpage will explain the interface between
the generic package and such engines.


[section OVERVIEW]

[syscmd doctoc] is similar to LaTex in that it consists primarily of
text, with markup commands embedded into it. The format used to mark
something as command is different from LaTeX however. All text between
matching pairs of [lb] and [rb] is a command, possibly with
arguments. Note that both brackets have to be on the same line for a
command to be recognized.


[para]

In this format plain text is not allowed, except for whitespace, which
can be used to separate the formatting commands described in the next
section ([sectref {FORMATTING COMMANDS}]).


[section {FORMATTING COMMANDS}]

First a number of generic commands useable anywhere in a
[syscmd doctoc] file.

[list_begin definitions]

[call [cmd vset] [arg varname] [arg value] ]

Sets the formatter variable [arg varname] to the specified
[arg value]. Returns the empty string.

[call [cmd vset] [arg varname]]

Returns the value associated with the formatter variable
[arg varname].

[call [cmd include] [arg filename]]

Instructs the system to insert the expanded contents of the file named
[arg filename] in its own place.

[call [cmd comment] [arg text]]

Declares that the marked [arg text] is a comment.

[list_end]


Commands to insert special plain text. These bracket commands are
necessary as plain brackets are used to denote the beginnings and
endings of the formatting commands and thus cannot be used as normal
characters anymore.

[list_begin definitions]

[call [cmd lb]]

Introduces a left bracket into the output.

[call [cmd rb]]

Introduces a right bracket into the output.

[list_end]



And now the relevant markup commands.

[list_begin definitions]

[call [cmd toc_begin] [arg text] [arg title]]

This command starts a table of contents. It has to be the very first
[term markup] command in a [syscmd doctoc] file. Plain text is not
allowed to come before this command. Only the generic commands (see
above: [cmd vset], [cmd include], [cmd comment]) can be used before
it.

[nl]

The [arg text] argument provides a label for the whole group of
manpages listed in the table of contents. Often this is the name of
the package (or extension) the manpages belong to.

[nl]

The [arg title] argument provides the title for the whole table of
contents.

[nl]

The table of contents has to contain at least either one toc element
([cmd item]) or one division.


[call [cmd toc_end]]

This command closes a table of contents. Nothing is allowed to follow
it.


[call [cmd division_start] [arg text]]

This command and its counterpart [cmd division_end] can be used to give
the table of contents additional structure.

[nl]

Each division starts with [cmd division_start], is ended by [cmd division_end]

and has a title provided through the argument [arg title]. The
contents of a division are like for the whole table of contents,
i.e. a series of either toc elements or divisions. The latter means
that divisions can be nested.

[nl]

The division has to contain at least either one toc element
([cmd item]) or one division.


[call [cmd division_end]]

This command closes a toc division. See [cmd division_start] above for
the detailed explanation.


[call [cmd item] [arg file] [arg label] [arg desc]]

This command describes an individual toc element. The [arg file]
argument refers to the file containing the actual manpage, and the
[arg desc] provides a short descriptive text of that manpage. The
argument [arg label] can be used by engines supporting hyperlinks to
give the link a nice text (instead of the symbolic filename).

[nl]

To preserve convertibility of this format to various output formats
the filename argument is considered a symbolic name. The actual name
of the file will be inserted by the formatting engine used to convert
the input, based on a mapping from symbolic to actual names given to
it.

[list_end]

[section NOTES]

[list_begin enum]
[enum]
The commands for the [syscmd doctoc] format are closely modeled on the
TMML tags used for describing collections of manpages.

[enum]

Using an appropriate formatting engine and some glue code it is
possible to automatically generate a document in [syscmd doctoc]
format from a collection of manpages in [syscmd doctools] format.


[list_end]

[section EXAMPLE]

As an example a table of contents for all manpages belonging to this
module (doctools) of package [package tcllib].

[para]

[example {
[toc_begin tcllib/doctools {Documentation tools}]
[division_start {Basic format}]
[item dtformat.man    {doctools format specification}]
[item dtformatter.man {doctools engine interface}]
[item doctools.man    {Package to handle doctools input and engines}]
[division_end]
[division_start {Table of Contents}]
[item dtocformat.man    {doctoc format specification}]
[item dtocformatter.man {doctoc engine interface}]
[item doctoc.man        {Package to handle doctoc input and engines}]
[division_end]
[division_start {Indices}]
[item dtidxformat.man    {docindex format specification}]
[item dtidxformatter.man {docindex engine interface}]
[item docindex.man       {Package to handle docindex input and engines}]
[division_end]
[toc_end]
}]

[see_also doctools_fmt docidx_fmt doctoc_api doctoc]
[keywords markup {generic markup} toc {table of contents} TMML HTML nroff LaTeX]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































Deleted modules/doctools/doctools.man.

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

This package provides objects which can be used to convert text
written in the doctools format as specified in [cmd dtformat(n)]
into any output format X, assuming that a formatting engine for X is
available and provides the interface specified in
[cmd dtformatter(n)].

[section API]

[list_begin definitions]

[call [cmd ::doctools::new] [arg objectName] [opt [arg "option value"]...]]

Creates a new doctools object with an associated global Tcl command
whose name is [arg objectName]. This command is explained in full
detail in the sections [sectref {OBJECT COMMAND}] and

[sectref {OBJECT METHODS}].

[nl]

The list of options and values coming after the name of the object is
used to set the initial configuration of the object.

[call [cmd ::doctools::help]]

This is a pure convenience command for applications which want to
provide their user with a reminder of the available formatting
commands and their meanings. It returns a string containing a standard
help for this purpose.


[call [cmd ::doctools::search] [arg path]]

Whenever the package has to map the name of a format to the file
containing the code for its formatting engine it will search the file
in a number of directories. Three such directories are declared by the
package itself.

[nl]

However the list is extensible by the user of the package and the
command above is the means to do so. When given a [arg path] to an
existing and readable directory it will prepend that directory to the
existing list. This means that the path added last is searched through
first.

[nl]

An error will be thrown if the [arg path] either does not excist, is
not a directory, or is not readable.

[list_end]

[section {OBJECT COMMAND}]

All commands created by [cmd ::doctools::new] have the following
general form and may be used to invoke various operations on the
object they are associated with.

[list_begin definitions]

[call [cmd objectName] [arg option] [opt [arg "arg arg ..."]]]

The [arg option] and its [arg arg]s determine the exact behavior of
the command. See section [sectref {OBJECT METHODS}] for more
explanations.

[list_end]

[section {OBJECT METHODS}]

[list_begin definitions]

[call [arg objectName] [method configure]]

When called without argument this method returns a list of all known
options and their current values.

[call [arg objectName] [method configure] [arg option]]

When called with a single argument this method behaves like
[method cget].

[call [arg objectName] [method configure] [arg "option value"]...]

When called with more than one argument the method reconfigures the
object using the [arg option]s and [arg value]s given to it.

[nl]

The legal configuration options are described in section
[sectref {OBJECT CONFIGURATION}].

[call [arg objectName] [method cget] [arg option]]

This method expects a legal configuration option as argument and
returns the current value of that option for the object the method was
invoked for.

[nl]

The legal configuration options are described in section
[sectref {OBJECT CONFIGURATION}].

[call [arg objectName] [method destroy]]

Destroys the object it is invoked for.

[call [arg objectName] [method format] [arg text]]

Takes the [arg text] and runs it through the configured formatting
engine. The resulting string is returned as the result of this
method. An error will be thrown if no [option -format] was configured
for the object.

[nl]

The method assumes that the [arg text] is in doctools format as
specified in [cmd dtformat(n)]. Errors will be thrown otherwise.


[call [arg objectName] [method search] [arg path]]

This method extends the per-object list of paths searched for
formatting engines. See also [cmd ::doctools::search] on how to extend
the global (per-package) list of paths.

[nl]

The path entered last is searched through first.

[call [arg objectName] [method warnings]]

Returns a list containing all the warnings generated by the engine
during the last invocation of method [method format].

[list_end]

[section {OBJECT CONFIGURATION}]

All doctools objects understand the following configuration options:

[list_begin definitions]

[lst_item "[option -file] [arg file]"]

The argument of this option is stored in the object and can be
retrieved by the formatting engine via the command [cmd dt_file] (see
[cmd dtformatter(n)]). Its default value is the empty string.

[nl]

It will be interpreted as the name of the file containing the text
currently processed by the engine.

[lst_item "[option -module] [arg text]"]

The argument of this option is stored in the object and can be
retrieved by the formatting engine via the command [cmd dt_module]
(see [cmd dtformatter(n)]). Its default value is the empty string.

[nl]

It will be interpreted as the name of the module the file containing
the text currently processed by the engine belongs to.

[lst_item "[option -format] [arg text]"]

The argument of this option specifies the format and thus the engine
to use when converting text via [method format]. Its default value is
the empty string. No formatting is possible if this
option is not set at least once.

[nl]

The package will immediately try to map the name of the format to a
file containing the implementation of the engine for that format. An
error will be thrown if this mapping fails and a previously configured
format is left untouched.

[nl]

Section [sectref {FORMAT MAPPING}] explains how
the package looks for engine implementations.

[lst_item "[option -deprecated] [arg boolean]"]

This option is a flag. If set the object will generate warnings when
formatting a text containing the deprecated markup command [cmd strong]
Its default value is [const FALSE]. In other words, no warnings will
be generated.

[list_end]

[section {FORMAT MAPPING}]

When trying to map a format name [term foo] to the file containing
the implementation of formatting engine for [term foo] the package
will perform the following algorithm:

[list_begin enum]
[enum]

If [term foo] is the name of an existing file 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, that file is taken as the
implementation.

[nl]

This list of paths is initially empty and can be extended through the
object method [method search].

[enum]

If not, the list of global (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, that file is taken as the
implementation.

[nl]

This list of paths contains initially one path and can be extended
through the command [cmd ::doctools::search].

[nl]

The initial (standard) path is the sub directory [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 {ENGINES}]

The package comes with the following predefined formatting engines

[list_begin definitions]
[lst_item html]

This engine generates HTML markup, for processing by web browsers and
the like.

[lst_item latex]

This engine generates output suitable for the [syscmd latex] text
processor coming out of the TeX world.

[lst_item 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.

[lst_item 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.

[lst_item null]

This engine generates no outout at all. This can be used if one just
wants to validate some input.

[lst_item tmml]

This engine generates TMML markup as specified by Joe English. The Tcl
Manpage Markup Language is a derivate of XML.

[lst_item wiki]

This engine generates Wiki markup as understood by Jean Claude
Wippler's [syscmd wikit] application.

[list_end]

[see_also doctools_api doctools_fmt]
[keywords toc {table of contents} index documentation manpage TMML HTML nroff conversion markup]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctools.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
# doctools.tcl --
#
#	Implementation of doctools objects for Tcl.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: doctools.tcl,v 1.5 2003/03/30 07:50:25 andreas_kupries Exp $

package require Tcl 8.2
package require textutil::expander

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\
	    * 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\
	    * 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\
	    * 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\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 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 ::doctools::doctools${name}::format_ip  format_ip
    upvar ::doctools::doctools${name}::chk_ip     chk_ip
    upvar ::doctools::doctools${name}::expander   expander
    upvar ::doctools::doctools${name}::passes     passes

    if {[llength $args] == 0} {
	# Retrieve the current configuration.

	upvar ::doctools::doctools${name}::file       file
	upvar ::doctools::doctools${name}::module     module
	upvar ::doctools::doctools${name}::format     format
	upvar ::doctools::doctools${name}::copyright  copyright
	upvar ::doctools::doctools${name}::deprecated deprecated

	set     res [list]
	lappend res -file       $file
	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 ::doctools::doctools${name}::file file
		return $file
	    }
	    -module {
		upvar ::doctools::doctools${name}::module module
		return $module
	    }
	    -copyright {
		upvar ::doctools::doctools${name}::copyright copyright
		return $copyright
	    }
	    -format {
		upvar ::doctools::doctools${name}::format format
		return $format
	    }
	    -deprecated {
		upvar ::doctools::doctools${name}::deprecated deprecated
		return $deprecated
	    }
	    default {
		return -code error \
			"doctools::_configure: Unknown option \"[lindex $args 0]\", expected\
			-copyright, -file, -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 ::doctools::doctools${name}::file file
		    set file $value
		}
		-module {
		    upvar ::doctools::doctools${name}::module module
		    set module $value
		}
		-copyright {
		    upvar ::doctools::doctools${name}::copyright copyright
		    set copyright $value
		}
		-format {
		    if {[catch {
			set fmtfile [LookupFormat $name $value]
			SetupFormatter $name $fmtfile
			upvar ::doctools::doctools${name}::format format
			set format $value
		    } msg]} {
			return -code error "doctools::_configure: -format: $msg"
		    }
		}
		-deprecated {
		    if {![string is boolean $value]} {
			return -code error \
				"doctools::_configure: -deprecated expected a boolean, got \"$value\""
		    }
		    upvar ::doctools::doctools${name}::deprecated deprecated
		    set deprecated $value
		}
		default {
		    return -code error \
			    "doctools::_configure: Unknown option \"$option\", expected\
			    -copyright, -file, -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 ::doctools::doctools${name}::map map
    set map($sfname) $afname
    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 ::doctools::doctools${name}::format format
    if {$format == ""} {
	return -code error "$name: No format was specified"
    }

    upvar ::doctools::doctools${name}::format_ip format_ip
    upvar ::doctools::doctools${name}::chk_ip    chk_ip
    upvar ::doctools::doctools${name}::ex_ok     ex_ok
    upvar ::doctools::doctools${name}::expander  expander
    upvar ::doctools::doctools${name}::passes    passes
    upvar ::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 "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 "Could not initialize pass $n of engine"
	}
	$chk_ip eval ck_initialize

	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 $msg}
	    set msg [join [lrange [split $msg \n] 2 end]]

	    if {![regexp {^--> \(FmtError\) } $msg]} {return -code error @$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 fmt_postprocess $result]]}]} {
	return -code error "Unable to post process final result"
    }
    if {[catch {$format_ip eval fmt_shutdown}]} {
	return -code error "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 ::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 ::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 ::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 ::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]} {
	return $format
    }

    upvar ::doctools::doctools${name}::paths opaths
    foreach path $opaths {
	set f [file join $path fmt.$format]
	if {[file exists $f]} {
	    return $f
	}
    }

    variable paths
    foreach path $paths {
	set f [file join $path fmt.$format]
	if {[file exists $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 manipulaye
#	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_package  {} ::doctools::Package $mpip
    interp alias $mpip file        {} ::doctools::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 {
	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 ::doctools::doctools${name}::formatfile formatfile
    upvar ::doctools::doctools${name}::format_ip  format_ip
    upvar ::doctools::doctools${name}::chk_ip     chk_ip
    upvar ::doctools::doctools${name}::expander   expander
    upvar ::doctools::doctools${name}::passes     xpasses
    upvar ::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_fileid    {} ::doctools::GetFileId    $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 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 manipulaye
#
# 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 ::doctools::doctools${name}::chk_ip    chk_ip
    if {$chk_ip != ""} {return}

    upvar ::doctools::doctools${name}::expander  expander
    upvar ::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
    } {
	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
    } {
	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 manipulaye
#
# Results:
#	None.

proc ::doctools::SetupExpander {name} {
    upvar ::doctools::doctools${name}::ex_ok    ex_ok
    if {$ex_ok} {return}

    upvar ::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 ::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 ::doctools::doctools${name}::deprecated deprecated
    return $deprecated
}

# ::doctools::FmtError --
#
#	API for checker. Called when an error occured.
#
# 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 ::doctools::doctools${name}::msg msg
    lappend msg $text
    return
}

# ::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 ::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]} {
	foreach {cmd filename} $macro break
	return [ExpandInclude $name $filename]
    }

    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 ::doctools::doctools${name}::file file

    set ipath [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 ::doctools::doctools${name}::expander  expander

    return [$expander expand $text]
}

# ::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 ::doctools::doctools${name}::file file

    #puts stderr "ok $file"
    return $file
}

# ::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]]]
}

# ::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]}
    }
    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 ::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 ::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 ::doctools::doctools${name}::format format
    return $format
}

# ::doctools::ListLevel --
#
#	API for formatter. Returns numer of open lists
#
# Arguments:
#	name	Name of the doctools object to query.
#
# Results:
#	Boolean flag.

proc ::doctools::ListLevel {name} {
    upvar ::doctools::doctools${name}::chk_ip chk_ip
    return [$chk_ip eval LNest]
}

# ::doctools::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::MapFile {name fname} {
    upvar ::doctools::doctools${name}::map map

    #parray map

    if {[info exists map($fname)]} {
	return $map($fname)
    }
    return $fname
}

# ::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::Locate {p} {
    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.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctools.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require doctools
puts "doctools [package present doctools]"

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]
} 2055

# doctools .............................................................

test doctools-3.0 {doctools errors} {
    catch {new} msg
    set msg
} [tcltest::getErrorMessage "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::getErrorMessage "::doctools::_cget" "name option" 1]

test doctools-5.1 {cget errors} {
    new mydoctools
    catch {mydoctools cget foo bar} result
    mydoctools destroy
    set result
} [tcltest::tooManyMessage "::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, -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::getErrorMessage "::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, -module, -format, or -deprecated}

test doctools-6.2 {configure retrieval} {
    new mydoctools
    catch {mydoctools configure} result
    mydoctools destroy
    set result
} {-file {} -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.13 {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 -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::getErrorMessage "::doctools::_search" "name path" 1]

test doctools-7.1 {search errors} {
    new mydoctools
    catch {mydoctools search foo bar} result
    mydoctools destroy
    set result
} [tcltest::tooManyMessage "::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::getErrorMessage "::doctools::_format" "name text" 1]

test doctools-8.1 {format errors} {
    new mydoctools
    catch {mydoctools format foo bar} result
    mydoctools destroy
    set result
} [tcltest::tooManyMessage "::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]}]
    lappend res [mydoctools warnings]
    mydoctools destroy
    set res
} {manpage {seealso {} keywords {} file {} section n module {} version 1.0 title foo shortdesc {} desc {} fid {}} {}}

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]}]
    lappend res [mydoctools warnings]
    mydoctools destroy
    set res
} {manpage {seealso {} keywords {} file {} section n module {} version 1.0 title foo shortdesc {} desc {} fid {}} {{Manpage warning (depr_strong): Deprecated command "[strong {foo}]".
Manpage 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
} {Manpage error (body), "plain_text foo" : Plain text not allowed outside of the body of the manpage.}


namespace forget ::doctools::new
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































Deleted modules/doctools/doctools_api.man.

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

This manpage specifies the interface between formatting engines for
data in the [syscmd doctools] format as specified in
[syscmd doctools_fmt], and [package doctools], the package for the
generic handling of such data, as described in [syscmd doctools].

[para]

Each formatting engine has to implement the conversion of input in
[syscmd doctools] format to one particular output format as chosen by
the author of the formatting engine.

[section INTERFACE]

Each formatting engine has to provide

[list_begin enum]
[enum]

Implementations of all the formatting commands as specified in

[syscmd doctools_fmt], using the defined names, but prefixed with the
string [const fmt_]. The sole exceptions to this are the formatting
commands [cmd vset] and [cmd include]. These two commands are
processed by the generic layer and will never be seen by the
formatting engine.

[enum]
and additionally implementations for

[list_begin definitions]

[lst_item "[cmd fmt_numpasses]"]

This command is called immediately after the formatter is loaded and
has to return the number of passes required by this formatter to
process a manpage. This information has to be an integer number
greater or equal to one.

[lst_item "[cmd fmt_initialize]"]

This command is called at the beginning of every conversion run and is
responsible for initializing the general state of the formatting
engine.

[lst_item "[cmd fmt_setup] [arg n]"]

This command is called at the beginning of each pass over the input
and is given the id of the current pass as its first argument. It is
responsible for setting up the internal state of the formatting for
this particular pass.

[lst_item "[cmd fmt_postprocess] [arg text]"]

This command is called immediately after the last pass, with the
expansion result of that pass as argument, and can do any last-ditch
modifications of the generated result.  Its result will be the final
result of the conversion.

[nl]

Most formats will use [emph identity] here.

[lst_item "[cmd fmt_shutdown]"]

This command is called at the end of every conversion run and is
responsible for cleaning up of all the state in the formatting engine.

[lst_item "[cmd fmt_plain_text] [arg text]"]

This command is called for any plain text encountered by the processor
in the input and can do any special processing required for plain
text. Its result is the string written into the expansion.

[nl]

Most formats will use [emph identity] here.


[lst_item [cmd fmt_listvariables]]

The command is called after loading a formatting engine to determine
which parameters are supported by that engine. The return value is a
list containing the names of these parameters.

[lst_item "[cmd fmt_varset] [arg varname] [arg text]"]

The command is called by the generic layer to set the value of an
engine specific parameter. The parameter to change is specified by
[arg varname], and the value to set is given in [arg text].

[nl]

The command will throw an error if an unknown [arg varname] is
used. Only the names returned by [cmd fmt_listvariables] are
considered known.

[list_end]
[list_end]

[para]

The tcl code of a formatting engine implementing all of the above can
make the following assumptions about its environment

[list_begin enum]
[enum]

It has full access to its own safe interpreter.  In other words, the
engine cannot damage the other parts of the processor, nor can it
damage the filesystem.

[enum]

The surrounding system provides the engine with the following
commands:

[list_begin definitions]

[lst_item "Doctools commands"]
[list_begin definitions]
[lst_item [cmd dt_file]]
Returns the full name of the file currently processed by the engine.
[lst_item [cmd dt_fileid]]
Returns the name of the file currently processed by the engine,
without path, nor extension
[lst_item [cmd dt_format]]
Returns the name of format loaded into the engine
[lst_item [cmd dt_lnesting]]
Returns the number lists currently open
[lst_item [cmd dt_module]]
Returns the name of the module the file currently processed belongs to.
[lst_item "[cmd dt_source] [arg file]"]
This command allows the engine to load additional tcl code. The file
being loaded has to be in the same directory as the file the format
engine was loaded from. Any path specified for [arg file] is ignored.
[list_end]

[lst_item "Expander commands"]

All of the commands below are methods of the expander object (without
the prefix [const ex_]) handling the input. Their arguments and
results are described in [package expander(n)].


[list_begin definitions]
[lst_item [cmd ex_cappend]]
[lst_item [cmd ex_cget]]
[lst_item [cmd ex_cis]]
[lst_item [cmd ex_cname]]
[lst_item [cmd ex_cpop]]
[lst_item [cmd ex_cpush]]
[lst_item [cmd ex_cset]]
[lst_item [cmd ex_lb]]
[lst_item [cmd ex_rb]]
[list_end]

[lst_item "_common.tcl commands"]

Any engine loading ([cmd dt_source]) the file [file _common.tcl] has
default implementations of the [const fmt_] commands explicitly
listed in this document, and can additionally use

[list_begin definitions]
[lst_item [cmd c_inpass]]
Returns the id of the pass currently executing
[lst_item [cmd c_begin]]
Use this to mark that processing of the text after [cmd manpage_begin]
has begun.
[lst_item [cmd c_begun]]
Checks the flag set by [cmd c_begin].
[lst_item "[cmd c_set_module] [arg text]"]
Remember [arg text] as module information.
[lst_item [cmd c_get_module]]
Retrieve module information stored by [cmd c_set_module].
[lst_item "[cmd c_set_title] [arg text]"]
Remember [arg text] as title.
[lst_item [cmd c_get_title]]
Retrieve title stored by [cmd c_set_title].
[lst_item [cmd c_provenance]]
Returns a string describing how the input was processed.
[lst_item "[cmd c_pass] [arg {pass proc arguments body}]"]
Define a procedure which is valid when pass [arg pass] of the engine
is executed.
[lst_item "[cmd c_holdBuffers] [arg args]"]
Define one or more buffers for holding data between passes.
[lst_item "[cmd c_hold] [arg {buffer entry}]"]
Add an entry to the specified buffer. The buffer has to be defined by
an earlier invocation of the command [cmd c_holdBuffers].
[lst_item "[cmd c_held] [arg buffer]"]
Retrieves the contents of the specified buffer. The buffer is empty
afterwards. All entries in the buffer are joined by newlines.
[lst_item [cmd c_cnext]]
Increment the counter and return its current value.
[lst_item [cmd c_cinit]]
Push the current counter on the stack and reinitialize the counter to zero.
[lst_item [cmd c_creset]]
Reinitialize the counter with the value on the counter stack and
remove that value from the stack.
[lst_item "[cmd NOP] [arg args]"]
Do nothing command. Can be used in conjunction with [cmd c_pass] to
visibly declare in which passes a formatting command has nothing to do.
[lst_item "[cmd NYI] [opt [arg message]]"]
Throws the error "[arg message] [const {Not yet implemented}]".
[lst_item "[cmd c_sectionId] [arg name]"]
Remembers the name of the section for later cross-referencing
[lst_item "[cmd c_possibleReference] [arg {text gi}]"]
Checks if a section is available for [arg text]. This command is
currently tuned for use by engines like HTML and TMML.
[list_end]

[list_end]
[list_end]

[see_also doctools_fmt doctools]
[keywords markup {generic markup} manpage TMML HTML nroff LaTeX]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































Deleted modules/doctools/doctools_fmt.man.

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

This manpage specifies a documentation format for manpages. It is
intended to complement both the [syscmd doctoc] format for writing
tables of contents and the [syscmd docidx] format for writing indices.
See [syscmd doctoc_fmt] and [syscmd docidx_fmt] for the specification
of these two formats.


[para]

This format is called [syscmd doctools].

It provides all the necessary commands to write manpages.

Like for the [syscmd doctoc] and [syscmd docidx] formats a package is
provided implementing a generic framework for the conversion of
[syscmd doctools] to a number of different output formats, like HTML,
TMML, nroff, LaTeX, etc.

The package is called [package doctools], its documentation can be
found in [syscmd doctools].

People wishing to write a formatting engine for the conversion of
[syscmd doctools] into a new output format have to read
[syscmd doctools_api]. This manpage will explain the interface between
the generic package and such engines.


[section OVERVIEW]

[syscmd doctoc] is similar to LaTex in that it consists primarily of
text, with markup commands embedded into it. The format used to mark
something as command is different from LaTeX however. All text between
matching pairs of [lb] and [rb] is a command, possibly with
arguments. Note that both brackets have to be on the same line for a
command to be recognized.

[para]

In contrast to both [syscmd doctoc] and [syscmd docidx] this format
does allow plain text beyond white space. This plain text will be the
contents of the described manpage.


[section {FORMATTING COMMANDS}]
[list_begin bullet]
[bullet]

The main commands are [cmd manpage_begin], [cmd manpage_end],
[cmd moddesc], [cmd titledesc], and [cmd description]. Four of these
five are required for a manpage. The optional command is
[cmd titledesc]. The first two are the first and last commands in a
manpage. Neither text nor other commands may precede
[cmd manpage_begin] nor follow [cmd manpage_end].  The command
[cmd description] separates header and body of the manpage and may not
be omitted.

[nl]

The remaining commands ([cmd moddesc] and [cmd titledesc]) provide
one-line descriptions of module and specific title respectively.

[bullet]
The only text allowed between [cmd manpage_begin] and
[cmd description] is the command [cmd require]. Other commands or
normal text are not permitted. [cmd require] is used to list the
packages the described command(s) depend(s) on for its operation. This
list can be empty.

[bullet]
After [cmd description] text and all other commands are allowed. The
text can be separated into highlevel blocks using named
[cmd section]s.  Each block can be further divided into paragraphs via
[cmd para].

[bullet]
The commands [cmd see_also] and [cmd keywords] define whole sections
named [emph {SEE ALSO}] and [emph KEYWORDS]. They can occur everywhere
in the manpage but making them the last section is the usual thing to
do. They can be omitted.

[bullet]

There are five commands available to markup words, [cmd arg],

[cmd cmd], [cmd opt], [cmd emph] and [cmd strong]. The first three are
used to mark words as [emph {command arguments}], as

[emph {command names}] and as [emph optional]. The other two are
visual markup to emphasize words. The term [emph words] is used in a
loose sense here, i.e application of the commands to a sequence of
words is entirely possible, if they are properly quoted. [emph Note]
that usage of [cmd strong] is discouraged as this command is
deprecated and only present for backwards compatibility

[bullet]

Another set of commands is available to construct (possibly nested)
lists. These are [cmd list_begin], [cmd list_end], [cmd lst_item],
[cmd bullet], [cmd enum], [cmd call], [cmd arg_def], [cmd opt_def],
[cmd cmd_def], and [cmd tkoption_def]. The first two of these begin
and end a list respectively.

[nl]

The argument to the first command denotes the type of the list. The
allowed values and their associated item command are explained later,
in the section detailing the [sectref Commands].

[nl]

The other commands start list items and each can be used only inside a
list of their type. In other words, [cmd bullet] is allowed in
bulletted lists but nowhere else, [cmd enum] in enumerated lists and
[cmd lst_item] and [cmd call] are for definition lists. These two
commands also have some text directly associated with the item
although the major bulk of the item is the text following the item
until the next list command.

[nl]

The last list command, [cmd call] is special. It is used to describe
the syntax of a command and its arguments. It should not only cause
the appropriate markup of a list item at its place but also add the
syntax to the table of contents (synopsis) if supported by the output
format in question. nroff and HTML for example do. A format focused on
logical markup, like TMML, may not.

[bullet]
The command [cmd usage] is similar to [cmd call] in that it adds the
syntax to the table of contents (synopsis) if supported by the output
format. Unlike [cmd call],  this command doesn't add any text to the
output as a direct result of the command. Thus, it can be used
anywhere within the document to add usage information. Typically it is
used near the top of the document, in cases where it is not desireable
to use [cmd call] elsewhere in the document, or where additional usage
information is desired (e.g.: to document a "package require" command).

[list_end]

[section Commands]
[list_begin definitions]

[call [cmd vset] [arg varname] [arg value] ]

Sets the formatter variable [arg varname] to the specified
[arg value]. Returns the empty string.

[call [cmd vset] [arg varname]]

Returns the value associated with the formatter variable
[arg varname].

[call [cmd include] [arg filename]]

Reads the file named [arg filename], runs it through the expansion
process and returns the expanded result.


[call [cmd manpage_begin] [arg command] [arg section] [arg version]]

This command begins a manpage. Nothing is allowed to precede
it. Arguments are the name of the command described by the manpage,
the section of the manpages this manpages lives in, and the version of
the module containing the command. All have to fit on one line.

[call [cmd manpage_end]]

This command closes a manpage. Nothing is allowed to follow it.

[call [cmd moddesc] [arg desc]]

This command is required and comes after [cmd manpage_begin], but
before either [cmd require] or [cmd description]. Its argument
provides a one-line description of the module described by the manpage.

[call [cmd titledesc] [arg desc]]

This command is optional and comes after [cmd manpage_begin], but
before either [cmd require] or [cmd description]. Its argument
provides a one-line expansion of the title for the manpage. If this
command is not used the manpage processor has to use information from
[cmd moddesc] instead.

[call [cmd copyright] [arg text]]

This command is optional and comes after [cmd manpage_begin], but
before either [cmd require] or [cmd description]. Its argument
declares the copyright assignment for the manpage. When invoked more
than once the assignments are accumulated.

[nl]

A doctools processor is allowed to provide auch information too, but a
formatting engine has to give the accumulated arguments of this
command precedence over the data coming from the processor.

[call [cmd description]]

This command separates the header part of the manpage from the main
body. Only [cmd require], [cmd moddesc], or [cmd titledesc] may
precede it.

[call [cmd require] [arg pkg] [opt [arg version]]]

May occur only between [cmd manpage_begin] and [cmd description]. Is
used to list the packages which are required for the described command
to be operational.

[call [cmd section] [arg name]]

Used to structure the body of the manpage into named sections. This
command is not allowed inside of a list or example. It implicitly
closes the last [cmd para]graph before the command and also implicitly
opens the first paragraph of the new section.

[call [cmd para]]

Used to structure sections into paragraphs. Must not be used inside of
a list or example.

[call [cmd see_also] [arg args]]

Creates a section [emph {SEE ALSO}] containing the arguments as
cross-references. Must not be used inside of a list or example.

[call [cmd keywords] [arg args]]

Creates a section [emph KEYWORDS] containing the arguments as words
indexing the manpage. Must not be used inside of a list or example.

[call [cmd arg] [arg text]]

Declares that the marked [arg text] is the name of a command argument.

[call [cmd cmd] [arg text]]

Declares that the marked [arg text] is the name of a command.

[call [cmd opt] [arg text]]

Declares that the marked [arg text] is something optional. Most often used
in conjunction with [cmd arg] to denote optional command arguments.

[call [cmd emph] [arg text]]

Emphasize the [arg text].

[call [cmd strong] [arg text]]

Emphasize the [arg text]. Same as [cmd emph]. Usage is
discouraged. The command is deprecated and present only for backward
compatibility.

[call [cmd comment] [arg text]]

Declares that the marked [arg text] is a comment.

[call [cmd sectref] [arg text]]

Declares that the marked [arg text] is a section reference.

[call [cmd syscmd] [arg text]]

Declares that the marked [arg text] is a system command.

[call [cmd method] [arg text]]

Declares that the marked [arg text] is a object method.

[call [cmd option] [arg text]]

Declares that the marked [arg text] is a option.

[call [cmd widget] [arg text]]

Declares that the marked [arg text] is a widget.

[call [cmd fun] [arg text]]

Declares that the marked [arg text] is a function.

[call [cmd type] [arg text]]

Declares that the marked [arg text] is a data type.

[call [cmd package] [arg text]]

Declares that the marked [arg text] is a package.

[call [cmd class] [arg text]]

Declares that the marked [arg text] is a class.

[call [cmd var] [arg text]]

Declares that the marked [arg text] is a variable.

[call [cmd file] [arg text]]

Declares that the marked [arg text] is a file .

[call [cmd uri] [arg text]]

Declares that the marked [arg text] is a uri.

[call [cmd term] [arg text]]

Declares that the marked [arg text] is a unspecific terminology.

[call [cmd const] [arg text]]

Declares that the marked [arg text] is a constant value.

[call [cmd nl]]

Vertical space to separate text without breaking it into a new
paragraph.

[call [cmd lb]]

Introduces a left bracket into the output.

[call [cmd rb]]

Introduces a right bracket into the output. The bracket commands are
necessary as plain brackets are used to denote the beginnings and
endings of the formatting commands.

[call [cmd example_begin]] 
Formats subsequent text as a code sample:
line breaks, spaces, and tabs are preserved and,
where appropriate, text is presented in a fixed-width font.

[call [cmd example_end]] 
End of a code sample block.

[call [cmd example] [arg text]] 

Formats [arg text] as a multi-line block of sample code.
[arg text] should be enclosed in braces.

[call [cmd list_begin] [arg what]]

Starts new list of type [arg what]. The allowed types (and their
associated item commands) are:

[list_begin definitions]
[lst_item [emph bullet]]
[cmd bullet]

[lst_item [emph enum]]
[cmd enum]

[lst_item [emph definitions]]
[cmd lst_item] and [cmd call]

[lst_item [emph arg]]
[cmd arg_def]

[lst_item [emph cmd]]
[cmd cmd_def]

[lst_item [emph opt]]
[cmd opt_def]

[lst_item [emph tkoption]]
[cmd tkoption_def]

[list_end]


[call [cmd list_end]]

Ends the list opened by the last [cmd list_begin].

[call [cmd bullet]]

Starts a new item in a bulletted list.

[call [cmd enum]]

Starts a new item in an enumerated list.

[call [cmd lst_item] [arg text]]

Starts a new item in a definition list. The argument is the term to be
defined.

[call [cmd call] [arg args]]

Starts a new item in a definition list, but the term defined by it is
a command and its arguments.

[call [cmd arg_def] [arg type] [arg name] [opt [arg mode]]]

Starts a new item in an argument list. Specifies the data-[arg type]
of the described argument, its [arg name] and possibly its
i/o-[arg mode].

[call [cmd opt_def] [arg name] [opt [arg arg]]]

Starts a new item in an option list. Specifies the [arg name] of the
option and possible (i.e. optional) [arg arg]uments.

[call [cmd cmd_def] [arg command]]

Starts a new item in a command list. Specifies the name of the
[arg command].

[call [cmd tkoption_def] [arg name] [arg dbname] [arg dbclass]]

Starts a new item in a widget option list.  Specifies the [arg name]
of the option, i.e.  the name used in scripts, name used by the option
database, and the class (type) of the option.

[call [cmd usage] [arg args]]

Defines a term to be used in the table of contents or synopsis section,
depending on the format. This command is [emph silent], as it doesn't
add any text to the output as a direct result of the call. It merely
defines data to appear in another section.

[list_end]

[section EXAMPLE]

The tcl sources of this manpage can serve as an example for all of the
markup described by it. Almost every possible construct (with the
exception of [cmd require]) is used here.

[see_also doctoc_fmt docidx_fmt doctools_api doctools]
[keywords markup {generic markup} manpage TMML HTML nroff LaTeX]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/mpexpand.

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


















































































































































































































































































































Deleted modules/doctools/mpexpand.all.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
#!/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
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































Deleted modules/doctools/mpexpand.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin mpexpand n 1.0]
[copyright {2002 Andreas Kupries <[email protected]>}]
[copyright {2003 Andreas Kupries <[email protected]>}]
[moddesc   {Documentation toolbox}]
[titledesc {Markup processor}]
[description]
[para]

This manpage describes a processor / converter for manpages in the
doctools format as specified in [cmd dtformat]. 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].

[nl]

If the option [arg -module] is present its value overrides the internal
definition of the module name.

[nl]

The currently known output formats are

[list_begin definitions]

[lst_item [const nroff]]

The processor generates *roff output, the standard format for unix
manpages.

[lst_item [const html]]

The processor generates HTML output, for usage in and display by web
browsers.

[lst_item [const tmml]]

The processor generates TMML output, the Tcl Manpage Markup Language,
a derivative of XML.

[lst_item [const latex]]

The processor generates LaTeX output.

[lst_item [const wiki]]

The processor generates Wiki markup as understood by [syscmd wikit].

[lst_item [const list]]

The processor extracts the information provided by [cmd manpage_begin].

[lst_item [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.

[nl]

The [arg module] information is passed to [cmd mpexpand].

[list_end]

[section NOTES]
[para]

Possible future formats are plain text, pdf and postscript.

[see_also expander(n) format(n) formatter(n)]
[keywords manpage TMML HTML nroff conversion markup]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































Deleted modules/doctools/mpformats/_common.tcl.

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

################################################################
# 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 {}}

    return "Copyright [c_copyrightsymbol] [join $cc "\nCopyright [c_copyrightsymbol] "]"
}

proc c_provenance {} {
    return "Generated from file '[dt_file]' 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'

# sectionId --
#	Format section name as an XML ID.
#
proc c_sectionId {name} {
    regsub -all {[^[:alnum:]]} $name {} name
    return [string tolower $name]
}

# 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} {
    global SectionNames
    if {[info exists SectionNames($text)]} {
    	return "[startTag ref refid $SectionNames($text)]$text[endTag ref]"
    } else {
    	return [wrap $text $gi]
    }
}

######################################################################
# 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

################################################################
# 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__ {}
}

proc c_xref_seealso  {} {global seealso  ; return $seealso}
proc c_xref_keywords {} {global keywords ; return $keywords}

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_see_also {args} NOP
c_pass 2 fmt_keywords {args} NOP

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/_html.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
# -*- tcl -*-
# 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
    return [string map $finalMap $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</b><br><hr>"]}
proc link   {text url} {return [markup "<a href=\"$url\">$text</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 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 protect {text} {return [string map [list & "&amp;" < "&lt;" > "&gt;"] $text]}


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 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}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































Deleted modules/doctools/mpformats/_idx_common.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# -*- tcl -*-
#
# _idx_common.tcl
#
# (c) 2003 Andreas Kupries <[email protected]>

################################################################
# 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]'"
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted modules/doctools/mpformats/_nroff.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
# -*- tcl -*-
#
# -- nroff commands
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>


################################################################
# nroff specific commands
#
# All dot-commands (f.e. .PP) are returned with a leading \n,
# enforcing that they are on a new line. Any empty line created
# because of this is filtered out in the post-processing step.


proc nr_lp      {}          {return \n.LP}
proc nr_ta      {{text {}}} {return ".ta$text"}
proc nr_bld     {}          {return \\fB}
proc nr_ul      {}          {return \\fI}
proc nr_rst     {}          {return \\fR}
proc nr_p       {}          {return \n.PP\n}
proc nr_comment {text}      {return "'\\\" [join [split $text \n] "\n'\\\" "]"} ; # "
proc nr_enum    {num}       {nr_item " \[$num\]"}
proc nr_item    {{text {}}} {return "\n.IP$text"}
proc nr_vspace  {}          {return \n.sp}
proc nr_blt     {text}      {return "\n.TP\n$text"}
proc nr_bltn    {n text}    {return "\n.TP $n\n$text"}
proc nr_in      {}          {return \n.RS}
proc nr_out     {}          {return \n.RE}
proc nr_nofill  {}          {return \n.nf}
proc nr_fill    {}          {return .fi}
proc nr_title   {text}      {return "\n.TH $text"}
proc nr_include {file}      {return "\n.so $file"}
proc nr_bolds   {}          {return \n.BS}
proc nr_bolde   {}          {return \n.BE}

proc nr_section {name}      {return "\n.SH \"$name\""}


################################################################

proc nroff_postprocess {nroff} {
    # 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 .nf .CS]	; # commands which start no-fill mode
    set fiMode   [list .fi .CE]	; # commands which terminate no-fill mode
    set lines    [list]         ; # Result buffer
    set verbatim 0              ; # Automaton mode/state

    foreach line [split $nroff "\n"] {
	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}
	} 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
    }
    # Return the modified result buffer
    return [join $lines "\n"]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































Deleted modules/doctools/mpformats/_text.tcl.

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

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.
# - 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 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 agasin 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
    #puts_stderr "SECT $text"
    #puts_stderr ""

    # Write section title, underline it

    lappend linebuffer ""
    lappend linebuffer $text
    lappend linebuffer [textutil::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::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 $text -length $size]
    }

    # Now apply prefixes, (ws prefixes bulleting), at last indentation.

    if {[string length $para(prefix)] > 0} {
	set text [textutil::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::indent $text $para(wspfx)]"
	} else {
	    set fprefix $thebullet[string range $para(wspfx) $blen end]
	    set text    "${fprefix}[textutil::indent $text $para(wspfx) 1]"
	}
    }

    if {$para(lmargin) > 0} {
	set text [textutil::indent $text [textutil::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)]"
    }
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/_toc_common.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
# -*- tcl -*-
#
# _toc_common.tcl
#
# (c) 2003 Andreas Kupries <[email protected]>

################################################################
# 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]'"
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































Deleted modules/doctools/mpformats/_xml.tcl.

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
























































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/c.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
# -*- 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 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."

# 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\]"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































Deleted modules/doctools/mpformats/de.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
# -*- 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 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 Aufzaehlungs-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 Ausfuehrung 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 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."
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































Deleted modules/doctools/mpformats/en.msg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
# -*- 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 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 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\]"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































Deleted modules/doctools/mpformats/fmt.html.

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

proc bgcolor {} {return ""}
proc border  {} {return 0}
proc Year    {} {clock format [clock seconds] -format %Y}

# 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} {
    global SectionNames
    if {[info exists SectionNames($text)]} {
	return [taga a [list href #$SectionNames($text)]]$text[tag/ a]
    } else {
	return [tag $gi]$text[tag/ $gi]
    }
}

c_holdBuffers require

################################################################
## 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
global hintstack ; # stack of hint information.
global chint     ; # current hint settings
global lmark     ; # boolean flag, 1 = list item command was last
#                ; #               0 = something other than a list item command

set    liststack [list]
set    hintstack [list]
set    chint     ""
set    lmark     0

proc llevel {} {global liststack ; return [llength $liststack]}

proc lpush {t hint} {
    global  liststack hintstack chint
    lappend liststack [tag/ $t]
    lappend hintstack $chint
    set     chint $hint
    return [tag $t]
}

proc lpop {} {
    global liststack hintstack chint
    set t         [lindex   $liststack end]
    set liststack [lreplace $liststack end end]
    set chint     [lindex   $hintstack end]
    set hintstack [lreplace $hintstack end end]
    return $t
}

proc lsmark {value} {
    global lmark ; set lmark $value ; return
}

proc limark {} {
    # hint and mark processing.
    # hint: compact list, do not create additional whitespace
    if {[lcompact]} {return ""}

    # hint: wide list, create additional whitespace.
    # mark: exception: two list items following each other have no whitespace.
    global lmark ; if {$lmark} {return ""}
    return [tag br][tag br]\n
}

proc lcompact {} {global chint ; string equal $chint compact}

proc fmt_plain_text {text} {
    # Control list state
    set redux [string map [list " " "" "\t" "" "\n" ""] $text]
    if {$redux != {}} {lsmark 0}
    return $text
}

################################################################
# Formatting commands.

c_pass 1 fmt_manpage_begin {title section version} {c_cinit ; return}
c_pass 2 fmt_manpage_begin {title section version} {
    c_cinit
    set module      [dt_module]
    set shortdesc   [c_get_module]
    set description [c_get_title]
    set copyright   [c_get_copyright]

    set     hdr ""
    append  hdr "[markup <html><head>]\n"
    append  hdr "[markup <title>]$title - $shortdesc [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
    if {$copyright != {}} {
	append  hdr [ht_comment $copyright]\n
    }
    append  hdr [ht_comment "CVS: \$Id\$ $title.$section"]\n
    append  hdr \n
    append  hdr [markup <body>]\n

    # Engine parameter - insert 'header'
    if {[set header [Get header]] != {}} {append hdr [markup $header]\n}

    append  hdr "[markup <h1>] [string trimleft $title :]($section) $version $module \"$shortdesc\"[markup </h1>]\n"
    append  hdr [fmt_section NAME]\n
    append  hdr "[fmt_para] $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 ct [c_get_copyright]

    if {[llength $sa] > 0} {
	append res [fmt_section {SEE ALSO}] \n
	append res [join [XrefList [lsort $sa] sa] ", "] \n
    }
    if {[llength $kw] > 0} {
	append res [fmt_section KEYWORDS] \n
	append res [join [XrefList [lsort $kw] kw] ", "] \n
    }
    if {$ct != {}} {
	append res [fmt_section COPYRIGHT] \n
	append res [join [split $ct \n] [tag br]\n] [tag br]\n
    }

    # Engine parameter - insert 'footer'
    if {[set footer [Get footer]] != {}} {append res [markup $footer]\n}

    append res [markup </body></html>]
    return $res
}

c_pass 1 fmt_section     {name} { set ::SectionNames($name) [c_sectionId $name] }
c_pass 2 fmt_section     {name} {
    set id [c_sectionId $name]
    return "[markup <h2><]a name=[markup \"]$id[markup \">]$name[markup </a></h2>\n<p>]"
}

proc fmt_para {} {return [markup <p>]}

c_pass 2 fmt_require {pkg {version {}}} NOP
c_pass 1 fmt_require {pkg {version {}}} {
    set result "package require [markup <b>]$pkg"
    if {$version != {}} {
	append result " $version"
    }
    append result [markup "</b><br>"]
    c_hold require $result
    return
}

c_pass 2 fmt_usage {cmd args} NOP
c_pass 1 fmt_usage {cmd args} {c_hold synopsis "[trtop][td]$cmd [join $args " "][markup </td></tr>]"}

c_pass 1 fmt_call {cmd args} {
    c_hold synopsis "[trtop][td][markup "<a href=\"#[c_cnext]\">"]$cmd [join $args " "][markup </a></td></tr>]"
}
c_pass 2 fmt_call {cmd args} {
    return "[fmt_lst_item "[markup "<a name=\"[c_cnext]\">"]$cmd [join $args " "][markup </a>]"]\n"
}

c_pass 1 fmt_description {} NOP
c_pass 2 fmt_description {} {
    set result ""
    set syn [c_held synopsis]
    set req [c_held require]
    if {$syn != {} || $req != {}} {
	append result [fmt_section SYNOPSIS]\n
    }
    if {$req != {}} {
	append result $req \n
	append result [markup <br>]
    }
    if {$syn != {}} {
	proc bgcolor {} {return lightyellow}

	append result [btable][tr][td][table]${syn}\n[markup </table></td></tr></table>]\n

	proc bgcolor {} {return ""}
    }
    append result [fmt_section DESCRIPTION]
    return $result
}

################################################################

proc fmt_list_begin  {what {hint {}}} {
    switch -exact -- $what {
	enum        {set tag ol}
	bullet      {set tag ul}
	arg - cmd - opt - tkoption -
	definitions {set tag dl}
    }
    return [if {[llevel]} {limark} else {}][lpush $tag $hint][lsmark 1]
}

proc fmt_list_end {}        {return [lpop][lsmark 1]}
proc fmt_lst_item {text}    {return [limark][tag dt]$text[tag dd][lsmark 1]}
proc fmt_bullet   {}        {return [limark][tag li][lsmark 1]}
proc fmt_enum     {}        {return [limark][tag li][lsmark 1]}
proc fmt_cmd_def  {command} {fmt_lst_item [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][markup <br>]\n"
    append text "Database Name:\t[strong $dbname][markup <br>]\n"
    append text "Database Class:\t[strong $dbclass][markup <br>]\n"
    fmt_lst_item $text
}


################################################################

proc fmt_example_begin {} {
    lsmark 0
    return [markup "<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>"]
}
proc fmt_example_end   {} {
    return [markup "</pre></td></tr></table></p>"]
}
proc fmt_example {code} {
    return "[fmt_example_begin][fmt_plain_text $code][fmt_example_end]"
}

proc fmt_nl {} {
    if {[lcompact]} {return [tag br]}
    return [tag br][tag br]
}
proc fmt_arg    {text} {return "[markup "<i class='arg'>"]$text[markup </i>]" }
proc fmt_cmd    {text} {return "[markup "<b class='cmd'>"][XrefMatch $text sa][markup </b>]" }

proc fmt_emph	{text}	{ em $text }

proc strong {text} {return "[markup <strong>]$text[markup </strong>]"}
proc em     {text} {return "[markup <em>]$text[markup </em>]"}


proc fmt_opt     {text} {return "?$text?" }
proc fmt_comment {text} {ht_comment $text}
proc fmt_sectref {text} {
    global SectionNames
    if {[info exists SectionNames($text)]} {
    	return "[markup <]a href=[markup \"]#$SectionNames($text)[markup \">]$text[markup </a>]"
    } else {
    	return "[markup <b>]$text[markup </b>]"
    }
}
proc fmt_syscmd  {text} {strong [XrefMatch $text sa]}
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 "\"[strong $text]\""}
proc fmt_uri     {text} {return "[markup <]a href=[markup \"]$text[markup \">]$text[markup </a>]"}
proc fmt_term    {text} {em [XrefMatch $text kw]}
proc fmt_const   {text} {strong $text}

################################################################

global xref ; array set xref {}

global    __var
array set __var {
    meta   {}
    header {}
    footer {}
    xref   {}
}
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
}

################################################################

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 ext} {
    global xref

    #puts_stderr "$word $ext"
    #foreach {k v} [array get xref] {puts_stderr "$k\t $v"}

    if {$ext != {}} {
	if {[info exists xref($ext,$word)]} {
	    return [XrefLink $xref($ext,$word) $word]
	}
    }
    if {[info exists xref($word)]} {
	return [XrefLink $xref($word) $word]
    }
    return $word
}

proc XrefList {list {ext {}}} {
    XrefInit
    set res [list]
    foreach w $list {lappend res [XrefMatch $w $ext]}
    return $res
}

proc XrefLink {dest label} {
    # Ensure that the link is properly done relative to this file!

    set save $dest

    #puts_stderr "XrefLink $dest $label"

    set here [file split [dt_fmap [dt_file]]]
    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 "[markup "<a href=\"$dest\">"] $label [markup </a>]" ; # "
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/fmt.latex.

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

# 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

################################################################
## Backend for LaTeX 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 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 "\\documentclass\{article\}" \n
    append  hdr "\\begin\{document\}" \n
    append  hdr "\\author\{[dt_user]\}" \n

    set    titletext ""
    append titletext "$module / $title \\\\"
    append titletext "$shortdesc : $description"

    append  hdr "\\title\{[texEscape $titletext]\}" \n
    append  hdr "\\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 ct [c_get_copyright]

    if {[llength $sa] > 0} {
	append res [fmt_section {SEE ALSO}] \n
	append res [join [lsort $sa] ", "] \n
    }
    if {[llength $kw] > 0} {
	append res [fmt_section KEYWORDS] \n
	append res [join [lsort $kw] ", "] \n
    }
    if {$ct != {}} {
	append res [fmt_section COPYRIGHT] \n
	append res \\begin\{flushleft\} \n
	append res [join [split $ct \n] \\linebreak\n] \\linebreak\n
	append res \\end\{flushleft\} \n
    }
    append  res "\\end\{document\}"
    return $res
}



proc fmt_section {name} {return "\\section\{$name\}"}
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 "\\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 "\\item\[\] $cmd [join $args " "]"}

c_pass 1 fmt_description {} NOP
c_pass 2 fmt_description {} {
    set res ""
    set req [c_held require]
    set syn [c_held synopsis]
    if {$req != {} || $syn != {}} {
	append res [fmt_section SYNOPSIS]\n
	if {$req != {}} {
	    append res \\begin\{flushleft\} \n
	    append res $req \n
	    append res \\end\{flushleft\} \n
	}
	if {$syn != {}} {
	    append res "\\begin\{itemize\}" \n
	    append res ${syn} \n\n
	    append res "\\end\{itemize\}" \n
	}
    }
    append res [fmt_section DESCRIPTION]
    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 {
	enum {
	    return \\begin\{enumerate\}
	}
	bullet - arg - opt - cmd - tkoption - definitions {
	    return \\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 {
	enum {
	    return \\end\{enumerate\}
	}
	bullet {
	    return \\end\{itemize\}
	}
	definitions - arg - opt - cmd - tkoption {
	    if {$item} {
		return \\end\{quote\}\n\\end\{itemize\}
	    } else {
		return \\end\{itemize\}
	    }
	}
	default {
	    return -code error "Must not happen"
	}
    }
}

proc fmt_bullet {} {return "\\item\n"}
proc fmt_enum   {} {return "\\item\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]
    if {$item} {
	return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n"
    } else {
	return "\\item\[\] $text\n\\begin\{quote\}\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)"}

    if {$item} {
	return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n"
    } else {
	return "\\item\[\] $text\n\\begin\{quote\}\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]

    if {$item} {
	return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n"
    } else {
	return "\\item\[\] $text\n\\begin\{quote\}\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"}

    if {$item} {
	return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n"
    } else {
	return "\\item\[\] $text\n\\begin\{quote\}\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"

    if {$item} {
	return "\\end\{quote\}\n\\item\[\] $text\n\\begin\{quote\}\n"
    } else {
	return "\\item\[\] $text\n\\begin\{quote\}\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 "\\begin\{verbatim\}\n${code}\n\\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} {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 "\"[Italic $text]\""}
proc fmt_uri     {text} {Underline $text}
proc fmt_term    {text} {Italic $text}
proc fmt_const   {text} {Bold $text}


################################################################
# latex specific commands

proc Comment   {text} {return "% [join [split $text \n] "\n% "]"}
proc Bold      {text} {return "\{\\bf [texEscape $text]\}"}
proc Italic    {text} {return "\{\\it [texEscape $text]\}"}
proc Underline {text} {return "\\underline\{[texEscape $text]\}"}

################################################################

proc texEscape {text} {
    string map {_ \\_ % \\% $ \\$ < $<$ > $>$ # \\# & \\&} $text
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/fmt.list.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
# -*- tcl -*-
#
# -- Extraction of basic meta information (title section version) from a manpage.
#
# Copyright (c) 2001-2002 Andreas Kupries <[email protected]>
# Copyright (c) 2003     Andreas Kupries <[email protected]>
#
################################################################

# 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]
    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}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































Deleted modules/doctools/mpformats/fmt.nroff.

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

    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_include man.macros]
    c_hold hdr [nr_title "\"[string trimleft $title :]\" $section $version $module \"$shortdesc\""]
    c_hold hdr [nr_bolds]
    c_hold hdr [fmt_section NAME]
    c_hold hdr "$title \\- $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 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
	append nroff [join [lsort $kw] ", "] \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} {return [nr_section $name]}
proc fmt_para {} {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[fmt_nl]"
}

c_pass 1 fmt_usage {cmd args} {c_hold synopsis "$cmd [join $args " "][nr_rst]\n[fmt_nl]"}
c_pass 2 fmt_usage {cmd args} NOP

c_pass 1 fmt_call  {cmd args} {c_hold synopsis       "$cmd [join $args " "][nr_rst]\n[fmt_nl]"}
c_pass 2 fmt_call  {cmd args} {return "[fmt_lst_item "$cmd [join $args " "][nr_rst]"]"}

c_pass 1 fmt_description {} NOP
c_pass 2 fmt_description {} {
    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] > 1} {
	return [nr_in]
    }
    return {}
}

proc fmt_list_end {} {
    c_creset
    if {[dt_lnesting] > 0} {
	return [nr_out]
    }
    return {}
}

proc fmt_enum     {}        {return [nr_item " \[[c_cnext]\]\n"]}
proc fmt_bullet   {}        {return [nr_item " \\(bu"]}
proc fmt_lst_item {text}    {return [nr_blt $text]}
proc fmt_cmd_def  {command} {return [nr_blt [cmd $command]]}

proc fmt_arg_def {type name {mode {}}} {
    set    text [nr_blt ""]
    append text [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 [option $name]
    if {$arg != {}} {append name " $arg"}
    return [nr_blt $name]
}
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 "\n[nr_nofill]" }
proc fmt_example_end   {} { nr_fill }
proc fmt_example {code} { 
    set lines [list "" [nr_nofill]] 
    foreach line [split $code "\n"] {
    	lappend lines [fmt_plain_text $line]
    }
    lappend lines [nr_fill] ""
    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} {return [nr_bld]$text[nr_rst]}
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} {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_uri     {text} {underline $text}
proc fmt_term    {text} {underline $text}
proc fmt_const   {text} {bold $text}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































Deleted modules/doctools/mpformats/fmt.null.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
# -*- tcl -*-
#
# -- Null format
#
# Copyright (c) 2001-2002 Andreas Kupries <[email protected]>
# Copyright (c) 2003      Andreas Kupries <[email protected]>

# 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
    sectref syscmd method option widget fun type package class var
    file uri term const copyright
} {
    proc fmt_$p {args} {return ""}
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































Deleted modules/doctools/mpformats/fmt.text.

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

# 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 {
	enum                                     {NewOrderedList}
	bullet                                   {NewUnorderedList}
	arg - cmd - opt - tkoption - 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::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::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 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 {$ct != {}}         {Section COPYRIGHT  ; Text $ct ; CloseParagraph [Verbatim]}
    return
}

c_pass 1 fmt_section     {name} NOP
c_pass 2 fmt_section     {name} {CloseParagraph ; Section $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 {} NOP
c_pass 2 fmt_description {} {
    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 [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} {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_uri     {text} {return "<URL:$text>"}
proc fmt_term    {text} {em     $text}
proc fmt_const   {text} {strong $text}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/fmt.tmml.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
# -*- tcl -*-
#
# $Id: fmt.tmml,v 1.15 2003/03/12 04:48:44 andreas_kupries Exp $
#
# [expand] definitions to convert a tcl based manpage definition
# into TMML.
#
# Copyright (C) 2001 Joe English <[email protected]>.
# 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}	;# 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}	{ c_possibleReference $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} {c_possibleReference $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_uri     {text} {wrap $text url}
proc fmt_term    {text} {wrap $text term}
proc fmt_const   {text} {wrap $text l}


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 {} NOP
c_pass 2 fmt_description {} {
    sequence \
	[xmlContext manpage] \
	[wrapLines? [c_held synopsis] syntax synopsis] \
	[start section] \
	[wrap "DESCRIPTION" title] \
	;
}

c_pass 1 fmt_section {name} { set ::SectionNames($name) [c_sectionId $name] }
c_pass 2 fmt_section {name} {
    sequence \
	[xmlContext manpage] \
    	[start section id [c_sectionId $name]] \
	[wrap [string toupper $name] title] \
	;
}
c_pass 1 fmt_para {} NOP
c_pass 2 fmt_para {} { sequence [xmlContext section] [start p] }

foreach {type gi} {
    bullet	ul
    enum	ol
    definitions	dl
    arg		arglist
    cmd		commandlist
    opt		optlist
    tkoption	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 {section dd li}] \
	[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"
}

c_pass 1 fmt_see_also	{args} { holdWrapped see_also $args ref }
c_pass 1 fmt_keywords   {args} { holdWrapped keywords $args keyword }
c_pass 2 fmt_see_also	{args} NOP
c_pass 2 fmt_keywords	{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*

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/fmt.wiki.

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


################################################################
## 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 '''$module''' ''$shortdesc''" \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 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 {$ct != {}} {
	append wiki [fmt_section COPYRIGHT]
	append wiki ". " [join [split $copyright \n] "\n. "] \n
    }
    return $wiki
}

proc fmt_section {name} {return "\n\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"}
    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 {} NOP
c_pass 2 fmt_description {} {
    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
}

################################################################

proc fmt_list_begin {what {hint {}}} {return {}}
proc fmt_list_end   {}               {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\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 ""
}
proc fmt_example_end   {} {
    global  mode_save textmode
    set textmode  [lindex $mode_save end]
    set mode_save [lrange $mode_save 0 end-1]
    return ""
}
proc fmt_example {code} {
    set lines [list ""]
    foreach line [split $code "\n"] {
	set linex [string trim $line]
	if {$linex == {}} {lappend lines {} ; continue}
    	lappend lines " | $line"
    }
    lappend lines ""
    return [join $lines "\n"]
}

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} {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_uri     {text} {emph $text}
proc fmt_term    {text} {emph $text}
proc fmt_const   {text} {strong $text}

################################################################
# 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"} {
	set lines [list ""] 
	foreach line [split $text "\n"] {
	    set linex [string trim $line]
	    if {$linex == {}} {lappend lines {} ; continue}
	    lappend lines " | $line"
	}
	lappend lines ""
	return [join $lines "\n"]
    }

    regsub -all "\[ \t\n\]+" $text { } text
    return $text
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































Deleted modules/doctools/mpformats/idx.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
# -*- tcl -*-
#
# $Id: idx.html,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a docidx document into HTML.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# Freely redistributable.
#
######################################################################

dt_source _idx_common.tcl
dt_source _html.tcl

######################################################################
# Conversion specification.
#
# One-pass processing.

rename idx_postprocess {}
rename fmt_postprocess idx_postprocess

proc fmt_plain_text {text} {return {}}

################################################################
## Backend for HTML markup

global firstkey   ; set firstkey   1
global even       ; set even        1
global reflist    ; set reflist [list]
global cnt        ; set cnt 0

proc fmt_index_begin     {label title}      {
    set     hdr ""
    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 "CVS: \$Id\$ $label"]\n
    append  hdr \n
    append  hdr [markup <body>]\n

    # Engine parameter - insert 'header'
    if {[set header [Get header]] != {}} {append hdr [markup $header]\n}

    if {($label != {}) && ($title != {})} {
	append  hdr "[markup <h3>] $label -- $title [markup </h3>]\n"
    } elseif {$label != {}} {
	append  hdr "[markup <h3>] $label [markup </h3>]\n"
    } elseif {$title != {}} {
	append  hdr "[markup <h3>] $title [markup </h3>]\n"
    }
    append  hdr "[markup "<hr><table class=\"#idx\">"]\n"
    return $hdr
}
proc fmt_index_end {} {
    set    text [FlushReferences]
    append text [tag/ table]\n

    # Engine parameter - insert 'footer'
    set  footer [Get footer]
    if {$footer != {}} {set footer \n[markup $footer]\n}

    return $text[tag hr]${footer}[tag/ body][tag/ html]\n
}
proc fmt_key {text} {
    global firstkey even reflist cnt

    set res [FlushReferences]
    set firstkey 0

    if {$even} {
	append res [markup "<tr class=\"#idxeven\" >"]\n
    } else {
	append res [markup "<tr class=\"#idxodd\"  >"]\n
    }
    set even [expr {1-$even}]

    append  res "    [markup "<td class=\"#idxleft\" >"][markup "<a name=\"key$cnt\">"] ${text} [markup </a>][tag/ td]\n"
    append  res "    [markup "<td class=\"#idxright\">"]\n"
    incr cnt
    return $res
}

proc FlushReferences {} {
    global firstkey reflist

    set res ""
    if {!$firstkey} {
	set lines [list]
	foreach {ref label} $reflist {
	    lappend lines "\t[markup "<a href=\"$ref\">"] ${label} [tag/ a]"
	}
	append res "[join $lines ,\n]\n    [tag /td]\n[tag/ tr]\n"
    }
    set reflist [list]
    return $res
}

proc fmt_manpage {file label} {global reflist ; lappend reflist [dt_fmap $file] $label ; return}
proc fmt_url     {url label}  {global reflist ; lappend reflist $url            $label ; return}
proc fmt_comment {text}       {ht_comment $text}

################################################################

global    __var
array set __var {
    meta   {}
    header {}
    footer {}
}
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
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































Deleted modules/doctools/mpformats/idx.nroff.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
# -*- tcl -*-
#
# $Id: idx.nroff,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a docidx document into nroff.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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 [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_include man.macros]\n
    append  hdr [nr_title "\"[string trimleft $label :]\" n"]\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 {}
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































Deleted modules/doctools/mpformats/idx.null.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# -*- tcl -*-
#
# -- Null format (docidx)
#
# Copyright (c) 2003      Andreas Kupries <[email protected]>

# 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 ""}
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Deleted modules/doctools/mpformats/idx.text.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
# -*- tcl -*-
#
# $Id: idx.text,v 1.2 2003/04/01 23:38:19 andreas_kupries Exp $
#
# Engine to convert a docidx document into plain text.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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::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::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::blank $max]

    foreach key [lsort [array names map]] {
	set   opfx $key[string range $pfx [string length $key] end]
	Text $opfx[textutil::indent [textutil::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}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































Deleted modules/doctools/mpformats/idx.wiki.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
# -*- tcl -*-
#
# $Id: idx.wiki,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a docidx document into Wiki markup.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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 {}}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































Deleted modules/doctools/mpformats/toc.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
# -*- tcl -*-
#
# $Id: toc.html,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a doctoc document into HTML.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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 ""
    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 "CVS: \$Id\$ $label"]\n
    append  hdr \n
    append  hdr [markup <body>]\n

    # Engine parameter - insert 'header'
    if {[set header [Get 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}

    return $text[tag /dl][tag hr]${footer}[tag/ body][tag/ html]\n
}
proc fmt_division_start {title} {
    global maintable ; set maintable 0
    return \n[markup <hr><dl><dt>]$title[markup <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=\"#toc\">"]\n
    }

    if {$even} {
	append text [markup "<tr class=\"#toceven\" >"]\n
    } else {
	append text [markup "<tr class=\"#tocodd\"  >"]\n
    }
    set even [expr {1-$even}]
    append text [markup "<td class=\"#tocleft\" >"][markup "<a href=\"[dt_fmap $file]\">"]$label[tag/ a][tag/ td]\n
    append text [markup "<td class=\"#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 {}
}
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
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































Deleted modules/doctools/mpformats/toc.nroff.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
# -*- tcl -*-
#
# $Id: toc.nroff,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a doctoc document into nroff.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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 [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_include man.macros]\n
    append  hdr [nr_title "\"[string trimleft $label :]\" n"]\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}      {return $text[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 {}
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































Deleted modules/doctools/mpformats/toc.null.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# -*- tcl -*-
#
# -- Null format (doctoc)
#
# Copyright (c) 2003      Andreas Kupries <[email protected]>

# 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 ""}
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































Deleted modules/doctools/mpformats/toc.text.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
# -*- tcl -*-
#
# $Id: toc.text,v 1.2 2003/04/01 23:38:19 andreas_kupries Exp $
#
# Engine to convert a doctoc document into plain text.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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::uncap [c_provenance]]\n"
    append  hdr \n
    append  hdr $title \n
    append  hdr [textutil::strRepeat = [string length $title]]
    Text   $hdr
    CloseParagraph [Verbatim]
}
proc fmt_division_start {title} {
    global lmarginIncrement currentEnv
    global seclist ; set seclist {}
    global max     ; set max 0

    Text $title\n
    Text [textutil::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::strRepeat . $max] "

	foreach {file desc} $seclist {
	    set   opfx "$file [string range $fpfx [string length $file] end]"
	    Text $opfx[textutil::indent [textutil::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
}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































Deleted modules/doctools/mpformats/toc.tmml.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
# -*- tcl -*-
#
# $Id: toc.tmml,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a doctoc document into TMML.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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}       {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}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Deleted modules/doctools/mpformats/toc.wiki.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
# -*- tcl -*-
#
# $Id: toc.wiki,v 1.1 2003/03/05 06:50:34 andreas_kupries Exp $
#
# Engine to convert a doctoc document into Wiki markup.
#
# Copyright (c) 2003 Andreas Kupries <[email protected]>
# 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}       {return '''[string trim $title]'''}
proc fmt_division_end   {}            {return {}}
proc fmt_item           {file label desc}  {return "   \[$label\]:   $file -- $desc"}
proc fmt_comment        {text}        {return {}}

################################################################
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































Deleted modules/doctools/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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 doctools            1.0 [list source [file join $dir doctools.tcl]]
package ifneeded doctools::toc       0.1 [list source [file join $dir doctoc.tcl]]
package ifneeded doctools::idx       0.1 [list source [file join $dir docidx.tcl]]
package ifneeded doctools::cvs       0.1 [list source [file join $dir cvs.tcl]]
package ifneeded doctools::changelog 0.1 [list source [file join $dir changelog.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted modules/doctools/tocexpand.

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
















































































































































































































































































Deleted modules/exif/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
2003-04-11  Andreas Kupries  <[email protected]>

	* exif.tcl:
	* exif.man:
	* pkgIndex.tcl: Fixed bug #614591. Set version of the package to
	  to 1.1.

2003-04-01  Andreas Kupries  <[email protected]>

	* exif.man:
	* exif.tcl: Applied patch for SF tcllib bug #665737 provided by
	  Tim J. Edwards <[email protected]>. 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  <[email protected]>

	* exif.tcl (exif::makerNote): Use string match instead of regexp.

2002-08-16  Andreas Kupries  <[email protected]>

	* 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
	  <[email protected]> to make the module work with
	  Digital IXUS.

2002-03-25  Andreas Kupries  <[email protected]>

	* exif.man: Fixed formatting errors in the doctools manpage.

2002-02-18  Andreas Kupries  <[email protected]>  

	* Added module on behalf of Darren New.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































Deleted modules/exif/exif.html.

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






































































































































































































































































































Deleted modules/exif/exif.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
[manpage_begin exif n 1.1]
[moddesc   {EXIF parsing}]
[titledesc {Tcl EXIF extracts and parses EXIF fields from digital images}]
[require Tcl 8.2]
[require exif [opt 1.1]]
[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.

[nl]

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.

[nl]

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.

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































Deleted modules/exif/exif.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
.\" automatically generated by xml2rfc v1.8 on 12 Feb 2002 23:41:15 +0000
.\" 
.pl 10.0i
.po 0
.ll 7.2i
.lt 7.2i
.nr LL 7.2i
.nr LT 7.2i
.ds LF New
.ds RF FORMFEED[Page %]
.ds CF 
.ds LH EXIF
.ds RH February 2002
.ds CH The EXIF Package
.hy 0
.ad l
.nf
The EXIF documentation file                                       D. New
                                                       February 12, 2002


.ce
The EXIF Package

.in 3

.ti 0
Abstract

.fi
Tcl EXIF extracts and parses EXIF fields from digital images.

.ti 0
Table of Contents

.nf
1. Synopsis . . . . . . . . . . . . . . . . . . . . . . . . . . . . 2
2. Details  . . . . . . . . . . . . . . . . . . . . . . . . . . . . 3
3. Copyrights . . . . . . . . . . . . . . . . . . . . . . . . . . . 4
4. Acknowledgements . . . . . . . . . . . . . . . . . . . . . . . . 5
.bp
.fi
.in 3
.ti 0
1. Synopsis
.nf

    package provide exif 1.0

.fi
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.
.bp
.in 3
.ti 0
2. Details
.nf

    array set answer [exif::analyze $channel]

.fi
$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.
.nf

.in 3
    set names [exif::fieldnames]

.fi
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.
.bp
.in 3
.ti 0
3. Copyrights

(c) 2002 Darren New

Hold harmless the author, and any lawful use is allowed.
.bp
.ti 0
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.
.bp
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































Deleted modules/exif/exif.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
# EXIF parser in Tcl
# Author: Darren New <[email protected]>
# Translated directly from the Perl version
# by Chris Breeze <[email protected]>
# 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 ; # 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
                    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: [email protected]
# 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
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/exif/exif.txt.

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


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]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































Deleted modules/exif/exif.xml.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
<?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>[email protected]</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>

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































Deleted modules/exif/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded exif 1.1 [list source [file join $dir exif.tcl]]
<
<




Deleted modules/fileutil/ChangeLog.

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

	* fileutil.man:
	* fileutil.tcl:
	* pkgIndex.tcl:  Set version of the package to to 1.5.

2003-04-02  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* fileutil.tcl (fileutil::touch): Applied patch #688965 provided
	  by Glenn Jackman <[email protected]>. This patch
	  provides a better message when asking the [fileutil::touch]
	  command for help.

2003-03-24  Andreas Kupries  <[email protected]>

	* fileutil.test:
	* fileutil.man:
	* fileutil.tcl: Fixed bug #707009, reported by Helmut Giese
	  <[email protected]>, also updated the documentation
	  and the testsuite.

2003-01-28  David N. Welton  <[email protected]>

	* fileutil.tcl (::fileutil::fileType): Use 'string match' instead
	  of regexp.  Require Tcl 8.2.

2003-01-16  Andreas Kupries  <[email protected]>

	* fileutil.man: More semantic markup, less visual one.

2002-10-08  Andreas Kupries  <[email protected]>

	* fileutil.tcl:
	* fileutil.man:
	* fileutil.test: Accepted enhanced format detection by Philip
	  Ehrens <[email protected]>.

2002-05-21  Andreas Kupries  <[email protected]>

	* fileutil.tcl (cat): Fixed bug #556504, reported by Michael
	  A. Cleverly <[email protected]>. 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  <[email protected]>

	* 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  <[email protected]>

	* fileutil.man: Added doctools manpage.
	* fileutils.n: Updated to reflect change of version.

2002-03-20  eric melski  <[email protected]>

	* 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  <[email protected]>

	* Bumped version to 1.3

2001-12-06  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* fileutil.test:
	* fileutil.n:
	* fileutil.tcl: Applied patch #477805 by Glenn Jackman
	  <[email protected]> implementing the unix 'touch'
	  command. Contains documentation and testsuite for the new
	  command too.

2001-09-05  Andreas Kupries  <[email protected]>

	* fileutil.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-08-21  Andreas Kupries  <[email protected]>

	* All of the changes below are related to tcllib Patch [449531] by
	  Anselm Lingnau <[email protected]>. 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 <[email protected]>

	* fileutil.n: Added manpage documenting the commands. tcllib Bug
	  [446584].

2001-06-21  Andreas Kupries <[email protected]>

	* fileutil.tcl: Fixed dubious code reported by frink.

2001-03-20  Andreas Kupries <[email protected]>

	* 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  <[email protected]>

	* fileutil.test:
	* fileutil.tcl: Added cat function, duplicates standard UNIX "cat"
	  utility.

2000-03-09  Eric Melski  <[email protected]>

	* fileutil.test: Collected tests into one file; adapted tests for
	  use in/out of tcllib test framework.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































Deleted modules/fileutil/fileutil.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin fileutil n 1.5]
[moddesc   {file utilities}]
[titledesc {Procedures implementing some file utilities}]
[require Tcl 8]
[require fileutil [opt 1.5]]
[description]
[para]

This package provides implementations of standard unix utilities.

[list_begin definitions]


[call [cmd ::fileutil::cat] [arg filename]]

A tcl implementation of the UNIX [syscmd cat] command.  Returns the
contents of the specified file. The first argument is the name of the
file to read.


[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, graphic gif, graphic jpeg, graphic png, graphic tiff, html,
xml (with doctype if available), message pgp, binary pdf, text ps,
text eps, binary gravity_wave_data_frame, compressed bzip,
compressed gzip, and link.


[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
loose itself in infinite loops upon encountering circular link
structures.  The result of the command is a list containing the paths
to the interesting files.


[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::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.

[call [cmd ::fileutil::stripPwd] [arg path]]

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::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.

[list_end]


[keywords {file utilities}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































Deleted modules/fileutil/fileutil.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
'\" 
'\" Copyright (c) 2001 by Andreas Kupries <[email protected]>
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: fileutil.n,v 1.9 2002/04/13 01:37:04 andreas_kupries Exp $
'\" 
.so man.macros
.TH fileutil n 1.4 Fileutil "file utilities"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
::fileutil \- Procedures implementing some file utilities
.SH SYNOPSIS
\fBpackage require Tcl 8\fR
.sp
\fBpackage require fileutil ?1.4?\fR
.sp
\fB::fileutil::cat\fR \fIfilename\fR
.sp
\fB::fileutil::fileType\fR \fIfilename\fR
.sp
\fB::fileutil::find\fR ?\fIbasedir\fR ?\fIfiltercmd\fR??
.sp
\fB::fileutil::findByPattern\fR \fIbasedir\fR ?\fI-regexp\fI|\fI-glob\fR? ?\fI\--\fR? \fIpatterns\fR
.sp
\fB::fileutil::foreachLine\fR \fIvar filename cmd\fR
.sp
\fB::fileutil::grep\fR \fIpattern\fR ?\fIfiles\fR?
.sp
\fB::fileutil::touch\fR ?\fI-a\fR? ?\fI-c\fR? ?\fI-m\fR? ?\fI-r ref_file\fR? ?\fI-t time\fR? \fIfilename\fR ?\fI...\fR?
.BE
.SH DESCRIPTION
.PP
This package provides implementations of standard unix utilities
.TP
\fB::fileutil::cat\fR \fIfilename\fR
A tcl implementation of the UNIX "cat" command.  Returns the contents
of the specified file. The first argument is the name of the file to
read.
.TP
\fB::fileutil::fileType\fR \fIfilename\fR
An implementation of the UNIX "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, graphic gif, graphic jpeg, html, xml (with doctype if available),
message pgp, and link.
.TP
\fB::fileutil::find\fR ?\fIbasedir\fR ?\fIfiltercmd\fR??
An implementation of the unix command \fBfind\fR. 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 \fB.\fR, i.e. the current
directory. The command defaults to the empty string, which means that
all files are of interest. The command takes care \fBnot\fR to loose
itself in infinite loops upon encountering circular link structures.
The result of the command is a list containing the paths to the
interesting files.
.TP
\fB::fileutil::findByPattern\fR \fIbasedir\fR ?\fI-regexp\fI|\fI-glob\fR? ?\fI\--\fR? \fIpatterns\fR
This command is based upon the TclX command \fBrecursive_glob\fR,
except that it doesn't allow recursion over more than one directory at
a time. It uses \fB::fileutil::find\fR internally and is thus able to
and does follow symbolic links, something the TclX command does not
do. First argument is the directory to start the search in, second
argument is a list of \fIpatterns\fR. The command returns a list of
all files reachable through \fIbasedir\fR 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 \fI--\fR stops
option processing. This allows the use of a leading '-' in the
patterns.
.TP
\fB::fileutil::foreachLine\fR \fIvar filename cmd\fR
The command reads the file \fIfilename\fR and executes the script
\fIcmd\fR for every line in the file. During the execution of the
script the variable \fIvar\fR 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 \fIcmd\fR or the empty string if the file was
empty.
.TP
\fB::fileutil::grep\fR \fIpattern\fR ?\fIfiles\fR?
Implementation of grep. Adapted from the Tcler's Wiki. The first
argument defines the \fIpattern\fR to search for. This is followed by
a list of \fIfiles\fR to search through. The list is optional and
\fBstdin\fR will be used if 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.
.TP
\fB::fileutil::touch\fR ?\fI-a\fR? ?\fI-c\fR? ?\fI-m\fR? ?\fI-r ref_file\fR? ?\fI-t time\fR? \fIfilename\fR ?\fI...\fR?
Implementation of touch. Alter the atime and mtime of the specified
files. If \fI-c\fR, do not create files if they do not already
exist. If \fI-r\fR, use the atime and mtime from \fIref_file\fR. If
\fI-t\fR, use the integer clock value \fItime\fR. It is illegal to 
specify both \fI-r\fR and \fI-t\fR. If \fI-a\fR, only change the 
atime. If \fI-m\fR, only change the mtime. 

.SH KEYWORDS
file utilities
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































Deleted modules/fileutil/fileutil.tcl.

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

package require Tcl 8.2
package require cmdline
package provide fileutil 1.5

namespace eval ::fileutil {
    namespace export grep find findByPattern cat foreachLine touch
}

# ::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 ==
#
# Two different implementations of this command, one for unix with its
# softlinks, the other for the Win* platform. The trouble with
# softlink is that they can generate circles in the directory and/or
# file structure, leading a simple recursion into infinity. So we
# record device/inode information for each file and directory we touch
# to be able to skip it should we happen to visit it again.

# Note about the general implementation: The tcl interpreter sets a
# tcl stack limit of 1000 levels to prevent infinite recursions from
# running out of bounds. As this command is implemented recursively it
# will fail for very deeply nested directory structures.

if {[string compare unix $tcl_platform(platform)]} {
    # Not a unix platform => Original implementation
    # Note: This may still fail for directories mounted via SAMBA,
    # i.e. coming from a unix server.

    # ::fileutil::find --
    #
    #	Implementation of find.  Adapted from the Tcler's Wiki.
    #
    # Arguments:
    #	basedir		directory to start searching from; default is .
    #	filtercmd	command to use to evaluate interest in each file.
    #			If NULL, all files are interesting.
    #
    # Results:
    #	files		a list of interesting files.

    proc ::fileutil::find {{basedir .} {filtercmd {}}} {
	set oldwd [pwd]
	cd $basedir
	set cwd [pwd]
	set filenames [glob -nocomplain * .*]
	set files {}
	set filt [string length $filtercmd]
	# If we don't remove . and .. from the file list, we'll get stuck in
	# an infinite loop in an infinite loop in an infinite loop in an inf...
	foreach special [list "." ".."] {
	    set index [lsearch -exact $filenames $special]
	    set filenames [lreplace $filenames $index $index]
	}
	foreach filename $filenames {
	    # Use uplevel to eval the command, not eval, so that variable 
	    # substitutions occur in the right context.
	    if {!$filt || [uplevel $filtercmd [list $filename]]} {
		lappend files [file join $cwd $filename]
	    }
	    if {[file isdirectory $filename]} {
		set files [concat $files [find $filename $filtercmd]]
	    }
	}
	cd $oldwd
	return $files
    }
} else {
    # Unix, record dev/inode to detect and break circles

    # ::fileutil::find --
    #
    #	Implementation of find.  Adapted from the Tcler's Wiki.
    #
    # Arguments:
    #	basedir		directory to start searching from; default is .
    #	filtercmd	command to use to evaluate interest in each file.
    #			If NULL, all files are interesting.
    #
    # Results:
    #	files		a list of interesting files.

    proc ::fileutil::find {{basedir .} {filtercmd {}} {nodeVar {}}} {
	if {$nodeVar == {}} {
	    # Main call, setup the device/inode structure
	    array set inodes {}
	} else {
	    # Recursive call, import the device/inode record from the caller.
	    upvar $nodeVar inodes
	}

	set oldwd [pwd]
	cd $basedir
	set cwd [pwd]
	set filenames [glob -nocomplain * .*]
	set files {}
	set filt [string length $filtercmd]
	# If we don't remove . and .. from the file list, we'll get stuck in
	# an infinite loop in an infinite loop in an infinite loop in an inf...
	foreach special [list "." ".."] {
	    set index [lsearch -exact $filenames $special]
	    set filenames [lreplace $filenames $index $index]
	}
	foreach filename $filenames {
	    # Stat each file/directory get exact information about its identity
	    # (device, inode). Non-'stat'able files are either junk (link to
	    # non-existing target) or not readable, i.e. inaccessible. In both
	    # cases it makes sense to ignore them.

	    if {[catch {file stat [file join $cwd $filename] stat}]} {
		continue
	    }

	    # No skip over previously recorded files/directories and
	    # record the new files/directories.

	    set key "$stat(dev),$stat(ino)"
	    if {[info exists inodes($key)]} {
		continue
	    }
	    set inodes($key) 1

	    # Use uplevel to eval the command, not eval, so that variable 
	    # substitutions occur in the right context.
	    if {!$filt || [uplevel $filtercmd [list $filename]]} {
		lappend files [file join $cwd $filename]
	    }
	    if {[file isdirectory $filename]} {
		set files [concat $files [find $filename $filtercmd inodes]]
	    }
	}
	cd $oldwd
	return $files
    }

    # end if
}

# ::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 file join [lrange $npath [llength $pwd] end]]
    }
    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 file join [lrange $path $n end]]
    }
}

# ::fileutil::cat --
#
#	Tcl implementation of the UNIX "cat" command.  Returns the contents
#	of the specified file.
#
# Arguments:
#	filename	name of the file to read.
#
# Results:
#	data		data read from the file.

proc ::fileutil::cat {filename} {
    # Don't bother catching errors, just let them propagate up
    set fd [open $filename r]
    # Use the [file size] command to get the size, which preallocates memory,
    # rather than trying to grow it as the read progresses.
    set size [file size $filename]
    if {$size} {
        set data [read $fd $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)
        set data [read $fd]
    }
    close $fd
    return $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.

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
#                       binary graphic [gif, jpeg, png, tiff]
#                       ps, eps, pdf
#                       html
#                       xml <doctype>
#                       message pgp
#                       bzip, gzip
#                       gravity_wave_data_frame
#                       link
#                  


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
    }
    if { [ regexp {^\#\!(\S+)} $test -> terp ] } {
        lappend type script $terp
    } elseif { $binary && [ regexp {^[\x7F]ELF} $test ] } {
        lappend type executable elf
    } 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 match "GIF*" $test] } {
        lappend type graphic gif
    } elseif { $binary && [string match "\x89PNG*" $test] } {
        lappend type graphic png
    } elseif { $binary && [string match "\xFF\xD8\xFF\xE0\x00\x10JFIF*" $test] } {
        lappend type graphic jpeg
    } elseif { $binary && [string match "MM\x00\**" $test] } {
        lappend type graphic tiff
    } elseif { $binary && [string match "\%PDF\-*" $test] } {
        lappend type pdf
    } elseif { ! $binary && [string match -nocase "*\<html\>*" $test] } {
        lappend type html
    } 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
    }    
    ;## lastly, is it a link?
    if { ! [ catch {file readlink $filename} ] } {
        lappend type link
    }
    return $type
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/fileutil/fileutil.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}
puts "tcltest [package present tcltest]"

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

package require fileutil
puts "fileutil [package present fileutil]"

# Build a sample tree to search
# Structure
#
#	dir
#	+--find1
#          +--find2
#          |  +--file2
#          +--file1

catch {removeDirectory find1} ; # start with a clean structure!

makeDirectory find1
makeDirectory [file join find1 find2]
makeFile "" [file join find1 file1]
makeFile "test" [file join find1 find2 file2]
set dir $::tcltest::temporaryDirectory

proc fileIsBiggerThan {s f} {
    expr {![file isdirectory $f] && [file size $f] > $s}
}

test find-1.1 {standard recursive find} {
    lsort [fileutil::find [file join $dir find1]]
} [list [file join $dir find1 file1] [file join $dir find1 find2] \
	[file join $dir find1 find2 file2]]
test find-1.2 {find directories} {
    fileutil::find [file join $dir find1] {file isdirectory}
} [list [file join $dir find1 find2]]
test find-1.3 {find files bigger than a given size} {
    fileutil::find [file join $dir find1] {fileIsBiggerThan 1}
} [list [file join $dir find1 find2 file2]]


# Extend the previous sample tree
# Extended structure:
#
#	dir
#	+--find1
#          +--find2       <----------+
#          |  +--file2		     |
#          |  +--file3 --> ../find2 -+
#          +--file1

test find-1.4 {handling of circular links} {unix} {
    catch {file delete -force [file join $dir find1 find2 file3]}
    exec ln -s ../find2 [file join $dir find1 find2 file3]

    # Find has to skip 'file3'
    lsort [fileutil::find [file join $dir find1]]
} [list [file join $dir find1 file1] [file join $dir find1 find2] \
	[file join $dir find1 find2 file2]]


# find by pattern tests

test find-2.0 {find by pattern} {
    catch {::fileutil::findByPattern $dir -glob {fil*} foo} msg
    set msg
} {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"}

test find-2.1 {find by pattern} {
    catch {::fileutil::findByPattern $dir -glob} msg
    set msg
} {wrong#args for "::fileutil::findByPattern", should be "::fileutil::findByPattern basedir ?-regexp|-glob? ?--? patterns"}

test find-2.2 {find by pattern} {
    lsort [::fileutil::findByPattern [file join $dir find1] -glob {fil*}]
} [list [file join $dir find1 file1] [file join $dir find1 find2 file2]]

test find-2.3 {find by pattern} {
    lsort [::fileutil::findByPattern [file join $dir find1] -regexp {.*1$}]
} [list [file join $dir find1 file1]]


catch {removeDirectory grepTest} ; # start with a clean structure!

# Build a sample tree to search
makeDirectory grepTest
makeFile "zoop" [file join $dir grepTest file1]
makeFile "zoo\nbart"  [file join $dir grepTest file2]

test grep-1.1 {normal grep} {
    lsort [fileutil::grep "zoo" [glob [file join $dir grepTest *]]]
} [list "[file join $dir grepTest file1]:1:zoop" \
	"[file join $dir grepTest file2]:1:zoo"]
test grep-1.2 {more restrictive grep} {
    lsort [fileutil::grep "zoo." [glob [file join $dir grepTest *]]]
} [list "[file join $dir grepTest file1]:1:zoop"]
test grep-1.3 {more restrictive grep} {
    lsort [fileutil::grep "bar" [glob [file join $dir grepTest *]]]
} [list "[file join $dir grepTest file2]:2:bart"]

makeDirectory catTest
makeFile "foo\nbar\nbaz\n" [file join $dir catTest file1]
test cat-1.1 {cat} {
    fileutil::cat [file join $dir catTest file1]
} "foo\nbar\nbaz\n"


test foreachline-1.0 {foreachLine} {
    set res ""
    ::fileutil::foreachLine line [file join $dir catTest file1] {
	append res /$line
    }
    set res
} {/foo/bar/baz}



catch {removeDirectory touchTest} ; # start with a clean structure!
makeDirectory touchTest
makeFile "blah" [file join $dir touchTest file1]

test touch-1.1 {create file} {
    set f [file join $dir touchTest here]
    fileutil::touch $f
    # reap this file on cleanup
    lappend ::tcltest::filesmade $f
    file exists $f
} 1
test touch-1.2 {'-c' prevents file creation} {
    set f [file join $dir touchTest nothere]
    fileutil::touch -c $f
    file exists $f
} 0
test touch-1.3 {'-c' has no effect on existing files} {
    set f [file join $dir touchTest file1]
    fileutil::touch -c $f
    file exists $f
} 1
test touch-1.4 {test relative times} {
    set f [file join $dir touchTest file1]
    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}]
} [list 1 1 1 1]
test touch-1.5 {test relative times using -a} {
    set f [file join $dir touchTest file1]
    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}]
} [list 1 0 1 0]
test touch-1.6 {test relative times using -m} {
    set f [file join $dir touchTest file1]
    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}]
} [list 1 0 0 1]
test touch-1.7 {test relative times using -a and -m} {
    set f [file join $dir touchTest file1]
    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}]
} [list 1 1 1 1]
test touch-1.8 {test -t} {
    set f [file join $dir touchTest file1]
    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}]
} [list 1 1]
test touch-1.9 {test -t with -a} {
    set f [file join $dir touchTest file1]
    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} {
    set f [file join $dir touchTest file1]
    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} {
    set f [file join $dir touchTest file1]
    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}]
} [list 1 1]
test touch-1.12 {test -r} {
    set r [info script]
    set f [file join $dir touchTest file1]
    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]}]
} [list 1 1]
test touch-1.13 {test -r with -a} {
    set r [info script]
    set f [file join $dir touchTest file1]
    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]}]
} [list 1 0]
test touch-1.14 {test -r with -m} {
    set r [info script]
    set f [file join $dir touchTest file1]
    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]}]
} [list 0 1]
test touch-1.15 {test -r with -a and -m} {
    set r [info script]
    set f [file join $dir touchTest file1]
    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]}]
} [list 1 1]


catch {removeDirectory fileTypeTest} ; # start with a clean structure!
makeDirectory fileTypeTest
fileutil::touch [file join $dir fileTypeTest emptyFile]

makeFile "\u0000" [file join $dir fileTypeTest binaryFile]

set elfData "\x7F"
append elfData "ELF"
append elfData "\x01\x01\x01\x00\x00"
makeFile $elfData [file join $dir fileTypeTest elfFile]

set bzipData "BZh91AY&SY"
append bzipData "\x01\x01\x01\x00\x00"
makeFile $bzipData [file join $dir fileTypeTest bzipFile]

set gzipData "\x1f\x8b"
append gzipData "\x01\x01\x01\x00\x00"
makeFile $gzipData [set f [file join $dir fileTypeTest gzipFile]]
set fh [open $f w] ; fconfigure $fh -encoding binary ; puts -nonewline $fh $gzipData ; close $fh

set jpgData "\xFF\xD8\xFF\xE0\x00\x10JFIF"
append jpgData "\x00\x01\x02\x01\x01\x2c"
makeFile $jpgData [file join $dir fileTypeTest jpegFile]

set gifData "GIF89a\x2b\x00\x40\x00\xf7\xff\x00"
makeFile $gifData [file join $dir fileTypeTest gifFile]

set pngData "\x89PNG"
append pngData "\x00\x01\x02\x01\x01\x2c"
makeFile $pngData [set f [file join $dir fileTypeTest pngFile]]
set fh [open $f w] ; fconfigure $fh -encoding binary ; puts -nonewline $fh $pngData ; close $fh

set tiffData "MM\x00\*"
append tiffData "\x00\x01\x02\x01\x01\x2c"
makeFile $tiffData [file join $dir fileTypeTest tiffFile]

set psData "%!PS-"
append psData "ADOBO-123 EPSF-1.4"
makeFile $psData [file join $dir fileTypeTest psFile]

set pdfData "%PDF-"
append pdfData "1.2 \x00\x01\x02\x01\x01\x2c"
makeFile $pdfData [file join $dir fileTypeTest pdfFile]

set epsData $psData
makeFile $psData [file join $dir fileTypeTest epsFile]

set igwdData "IGWD"
append igwdData "\x00\x01\x02\x01\x01\x2c"
makeFile $igwdData [file join $dir fileTypeTest igwdFile]

makeFile "simple text" [file join $dir fileTypeTest textFile]
makeFile "#!/bin/tclsh" [file join $dir fileTypeTest scriptFile]
makeFile "<html></html>" [file join $dir fileTypeTest htmlFile]

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>
}

makeFile $xmlData [file join $dir fileTypeTest xmlFile]
makeFile $xmlDataWithDTD [file join $dir fileTypeTest xmlWithDTDFile]

set pgpData {-----BEGIN PGP MESSAGE-----
Version: PGP 6.5.8

abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
}

makeFile $pgpData [file join $dir fileTypeTest pgpFile]

test fileType-1.1 {test file non-existance} {
    set f [file join $dir fileTypeTest bogus]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 1 "file not found: '[file join $dir fileTypeTest bogus]'"]
test fileType-1.2 {test file directory} {
    set f [file join $dir fileTypeTest]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list directory]]
test fileType-1.3 {test file empty} {
    set f [file join $dir fileTypeTest emptyFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list empty]]
test fileType-1.4 {test simple binary} {
    set f [file join $dir fileTypeTest binaryFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary]]
test fileType-1.5 {test elf executable} {
    set f [file join $dir fileTypeTest elfFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary executable elf]]
test fileType-1.6 {test simple text} {
    set f [file join $dir fileTypeTest textFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text]]
test fileType-1.7 {test script file} {
    set f [file join $dir fileTypeTest scriptFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text script /bin/tclsh]]
test fileType-1.8 {test html text} {
    set f [file join $dir fileTypeTest htmlFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text html]]
test fileType-1.9 {test xml text} {
    set f [file join $dir fileTypeTest xmlFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text xml]]
test fileType-1.10 {test xml with dtd text} {
    set f [file join $dir fileTypeTest xmlWithDTDFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text xml foobar]]
test fileType-1.11 {test PGP message} {
    set f [file join $dir fileTypeTest pgpFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text message pgp]]
test fileType-1.12 {test binary graphic jpeg} {
    set f [file join $dir fileTypeTest jpegFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary graphic jpeg]]
test fileType-1.13 {test binary graphic gif} {
    set f [file join $dir fileTypeTest gifFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary graphic gif]]
test fileType-1.14 {test binary graphic png} {
    set f [file join $dir fileTypeTest pngFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary graphic png]]
test fileType-1.15 {test binary graphic tiff} {
    set f [file join $dir fileTypeTest tiffFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary graphic tiff]]
test fileType-1.16 {test binary pdf} {
    set f [file join $dir fileTypeTest pdfFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary pdf]]
test fileType-1.17 {test text ps} {
    set f [file join $dir fileTypeTest psFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text ps eps]]
test fileType-1.18 {test text eps} {
    set f [file join $dir fileTypeTest epsFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list text ps eps]]
test fileType-1.19 {test binary gravity_wave_data_frame} {
    set f [file join $dir fileTypeTest igwdFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary gravity_wave_data_frame]]
test fileType-1.20 {test binary compressed bzip} {
    set f [file join $dir fileTypeTest bzipFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary compressed bzip]]
test fileType-1.21 {test binary compressed gzip} {
    set f [file join $dir fileTypeTest gzipFile]
    set res [catch {fileutil::fileType $f} msg]
    list $res $msg
} [list 0 [list binary compressed gzip]]



# stripPwd/N -----------------------------------------------------
# dir = $::tcltest::temporaryDirectory = current working directory

test stripPwd-1.0 {unrelated path} {
    fileutil::stripPwd find1
} find1

test stripPwd-1.1 {pwd-relative path} {
    fileutil::stripPwd [file join [pwd] $dir find1]
} find1

test stripPwd-1.2 {pwd-relative path} {
    fileutil::stripPwd [file join [pwd] $dir find1 find2]
} [file join find1 find2]

test stripPwd-1.3 {pwd itself} {
    fileutil::stripPwd [pwd]
} .


test stripN-1.0 {remove nothing} {
    fileutil::stripN find1 0
} find1

test stripN-1.1 {remove all} {
    fileutil::stripN find1 1
} {}

test stripN-1.2 {remove more than existing} {
    fileutil::stripN find1 2
} {}

test stripN-2.0 {remove nothing} {
    fileutil::stripN [file join find1 find2] 0
} [file join find1 find2]

test stripN-2.1 {remove part} {
    fileutil::stripN [file join find1 find2] 1
} find2

test stripN-2.2 {remove all} {
    fileutil::stripN [file join find1 find2] 2
} {}

test stripN-2.3 {remove more than existing} {
    fileutil::stripN [file join find1 find2] 3
} {}


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

::tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/fileutil/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 fileutil 1.5 [list source [file join $dir fileutil.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/ftp/ChangeLog.

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

	* 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  <[email protected]>

	* ftp.tcl (ModTime): Applied patch #659238 supplied by Dan Rogahn
	  <[email protected]> to allow setting the
	  modification time of a file, assuming the server allows this as
	  well.

2003-03-18  Pat Thoyts  <[email protected]>

	* ftp.tcl (ftp::InitDataConn): revert -regexp to fix bug 701288.

2003-02-24  David N. Welton  <[email protected]>

	* ftp.tcl (ftp::OpenControlConn): Use string map instead of
	regsub.

2003-01-28  David N. Welton  <[email protected]>

	* ftp.tcl (ftp::InitDataConn): Use 'string match' instead of
	  regexp.

2003-01-16  Andreas Kupries  <[email protected]>

	* ftp.man: More semantic markup, less visual one.

2002-08-30  Andreas Kupries  <[email protected]>

	* examples (hpupdate.tcl): Updated 'info exist' to 'info exists'.

2002-08-21  Andreas Kupries <[email protected]>

	* ftpdemo.tcl (Examples): Changed ftp.tcl to ftpdemo.tcl in
	  [test_40afile] and [test_70append]. Problem found and reported
	  by Jussi Kuosa <[email protected]>.

2002-08-06  Andreas Kupries <[email protected]>

	* ftp.tcl: Fixed SF Bug #582668, reported by Frank Richter
	  <[email protected]>.

2002-03-21  Andreas Kupries <[email protected]>

	* ftp.man: New, doctools manpage.

2002-02-14  Andreas Kupries <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* Bumped version to 2.3

2002-01-16  Andreas Kupries <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* ftp.tcl, ftp.n: Implemented and documented FR #481161.

	* ftp.tcl: Applied patch #428053 provided by Sreangsu Acharyya
	  <[email protected]>. 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]> for pointing out
	  the deficiencies in the documentation.

2001-10-20  Andreas Kupries <[email protected]>

	* 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 <[email protected]>

	* ftp.n:
	* ftp.tcl:
	* pkgIndex.tcl: Version up to 2.2.1.

2001-09-17  Andreas Kupries <[email protected]>

	* example/hpupdate.tcl: Some cleanups in the example code,
	  provided by Larry Virden <[email protected]>. This
	  fixes [440064].

2001-09-12  Andreas Kupries <[email protected]>

	* Added manpages for ftp package.

2001-08-01  Don Porter  <[email protected]>

	* example/hpupdate.tcl:  Workaround for moving Tk internal
	command [tkButtonInvoke].  [Bug 450914]

2001-08-01  Jeff Hobbs  <[email protected]>

	* ftp.tcl: added eval in ftp::List wrapper when used in tkcon.
	[Bug: #439779] (loring)

2001-07-10  Andreas Kupries <[email protected]>

	* ftp.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* ftpdemo.tcl:
	* ftp.tcl: Fixed dubious code reported by frink.

2000-10-01  Dan Kuchler <[email protected]>

      * 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 <[email protected]>

      * 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 <[email protected]>

       * 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   <[email protected]>

       * 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  <[email protected]>

       * 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  <[email protected]>

        * 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  <[email protected]>

        * 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  <[email protected]>

	* 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  <[email protected]> 
	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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 <[email protected]>
	for his investigation.  Added current namespace prefix to
	InitDataConn procedure.

1999-01-31  Steffen Traeger  <[email protected]>

	* ftp_lib.tcl: Changed return values of the FTP::Quote command,
	sent back the string it received instead of any parsing THANKS
	Keith Vetter <[email protected]> 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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
	<[email protected]> for inspiration
	
-------------------------- Released 0.9 -----------------------------

1998-02-28  Steffen Traeger  <[email protected]>

	* 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
	<[email protected]> 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 <[email protected]> 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)
-----------------
- ???

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ftp/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
=========================
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.


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































Deleted modules/ftp/docs/fhelp1.html.

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

# 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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































Deleted modules/ftp/docs/fhelp10.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































Deleted modules/ftp/docs/fhelp11.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Deleted modules/ftp/docs/fhelp12.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































Deleted modules/ftp/docs/fhelp125.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































Deleted modules/ftp/docs/fhelp13.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































Deleted modules/ftp/docs/fhelp14.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































Deleted modules/ftp/docs/fhelp15.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































Deleted modules/ftp/docs/fhelp16.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































Deleted modules/ftp/docs/fhelp17.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































Deleted modules/ftp/docs/fhelp18.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































Deleted modules/ftp/docs/fhelp2.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































Deleted modules/ftp/docs/fhelp3.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































Deleted modules/ftp/docs/fhelp4.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































Deleted modules/ftp/docs/fhelp5.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































Deleted modules/ftp/docs/fhelp6.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































Deleted modules/ftp/docs/fhelp7.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































Deleted modules/ftp/docs/fhelp8.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































Deleted modules/ftp/docs/fhelp9.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































Deleted modules/ftp/docs/index.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
<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:[email protected]">Steffen Traeger</a></font></p>
</body>
</html>


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































Deleted modules/ftp/ftp.man.

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


[para]

The ftp package provides the client side of the ftp protocol.  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::geturl] [arg url]]

This command lives in its own package, [cmd ::ftp::geturl], and can be
used by the generic command [cmd ::uri::geturl] to retrieve the
contents of ftp urls. Internally it uses the ftp commands described
below to fulfill the request.

[nl]

The contents of an ftp url are defined as follows:

[list_begin definitions]

[lst_item [term file]]

The contents of the specified file itself.

[lst_item [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.

[lst_item [term link]]

The attributes of the link, including the path it refers to.

[list_end]

[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.

[nl]

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.

[nl]

The options overwrite some default values or set special abilities:

[list_begin definitions]

[lst_item "[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.

[lst_item "[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.

[lst_item "[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.

[lst_item "[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].

[lst_item "[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.

[nl]

When evaluating the [arg callback] one argument is appended to the
callback script, the current accumulated number of bytes transferred
so far.

[lst_item "[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.

[nl]

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].

[lst_item "[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 bullet]
[bullet]

a subdirectory of the current directory,

[bullet]

Two dots, [const ..]  (as an indicator for the parent directory of
the current directory)

[bullet]

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.

[nl]

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.

[nl]

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.

[nl]

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.

[nl]

[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.

[nl]

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.

[nl]

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.

[nl]

If [option -variable] [arg varname] is specified, the system will
store the retrieved data into the variable [arg varname] instead of a
file.

[nl]

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.

[nl]

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.

[nl]

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.

[lst_item [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".

[lst_item [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].

[see_also ftpd smtp pop3 mime]
[keywords ftp rfc959 internet net]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ftp/ftp.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
'\"
'\" Copyright (c) 2000 Andreas Kupries
'\" All right reserved
'\"
'\" CVS: $Id: ftp.n,v 1.11 2002/02/15 05:35:30 andreas_kupries Exp $ ftp.n
'\"
.so man.macros
.TH "ftp" n 2.3.1 tcllib "ftp client"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
ftp \- Client-side tcl implementation of the ftp protocol
.SH "SYNOPSIS"
.nf
package require \fBTcl\fR
.sp
package require \fBftp\fR ?\fB2.3.1\fR?
package require \fBftp::geturl\fR ?\fB0.1\fR? ; # for ftp::geturl command
.sp
\fBftp::Open\fR \fIserver\fR \fIuser\fR \fIpasswd\fR ?\fIoptions\fR?
\fBftp::Close\fR \fIhandle\fR
.sp
\fBftp::Cd\fR \fIhandle\fR \fIdirectory\fR
\fBftp::Pwd\fR \fIhandle\fR
\fBftp::Type\fR \fIhandle\fR ?\fIascii|binary|tenex\fR?
\fBftp::List\fR \fIhandle\fR ?\fIdirectory\fR?
\fBftp::NList\fR \fIhandle\fR ?\fIdirectory\fR?
\fBftp::FileSize\fR \fIhandle\fR \fIfile\fR
\fBftp::ModTime\fR \fIhandle\fR \fIfile\fR
\fBftp::Delete\fR \fIhandle\fR \fIfile\fR
\fBftp::Rename\fR \fIhandle\fR \fIfrom\fR \fIto\fR
\fBftp::Put\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR?
\fBftp::Append\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR?
\fBftp::Get\fR \fIhandle\fR \fIremote\fR ?(\fIlocal\fR | -variable \fIvarname\fR | -channel \fIchan\fR)?
\fBftp::Reget\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR? ?\fIfrom\fR? ?\fIto\fR?
\fBftp::Newer\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR?
\fBftp::MkDir\fR \fIhandle\fR \fIdirectory\fR
\fBftp::RmDir\fR \fIhandle\fR \fIdirectory\fR
\fBftp::Quote\fR \fIhandle\fR \fIarg1\fR \fIarg2\fR \fI...\fR
\fBftp::DisplayMsg\fR \fIhandle\fR \fImsg\fR ?\fIstate\fR?
.sp
\fBftp::geturl\fR \fIurl\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
The ftp library package provides the client side of the ftp protocol.
The package implements both active (default) and passive ftp sessions.
.PP
A new ftp session is started with the \fBOpen\fR command. To shutdown
an existing ftp session use \fBClose\fR. 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 \fBcd\fR or \fBfile\fR.
.PP
The output of the package is controlled by two state variables,
\fIftp::VERBOSE\fR and \fIftp::DEBUG\fR. Setting \fIftp::VERBOSE\fR
to \fI1\fR forces the package to show all responses from a remote
server. The default value is \fI0\fR. Setting \fIftp::DEBUG\fR to
\fI1\fR enables debugging and forces the package to show all return
codes, states, state changes and "real" ftp commands. The default
value is \fI0\fR.
.PP
The procedure \fBDisplayMsg\fR is used to show the different messages
from the ftp session. The setting of \fIVERBOSE\fR determines if this
command is called or not. The current implementation of the command
uses the \fBlog\fR module of tcllib to write the messages to their
final destination. This means that the behaviour of \fBDisplayMsg\fR
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 -output option to \fBftp::Open\fR for a session specific log
command.
.PP
\fBCaution\fR: 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.
.SH "API"
.TP
\fBftp::geturl \fIurl\fR
This command lives in its own package, \fBftp::geturl\fR, and can be
used by the generic \fBuri::geturl\fR command to retrieve the contents
of ftp urls. Internally it uses the ftp commands described below to
fulfill the request.
.sp
The contents of an ftp url are defined as follows:
.RS
.TP
\fBfile\fR
The contents of the specified file itself.
.TP
\fBdirectory\fR
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.
.TP
\fBlink\fR
The attributes of the link, including the path it refers to.
.RE
.TP
\fBftp::Open\fR \fIserver\fR \fIuser\fR \fIpasswd\fR ?\fIoptions\fR?
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.
.sp
The command takes a host name \fIserver\fR, a user name \fIuser\fR and
a password \fIpassword\fR as its parameters and returns a session
handle that is an integer number greater than or equal to \fI0\fR, if
the connection is successfully established. Otherwise it returns
\fI-1\fR.  The \fIserver\fR parameter must be the name or internet
address (in dotted decimal notation) of the ftp server to connect
to. The \fIuser\fR and \fIpasswd\fR parameters must contain a valid
user name and password to complete the login process.
.sp
The options overwrite some default values or set special abilities:
.RS
.TP
-blocksize \fIsize\fP
The blocksize is used during data transfer. At most \fIsize\fR bytes
are transfered at once. The default value for this option is 4096.
The package will evaluate the \fB-progress callback\fR for the
session after the transfer of each block.
.TP
-timeout \fIseconds\fP
If \fIseconds\fR is non-zero, then \fBftp::Open\fR sets up a timeout
which will occur after the specified number of seconds. The default
value is 600.
.TP
-port \fInumber\fP
The port \fInumber\fR 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.
.TP
-mode \fImode\fP
The transfer \fImode\fR option determines if a file transfer occurs in
\fBactive\fR or \fBpassive\fR 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 \fBactive\fR.
.TP
-progress \fIcallback\fP
This \fIcallback\fR is evaluated whenever a block of data was
transfered. See the option \fB-blocksize\fR for how to specify the
size of the transfered blocks.
.sp
When evaluating the \fIcallback\fR one argument is appended to the
callback script, the current accumulated number of bytes transferred
so far.
.TP
-command \fIcallback\fP
Specifying this option places the connection into asynchronous
mode. The \fIcallback\fR 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.
.sp
When evaluating the \fIcallback\fR 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 occured during the execution of the operation the callback is
given the keyword \fBerror\fR.
.TP
-output \fIcallback\fP
This option has no default. If it is set the default implementation of
\fBDisplayMsg\fR 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.
.RE
.TP
\fBftp::Close\fR \fIhandle\fR
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 conenction afterward.
.TP
\fBftp::Cd\fR \fIhandle\fR \fIdirectory\fR
This command changes the current working directory on the ftp server
to a specified target \fIdirectory\fR.  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
.RS
.IP *
a subdirectory of the current directory,
.IP *
.B ..
(as an indicator for the parent directory of the current directory)
.IP *
or a fully qualified path to a new working directory.
.RE
.TP
\fBftp::Pwd\fR \fIhandle\fR
This command returns the complete path of the current working
directory on the ftp server, or an empty string in case of an error.
.TP
\fBftp::Type\fR \fIhandle\fR ?\fIascii|binary|tenex\fR?
This command sets the ftp file transfer type to either \fBascii\fR,
\fBbinary\fR, or \fBtenex\fR. The command always returns the
currently set type. If called without type no change is made.
.sp
Currently only \fBascii\fR and \fBbinary\fR types are
supported. There is some early (alpha) support for Tenex mode. The
type \fBascii\fR 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
\fBbinary\fR on the other hand allows the undisturbed transfer of
non-text files, such as compressed files, images and executables.
.TP
\fBftp::List\fR \fIhandle\fR ?\fIpattern\fR?
This command returns a human-readable list of files.
Wildcard expressions such as \fI*.tcl\fR are allowed. 
If \fIpattern\fR refers to a specific directory,
then the contents of that directory are returned.
If the \fIpattern\fR is not a fully-qualified path name,
the command lists entries relative to the current remote directory.
If no \fIpattern\fR is specified, the contents of the current remote
directory is returned. 
.sp
The listing includes any system-dependent information that the server
chooses to include. For example most UNIX systems produce output from
the command \fBls -l\fR. 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.
.sp
If the command fails an empty list is returned.
.TP
\fBftp::NList\fR \fIhandle\fR ?\fIdirectory\fR?
This command has the same behavior as the \fBftp::List\fR command,
except that it only retrieves an abbreviated listing. This means only
file names are returned in a sorted list.
.TP
\fBftp::FileSize\fR \fIhandle\fR \fIfile\fR
This command returns the size of the specified \fIfile\fR on the ftp
server. If the command fails an empty string is returned.
.sp
\fBATTENTION!\fR It will not work properly when in ascii mode and
is not supported by all ftp server implementations.
.TP
\fBftp::ModTime\fR \fIhandle\fR \fIfile\fR
This command retrieves the time of the last modification of the
\fIfile\fR on the ftp server as a system dependent integer value in
seconds or an empty string if an error occured. Use the built-in
command \fBclock\fR to convert the retrieves value into other formats.
.TP
\fBftp::Delete\fR \fIhandle\fR \fIfile\fR
This command deletes the specified \fIfile\fR on the ftp server. The
command returns 1 if the specified file was successfully deleted or 0
if it failed.
.TP
\fBftp::Rename\fR \fIhandle\fR \fIfrom\fR \fIto\fR
This command renames the file \fIfrom\fR in the current directory of
the ftp server to the specified new file name \fIto\fR. 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.
.TP
\fBftp::Put\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR?
This command transfers a local file \fIlocal\fR to a remote file
\fIremote\fR 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 sucessful
transfer and 0 in the case of a failure.
.sp
If \fB-data \fIdata\fR is specified instead of a local file,
the system will not transfer a file, but the \fIdata\fR passed into
it. In this case the name of the remote file has to be specified.
.sp
If \fB-channel \fIchan\fR is specified instead of a local file, the
system will not transfer a file, but read the contents of the channel
\fIchan\fR and write this to the remote file. In this case the name of
the remote file has to be specified. After the transfer \fIchan\fR
will be closed.
.TP
\fBftp::Append\fR \fIhandle\fR (\fIlocal\fR | -data \fIdata\fR | -channel \fIchan\fR) ?\fIremote\fR?
This command behaves like \fBftp::Puts\fR, but appends the transfered
information to the remote file. If the file did not exist on the
server it will be created.
.TP
\fBftp::Get\fR \fIhandle\fR \fIremote\fR ?(\fIlocal\fR | -variable \fIvarname\fR | -channel \fIchan\fR)?
This command retrieves a remote file \fIremote\fR on the ftp server
and stores its contents into the local file \fIlocal\fR. 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 sucessful transfer and 0 in the case of a failure. The
command will throw an error if the directory the file \fIlocal\fR is
to be placed in does not exist.
.sp
If \fB-variable \fIvarname\fR is specified, the system will
store the retrieved data into the variable \fIvarname\fR instead of a
file.
.sp
If \fB-channel \fIchan\fR is specified, the system will write the
retrieved data into the channel \fIchan\fR instead of a file. The
system will \fBnot\fR close \fIchan\fR after the transfer, this is the
responsibility of the caller to \fBGet\fR.
.TP
\fBftp::Reget\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR? ?\fIfrom\fR? ?\fIto\fR?
This command behaves like \fBftp::Get\fR, except that if local file
\fIlocal\fR exists and is smaller than remote file \fIremote\fR, 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
\fIlocal\fR is to be placed in does not exist. This command is useful
when transferring very large files over networks that tend to drop
connections.
.sp
Specifying the additional byte offsets \fIfrom\fR and \fIto\fR 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 \fIto\fR leads
to downloading till the end of the file.
.TP
\fBftp::Newer\fR \fIhandle\fR \fIremote\fR ?\fIlocal\fR?
This command behaves like \fBftp::Get\fR, 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 \fIlocal\fR is to be
placed in does not exist.
.TP
\fBftp::MkDir\fR \fIhandle\fR \fIdirectory\fR
This command creates the specified \fIdirectory\fR 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 sucessful creation of the directory and 0 in
the case of a failure.
.TP
\fBftp::RmDir\fR \fIhandle\fR \fIdirectory\fR
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 sucessful removal of the directory and 0 in
the case of a failure.
.TP
\fBftp::Quote\fR \fIhandle\fR \fIarg1\fR \fIarg2\fR \fI...\fR
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.
.sp
In constrast 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.
.TP
\fBftp::DisplayMsg\fR \fIhandle\fR \fImsg\fR ?\fIstate\fR?
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 \fIstdout\fR (if
\fIVERBOSE\fR 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 \fBlog\fR package can be
useful for this.
.TP
\fBftp::VERBOSE\fR
A state variable controlling the output of the package. Setting
\fIftp::VERBOSE\fR to \fI1\fR forces the package to show all
responses from a remote server. The default value is \fI0\fR.
.TP
\fBftp::DEBUG\fR
A state variable controlling the output of ftp. Setting
\fIftp::DEBUG\fR to \fI1\fR enables debugging and forces the package
to show all return codes, states, state changes and "real" ftp
commands. The default value is \fI0\fR.
.SH "BUGS"
.PP
The correct execution of many commands depends upon the proper
behavior by the remote server, network and router configuration.
.PP
An update command placed in the procedure \fBDisplayMsg\fR may run
into persistent errors or infinite loops. The solution to this problem
is to use \fBupdate idletasks\fR instead of \fBupdate\fR.
.SH "SEE ALSO"
ftpd, smtp, pop3, mime
.SH "KEYWORDS"
ftp, rfc959, internet, net

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ftp/ftp.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
# ftp.tcl --
#
#	FTP library package for Tcl 8.2+.  Originally written by Steffen
#	Traeger ([email protected]); modified by Peter MacDonald
#	([email protected]) to support multiple simultaneous FTP sessions;
#	Modified by Steve Ball ([email protected]) to support
#	asynchronous operation.
#
# Copyright (c) 1996-1999 by Steffen Traeger <[email protected]>
# 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.30 2003/04/11 18:39:17 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

    set serial 0
    set VERBOSE 0
    set 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.

    switch -exact -- $state {
        data    {log::log debug "$state | $msg"}
        control {log::log debug "$state | $msg"}
        error   {log::log error "$state | E: $msg"}
        default {log::log debug "$state | $msg"}
    }
    return
}

#############################################################################
#
# Timeout --
#
# Handle timeouts
# 
# Arguments:
#  -
#
proc ::ftp::Timeout {s} {
    upvar ::ftp::ftp$s ftp

    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

    set retvar 1

    if { ![string length $ftp(Command)] && [info exists ftp(state.control)] } {

        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 {$ftp(Error) != ""} {
        set errmsg $ftp(Error)
        set ftp(Error) ""
        DisplayMsg $s $errmsg error
    }

    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} {
    upvar ::ftp::ftp$s ftp

    if {![info exists ftp(Command)]} {
	set ftp(state.control) $value
	return $value
    }
    if { ![string length $ftp(Command)] && [info exists ftp(state.data)] } {
        vwait ::ftp::ftp${s}(state.data)
    }

    catch {after cancel $ftp(Wait)}
    set ftp(state.control) $value
    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

    # 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 [gets $sock bufline]

        if { $number > 0 } {

            # get return code, check for multi-line text
            
            regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line msgtext
            set buffer $bufline
			
            # multi-line format detected ("-"), get all the lines
            # until the real return code

            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
                }
            }
        } elseif { [eof $ftp(CtrlSock)] } {
            # remote server has closed control connection
            # kill control socket, unset State to disable all following command
            
            set rc 421
            if { $VERBOSE } {
                DisplayMsg $s "C: 421 Service not available, closing control connection." control
            }
            set ftp(Error) "Service not available!"
            CloseDataConn $s
            WaitComplete $s 0
	    Command $ftp(Command) terminated
            catch {unset ftp(State)}
            catch {close $ftp(CtrlSock); unset ftp(CtrlSock)}
            return
        } else {
	    # Fix SF bug #466746: Incomplete line, do nothing.
	    return	   
	}
    } 
	
    if { $DEBUG } {
        DisplayMsg $s "-> rc=\"$rc\"\n-> msgtext=\"$msgtext\"\n-> 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"] } {
        return
    }

    # use only the first digit 
    regexp -- "^\[0-9\]?" $rc rc
	
    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"] } {
                        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 {
		    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
                        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
		    return
		}
                2 {
                    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
                        unset ftp(state.data)
                    }  
                    set errmsg "Error opening connection!"
                    set complete_with 0
		    Command $ftp(Command) error $errmsg
                }
            }
        }
        append_close {
            switch -exact -- $rc {
                2 {
                    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
                        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 {
                    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
                        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 {
                    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)\""
	}
    }

    # finish waiting 
    if { [info exists complete_with] } {
        WaitComplete $s $complete_with
    }

    # 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 {$nextState && [info exists ftp(NextState)] && [llength $ftp(NextState)]} {
	# Pop the head of the NextState queue
	set ftp(State) [lindex $ftp(NextState) 0]
	set ftp(NextState) [lreplace $ftp(NextState) 0 0]
	StateHandler $s
    }

    # enable fileevent on control socket again
    #fileevent $ftp(CtrlSock) readable [list ::ftp::StateHandler $ftp(CtrlSock)]

}

#############################################################################
#
# 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 ""}} {
    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 { $ftp(Type) != "ascii" } {
	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)
    StateHandler $s

    # wait for synchronization
    set rc [WaitOrTimeout $s]

    # restore old type
    if { [Type $s] != $old_type } {
        Type $s $old_type
    }

    unset ftp(Dir)
    if { $rc } { 
        return [lsort $ftp(List)]
    } else {
        CloseDataConn $s
        return {}
    }
}

#############################################################################
#
# 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} {
    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}]
    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)}
        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)}
        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)
        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.

	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
            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 {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 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" data
    }
    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
    }

    # 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}]"

    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)]
	
    # 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)]

    # report ready message

    set peer [fconfigure $ftp(CtrlSock) -peername]
    if { $VERBOSE } {
        DisplayMsg $s "C: Connection from [lindex $peer 0]:[lindex $peer 2]" 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} {
        foreach i [eval ::ftp::List_org $args] {
            puts $i
        }
    }

    # 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} 1]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ftp/ftp_geturl.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
# ftp_geturl.tcl --
#
# Copyright (c) 2001 by Andreas Kupries <[email protected]>
#
# 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) "[email protected]"
    }
    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 command $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] {
	- {
	    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} 1]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































Deleted modules/ftp/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
# 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 ftp         2.4 [list source [file join $dir ftp.tcl]]
package ifneeded ftp::geturl 0.2 [list source [file join $dir ftp_geturl.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted modules/ftpd/ChangeLog.

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

	* ftpd.tcl:
	* ftpd.man:
	* pkgIndex.tcl: Fixed bug #614591. Set version of the package to
	  to 1.1.3.

2003-01-16  Andreas Kupries  <[email protected]>

	* ftpd.man: More semantic markup, less visual one.

2002-08-30  Andreas Kupries  <[email protected]>

	* ftpd.tcl: Updated 'info exist' to 'info exists'.

2002-06-03  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl:
	* ftpd.tcl:
	* ftpd.n:
	* ftpd.man: Bumped to version 1.1.2.

2002-03-20  Andreas Kupries  <[email protected]>

	* ftpd.man: New, doctools manpage.

2002-03-19  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* ftpd.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-06-21  Andreas Kupries <[email protected]>

	* ftpd.tcl: Fixed dubious code reported by frink.

2000-11-22  Eric Melski  <[email protected]>

	* 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  <[email protected]>

	* Integrated patch from Keith Vetter <[email protected]>
	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  <[email protected]>

	* Made some fixes to better support windows.

2000-10-27  Dan Kuchler  <[email protected]>

	* Initial revision of tcllib ftpd.  Based off of the ftpd in
	the stdtcl distribution.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































Deleted modules/ftpd/ftpd.man.

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

The [package ftpd] package provides a simple Tcl-only server library
for the FTP protocol.  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]

[lst_item "-authIpCmd [arg proc]"]

Callback to authenticate new connections based on the ip-address of
the peer.

[lst_item "-authUsrCmd [arg proc]"]

Callback to authenticate new connections based on the user logging in
(and the users password).

[lst_item "-authFileCmd [arg proc]"]

Callback to accept or deny a users access to read and write to a
specific path or file.

[lst_item "-logCmd [arg proc]"]

Callback for log information generated by the FTP engine.

[lst_item "-fsCmd [arg proc]"]

Callback to connect the engine to the filesystem it operates on.

[list_end]
[list_end]

[section CALLBACKS]

[list_begin definitions]

[lst_item "[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.

[lst_item "[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.

[lst_item "[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.

[lst_item "[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.

[lst_item "[cmd fsCmd] callback"]]

The fsCmd receives a subcommand, a filename or path, and optional
additional arguments (depending on the subcommand).

[nl]
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]
[list_end]

[section VARIABLES]

[list_begin definitions]

[lst_item [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.

[lst_item [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.

[lst_item [var ::ftpd::port]]

The port that the ftp server should listen on.

[lst_item [var ::ftpd::welcome]]

The message that is printed out when the user first connects to the
ftp server.


[list_end]

[keywords ftpd ftp ftpserver services {rfc 959}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































Deleted modules/ftpd/ftpd.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
'\"
'\" Copyright (c) 2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: ftpd.n,v 1.5 2002/06/03 20:21:46 andreas_kupries Exp $
'\" 
.so man.macros
.TH ftpd n 1.1.2 ftpd "Tcl FTP Server Package"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
ftpd \- Tcl FTP server implementation
.SH SYNOPSIS
\fBpackage require Tcl 8.3\fR
.sp
\fBpackage require ftpd ?1.1.2?\fR
.sp
\fB::ftpd::server\fR \fR?\fImyaddr\fR?\fR
.sp
\fB::ftpd::config\fR \fR?\fIoption\fR \fIvalue\fR?\fR \fR?\fIoption\fR \fIvalue\fR \fI...\fR?\fR
.sp

.BE
.SH DESCRIPTION
.PP
The \fBftpd\fR package provides a simple Tcl-only server library for
the FTP protocol.  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 bgerror will be thrown
on the server if there are problems with the code in the module.

.SH COMMANDS
.TP
\fB::ftpd::server\fR \fR?\fImyaddr\fR?\fR
Open a listening socket to listen to and accept ftp connections.
myaddr is an optional argument.  \fBmyaddr\fR is the domain-style name or
numerical IP address of the client-side network interface to use for the
connection.
.TP
\fB::ftpd::config\fR \fR?\fIoption\fR \fIvalue\fR?\fR \fR?\fIoption\fR \fIvalue\fR \fI...\fR?\fR
The value is always the proc to call as the callback.  The option specifies
which callback should be configured.  See the CALLBACKS section for
descriptions of the arguments and return values for each of the callbacks.
.RS
.TP
\fB-authIpCmd proc\fR
Callback to authenticate new connections based on the ip-address of the
peer.
.TP
\fB-authUsrCmd proc\fR
Callback to authenticate new connections based on the  user logging in (and
the users password).
.TP
\fB-authFileCmd proc\fR
Callback to accept or deny a users access to read and write to a specific
path or file.
.TP
\fB-logCmd proc\fR
Callback for log information generated by the FTP engine.
.TP
\fB-fsCmd proc\fR
Callback to connect the engine to the filesystem it operates on.
.RE
.TP
.SH CALLBACKS
.TP
\fBauthIpCmd callback\fR
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.
.TP
\fBauthUsrCmd callback\fR
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.
.TP
\fBauthFileCmd callback\fR
The authFileCmd receives the user (that is currently logged in), the
path or filename that is about to be read or written, and \fBread\fR
or \fBwrite\fR 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.
.TP
\fBlogCmd callback\fR
The logCmd receives a severity and a message as its two arguments.  The
severities used within the ftpd package are \fBnote\fR, \fBdebug\fR, and
\fBerror\fR.  The logCmd doesn't return anything.
.TP
\fBfsCmd callback\fR
The fsCmd receives a subcommand, a filename or path, and optional
additional arguments (depending on the subcommand).
.SP
The subcommands supported by the fsCmd are:
.RS
.TP
\fBappend\fR <path>
The append subcommand receives the filename to append to as its argument. It
returns a writable tcl channel as its return value.
.TP
\fBdelete\fR <path> <channel-to-write-to>
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.
.TP
\fBdlist\fR <path> <style> <channel-to-write-dir-list-to>
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
\fBnlst\fR or \fBlist\fR, 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 \fBnlst\fR only the name of the file is printed to the
channel.  If the style is \fBlist\fR 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 dlist subcommand returns nothing.
.TP
\fBexists\fR <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.
.TP
\fBmkdir\fR <path> <channel-to-write-to>
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.
.TP
\fBmtime\fR <path> <channel-to-write-mtime-to>
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.
.TP
\fBpermissions\fR <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.
.TP
\fBrename\fR <path> <newpath> <channel-to-write-to>
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.
.TP
\fBretr\fR <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.
.TP
\fBrmdir\fR <path> <channel-to-write-to>
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.
.TP
\fBsize\fR <path> <channel-to-write-size-to>
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.
.TP
\fBstore\fR <path>
The store subcommand receives the path of a file to write as its only
argument.  The store subcommand returns a writable channel.
.RE
.TP
.SH VARIABLES
.TP
\fB::ftpd::cwd\fR
The current working directory for a session when someone first connects to
the FTPD or when the REIN ftp command is received.
.TP
\fB::ftpd::contact\fR
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 FTP HELP command.
.TP
\fB::ftpd::port\fR
The port that the ftp server should listen on.
.TP
\fB::ftpd::welcome\fR
The message that is printed out when the user first connects to the ftp server.
.TP
.SH KEYWORDS
ftpd, ftp, ftpserver, services, RFC 959




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































Deleted modules/ftpd/ftpd.tcl.

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

# Define the ftpd package version 1.1.2

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 \
	    authIpCmd  {} \
	    authUsrCmd {::ftpd::anonAuth} \
            authFileCmd {::ftpd::fileAuth} \
	    logCmd     {::ftpd::logStderr} \
	    fsCmd      {::ftpd::fsFile::fs}]
    }

    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

    array set cfg [cmdline::getoptions args [list \
	{authIpCmd.arg  {} {Callback to authenticate new connections based on the ip-address of the peer. Optional}} \
	{authUsrCmd.arg {::ftpd::anonAuth} {Callback to authenticate new connections based on the user logging in.}} \
	{authFileCmd.arg {::ftpd::fileAuth} {Callback to accept or deny a users access to read and write to a specific path or file.}} \
	{logCmd.arg {::ftpd::logStderr} {Callback for log information generated by the FTP engine.}} \
	{fsCmd.arg {::ftpd::fsFile::fs} {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
    if {[string length $myaddr]} {
	socket -server ::ftpd::accept -myaddr $myaddr $port
    } else {
	socket -server ::ftpd::accept $port
    }
    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

    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 \
	state		command \
	buffering	line \
	cwd		"$cwd" \
	mode		binary \
        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

    if {[eof $sock]} {
	Finish $sock
	return
    }
    switch -exact -- $data(state) {
	command {
	    gets $sock command
	    set parts [split $command]
	    set cmd [string toupper [lindex  $parts 0]]
	    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 command ::ftpd::command::$cmd] != ""} {
		Log debug $command
		::ftpd::command::$cmd $sock [lrange $parts 1 end]
		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} {
    close $sock
    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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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))"
	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 list} {
    upvar #0 ::ftpd::$sock data

    set relativepath [lindex $list 0]

    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 data(cwd) [file join $data(cwd) $relativepath]
    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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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 list} {
    upvar #0 ::ftpd::$sock data

    if {[llength $list] > 0} {
        set command [string toupper [lindex $list 0]]
        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 list} {
    set filename [lindex $list 0]
    ::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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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 list} {
    set filename [lindex $list 0]
    ::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 list} {
    upvar #0 ::ftpd::$sock data

    if {[llength $list] == 0} {
        puts $sock "530 Please login with USER and PASS."
        return
    }
    set data(pass) [lindex $list 0]

    ::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 "200 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 list} {
    upvar #0 ::ftpd::$sock data
    set x [split [lindex $list 0] ,]

    ::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."
    close $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

    # Reinitialize the user and connection data.

    array set data [list \
        access          0 \
	state		command \
	buffering	line \
	cwd		"$::ftpd::cwd" \
	mode		binary \
        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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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))"
	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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    set path [file join $data(cwd) [string trimleft $filename /]]

    if {[file 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 list} {

    if {[llength $list] == 0} {
        puts $sock "500 'RNTO': command not understood."
        return
    }
    set filename [lindex $list 0]
    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} 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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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))"
	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 list} {
    upvar #0 ::ftpd::$sock data

    set filename [lindex $list 0]
    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))"
	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 list} {
    upvar #0 ::ftpd::$sock data
    set type [lindex $list 0]
    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 list} {
    upvar #0 ::ftpd::$sock data

    if {[llength $list] == 0} {
        puts $sock "530 Please login with USER and PASS."
        return
    }
    set data(user) [lindex $list 0]
    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
    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)."
    }
    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]

    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
          }
          return $fhandle
        }
	retr {
          #
          # Patched Mark O'Connor
          #
	    set fhandle [open $path r]
          if {[lindex $args 0] == "binary"} {
             fconfigure $fhandle -translation binary
          }
          return $fhandle
	}
	store {
          #
          # Patched Mark O'Connor
          #
	    set fhandle [open $path w]
          if {[lindex $args 0] == "binary"} {
             fconfigure $fhandle -translation binary
          }
          return $fhandle
	}
	dlist {
	    foreach {style outchan} $args break
	    set path [glob -nocomplain $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]]]

	    switch -- $style {
	        nlst {
	            foreach f [lsort $fileList] {
                        if {[string equal [file tail $f] "."] || \
                                [string equal [file tail $f] ".."]} {
                            continue
                        }
		        puts $outchan $f
	            }
	        }
		list {
	            foreach f [lsort $fileList] {
			file stat $f stat
                        if {[string equal $tcl_platform(platform) "unix"]} {
                            set user [file attributes $f -owner]
                            set group [file attributes $f -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]]
                        } else {
                            puts $outchan [format "%s %3d %11s %s %s" \
                                    [PermBits $f $stat(mode)] $stat(nlink) \
                                    $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 $sock "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.1.3

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ftpd/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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.3]} {return}
package ifneeded ftpd 1.1.3 [list source [file join $dir ftpd.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/ftpd/rfc959.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933

                                                                        
Network Working Group                                          J. Postel
Request for Comments: 959                                    J. Reynolds
                                                                     ISI
Obsoletes RFC: 765 (IEN 149)                                October 1985

                      FILE TRANSFER PROTOCOL (FTP)


Status of this Memo

   This memo is the official specification of the File Transfer
   Protocol (FTP).  Distribution of this memo is unlimited.

   The following new optional commands are included in this edition of
   the specification:

      CDUP (Change to Parent Directory), SMNT (Structure Mount), STOU
      (Store Unique), RMD (Remove Directory), MKD (Make Directory), PWD
      (Print Directory), and SYST (System).

   Note that this specification is compatible with the previous edition.

1.  INTRODUCTION

   The objectives of FTP are 1) to promote sharing of files (computer
   programs and/or data), 2) to encourage indirect or implicit (via
   programs) use of remote computers, 3) to shield a user from
   variations in file storage systems among hosts, and 4) to transfer
   data reliably and efficiently.  FTP, though usable directly by a user
   at a terminal, is designed mainly for use by programs.

   The attempt in this specification is to satisfy the diverse needs of
   users of maxi-hosts, mini-hosts, personal workstations, and TACs,
   with a simple, and easily implemented protocol design.

   This paper assumes knowledge of the Transmission Control Protocol
   (TCP) [2] and the Telnet Protocol [3].  These documents are contained
   in the ARPA-Internet protocol handbook [1].

2.  OVERVIEW

   In this section, the history, the terminology, and the FTP model are
   discussed.  The terms defined in this section are only those that
   have special significance in FTP.  Some of the terminology is very
   specific to the FTP model; some readers may wish to turn to the
   section on the FTP model while reviewing the terminology.







Postel & Reynolds                                               [Page 1]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   2.1.  HISTORY

      FTP has had a long evolution over the years.  Appendix III is a
      chronological compilation of Request for Comments documents
      relating to FTP.  These include the first proposed file transfer
      mechanisms in 1971 that were developed for implementation on hosts
      at M.I.T. (RFC 114), plus comments and discussion in RFC 141.

      RFC 172 provided a user-level oriented protocol for file transfer
      between host computers (including terminal IMPs).  A revision of
      this as RFC 265, restated FTP for additional review, while RFC 281
      suggested further changes.  The use of a "Set Data Type"
      transaction was proposed in RFC 294 in January 1982.

      RFC 354 obsoleted RFCs 264 and 265.  The File Transfer Protocol
      was now defined as a protocol for file transfer between HOSTs on
      the ARPANET, with the primary function of FTP defined as
      transfering files efficiently and reliably among hosts and
      allowing the convenient use of remote file storage capabilities.
      RFC 385 further commented on errors, emphasis points, and
      additions to the protocol, while RFC 414 provided a status report
      on the working server and user FTPs.  RFC 430, issued in 1973,
      (among other RFCs too numerous to mention) presented further
      comments on FTP.  Finally, an "official" FTP document was
      published as RFC 454.

      By July 1973, considerable changes from the last versions of FTP
      were made, but the general structure remained the same.  RFC 542
      was published as a new "official" specification to reflect these
      changes.  However, many implementations based on the older
      specification were not updated.

      In 1974, RFCs 607 and 614 continued comments on FTP.  RFC 624
      proposed further design changes and minor modifications.  In 1975,
      RFC 686 entitled, "Leaving Well Enough Alone", discussed the
      differences between all of the early and later versions of FTP.
      RFC 691 presented a minor revision of RFC 686, regarding the
      subject of print files.

      Motivated by the transition from the NCP to the TCP as the
      underlying protocol, a phoenix was born out of all of the above
      efforts in RFC 765 as the specification of FTP for use on TCP.

      This current edition of the FTP specification is intended to
      correct some minor documentation errors, to improve the
      explanation of some protocol features, and to add some new
      optional commands.


Postel & Reynolds                                               [Page 2]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      In particular, the following new optional commands are included in
      this edition of the specification:

         CDUP - Change to Parent Directory

         SMNT - Structure Mount

         STOU - Store Unique

         RMD - Remove Directory

         MKD - Make Directory

         PWD - Print Directory

         SYST - System

      This specification is compatible with the previous edition.  A
      program implemented in conformance to the previous specification
      should automatically be in conformance to this specification.

   2.2.  TERMINOLOGY

      ASCII

         The ASCII character set is as defined in the ARPA-Internet
         Protocol Handbook.  In FTP, ASCII characters are defined to be
         the lower half of an eight-bit code set (i.e., the most
         significant bit is zero).

      access controls

         Access controls define users' access privileges to the use of a
         system, and to the files in that system.  Access controls are
         necessary to prevent unauthorized or accidental use of files.
         It is the prerogative of a server-FTP process to invoke access
         controls.

      byte size

         There are two byte sizes of interest in FTP:  the logical byte
         size of the file, and the transfer byte size used for the
         transmission of the data.  The transfer byte size is always 8
         bits.  The transfer byte size is not necessarily the byte size
         in which data is to be stored in a system, nor the logical byte
         size for interpretation of the structure of the data.



Postel & Reynolds                                               [Page 3]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      control connection

         The communication path between the USER-PI and SERVER-PI for
         the exchange of commands and replies.  This connection follows
         the Telnet Protocol.

      data connection

         A full duplex connection over which data is transferred, in a
         specified mode and type. The data transferred may be a part of
         a file, an entire file or a number of files.  The path may be
         between a server-DTP and a user-DTP, or between two
         server-DTPs.

      data port

         The passive data transfer process "listens" on the data port
         for a connection from the active transfer process in order to
         open the data connection.

      DTP

         The data transfer process establishes and manages the data
         connection.  The DTP can be passive or active.

      End-of-Line

         The end-of-line sequence defines the separation of printing
         lines.  The sequence is Carriage Return, followed by Line Feed.

      EOF

         The end-of-file condition that defines the end of a file being
         transferred.

      EOR

         The end-of-record condition that defines the end of a record
         being transferred.

      error recovery

         A procedure that allows a user to recover from certain errors
         such as failure of either host system or transfer process.  In
         FTP, error recovery may involve restarting a file transfer at a
         given checkpoint.



Postel & Reynolds                                               [Page 4]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      FTP commands

         A set of commands that comprise the control information flowing
         from the user-FTP to the server-FTP process.

      file

         An ordered set of computer data (including programs), of
         arbitrary length, uniquely identified by a pathname.

      mode

         The mode in which data is to be transferred via the data
         connection.  The mode defines the data format during transfer
         including EOR and EOF.  The transfer modes defined in FTP are
         described in the Section on Transmission Modes.

      NVT

         The Network Virtual Terminal as defined in the Telnet Protocol.

      NVFS

         The Network Virtual File System.  A concept which defines a
         standard network file system with standard commands and
         pathname conventions.

      page

         A file may be structured as a set of independent parts called
         pages.  FTP supports the transmission of discontinuous files as
         independent indexed pages.

      pathname

         Pathname is defined to be the character string which must be
         input to a file system by a user in order to identify a file.
         Pathname normally contains device and/or directory names, and
         file name specification.  FTP does not yet specify a standard
         pathname convention.  Each user must follow the file naming
         conventions of the file systems involved in the transfer.

      PI

         The protocol interpreter.  The user and server sides of the
         protocol have distinct roles implemented in a user-PI and a
         server-PI.


Postel & Reynolds                                               [Page 5]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      record

         A sequential file may be structured as a number of contiguous
         parts called records.  Record structures are supported by FTP
         but a file need not have record structure.

      reply

         A reply is an acknowledgment (positive or negative) sent from
         server to user via the control connection in response to FTP
         commands.  The general form of a reply is a completion code
         (including error codes) followed by a text string.  The codes
         are for use by programs and the text is usually intended for
         human users.

      server-DTP

         The data transfer process, in its normal "active" state,
         establishes the data connection with the "listening" data port.
         It sets up parameters for transfer and storage, and transfers
         data on command from its PI.  The DTP can be placed in a
         "passive" state to listen for, rather than initiate a
         connection on the data port.

      server-FTP process

         A process or set of processes which perform the function of
         file transfer in cooperation with a user-FTP process and,
         possibly, another server.  The functions consist of a protocol
         interpreter (PI) and a data transfer process (DTP).

      server-PI

         The server protocol interpreter "listens" on Port L for a
         connection from a user-PI and establishes a control
         communication connection.  It receives standard FTP commands
         from the user-PI, sends replies, and governs the server-DTP.

      type

         The data representation type used for data transfer and
         storage.  Type implies certain transformations between the time
         of data storage and data transfer.  The representation types
         defined in FTP are described in the Section on Establishing
         Data Connections.




Postel & Reynolds                                               [Page 6]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      user

         A person or a process on behalf of a person wishing to obtain
         file transfer service.  The human user may interact directly
         with a server-FTP process, but use of a user-FTP process is
         preferred since the protocol design is weighted towards
         automata.

      user-DTP

         The data transfer process "listens" on the data port for a
         connection from a server-FTP process.  If two servers are
         transferring data between them, the user-DTP is inactive.

      user-FTP process

         A set of functions including a protocol interpreter, a data
         transfer process and a user interface which together perform
         the function of file transfer in cooperation with one or more
         server-FTP processes.  The user interface allows a local
         language to be used in the command-reply dialogue with the
         user.

      user-PI

         The user protocol interpreter initiates the control connection
         from its port U to the server-FTP process, initiates FTP
         commands, and governs the user-DTP if that process is part of
         the file transfer.




















Postel & Reynolds                                               [Page 7]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   2.3.  THE FTP MODEL

      With the above definitions in mind, the following model (shown in
      Figure 1) may be diagrammed for an FTP service.

                                            -------------
                                            |/---------\|
                                            ||   User  ||    --------
                                            ||Interface|<--->| User |
                                            |\----^----/|    --------
                  ----------                |     |     |
                  |/------\|  FTP Commands  |/----V----\|
                  ||Server|<---------------->|   User  ||
                  ||  PI  ||   FTP Replies  ||    PI   ||
                  |\--^---/|                |\----^----/|
                  |   |    |                |     |     |
      --------    |/--V---\|      Data      |/----V----\|    --------
      | File |<--->|Server|<---------------->|  User   |<--->| File |
      |System|    || DTP  ||   Connection   ||   DTP   ||    |System|
      --------    |\------/|                |\---------/|    --------
                  ----------                -------------

                  Server-FTP                   USER-FTP

      NOTES: 1. The data connection may be used in either direction.
             2. The data connection need not exist all of the time.

                      Figure 1  Model for FTP Use

      In the model described in Figure 1, the user-protocol interpreter
      initiates the control connection.  The control connection follows
      the Telnet protocol.  At the initiation of the user, standard FTP
      commands are generated by the user-PI and transmitted to the
      server process via the control connection.  (The user may
      establish a direct control connection to the server-FTP, from a
      TAC terminal for example, and generate standard FTP commands
      independently, bypassing the user-FTP process.) Standard replies
      are sent from the server-PI to the user-PI over the control
      connection in response to the commands.

      The FTP commands specify the parameters for the data connection
      (data port, transfer mode, representation type, and structure) and
      the nature of file system operation (store, retrieve, append,
      delete, etc.).  The user-DTP or its designate should "listen" on
      the specified data port, and the server initiate the data
      connection and data transfer in accordance with the specified
      parameters.  It should be noted that the data port need not be in


Postel & Reynolds                                               [Page 8]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      the same host that initiates the FTP commands via the control
      connection, but the user or the user-FTP process must ensure a
      "listen" on the specified data port.  It ought to also be noted
      that the data connection may be used for simultaneous sending and
      receiving.

      In another situation a user might wish to transfer files between
      two hosts, neither of which is a local host. The user sets up
      control connections to the two servers and then arranges for a
      data connection between them.  In this manner, control information
      is passed to the user-PI but data is transferred between the
      server data transfer processes.  Following is a model of this
      server-server interaction.

      
                    Control     ------------   Control
                    ---------->| User-FTP |<-----------
                    |          | User-PI  |           |
                    |          |   "C"    |           |
                    V          ------------           V
            --------------                        --------------
            | Server-FTP |   Data Connection      | Server-FTP |
            |    "A"     |<---------------------->|    "B"     |
            -------------- Port (A)      Port (B) --------------
      

                                 Figure 2

      The protocol requires that the control connections be open while
      data transfer is in progress.  It is the responsibility of the
      user to request the closing of the control connections when
      finished using the FTP service, while it is the server who takes
      the action.  The server may abort data transfer if the control
      connections are closed without command.

      The Relationship between FTP and Telnet:

         The FTP uses the Telnet protocol on the control connection.
         This can be achieved in two ways: first, the user-PI or the
         server-PI may implement the rules of the Telnet Protocol
         directly in their own procedures; or, second, the user-PI or
         the server-PI may make use of the existing Telnet module in the
         system.

         Ease of implementaion, sharing code, and modular programming
         argue for the second approach.  Efficiency and independence



Postel & Reynolds                                               [Page 9]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         argue for the first approach.  In practice, FTP relies on very
         little of the Telnet Protocol, so the first approach does not
         necessarily involve a large amount of code.

3.  DATA TRANSFER FUNCTIONS

   Files are transferred only via the data connection.  The control
   connection is used for the transfer of commands, which describe the
   functions to be performed, and the replies to these commands (see the
   Section on FTP Replies).  Several commands are concerned with the
   transfer of data between hosts.  These data transfer commands include
   the MODE command which specify how the bits of the data are to be
   transmitted, and the STRUcture and TYPE commands, which are used to
   define the way in which the data are to be represented.  The
   transmission and representation are basically independent but the
   "Stream" transmission mode is dependent on the file structure
   attribute and if "Compressed" transmission mode is used, the nature
   of the filler byte depends on the representation type.

   3.1.  DATA REPRESENTATION AND STORAGE

      Data is transferred from a storage device in the sending host to a
      storage device in the receiving host.  Often it is necessary to
      perform certain transformations on the data because data storage
      representations in the two systems are different.  For example,
      NVT-ASCII has different data storage representations in different
      systems.  DEC TOPS-20s's generally store NVT-ASCII as five 7-bit
      ASCII characters, left-justified in a 36-bit word. IBM Mainframe's
      store NVT-ASCII as 8-bit EBCDIC codes.  Multics stores NVT-ASCII
      as four 9-bit characters in a 36-bit word.  It is desirable to
      convert characters into the standard NVT-ASCII representation when
      transmitting text between dissimilar systems.  The sending and
      receiving sites would have to perform the necessary
      transformations between the standard representation and their
      internal representations.

      A different problem in representation arises when transmitting
      binary data (not character codes) between host systems with
      different word lengths.  It is not always clear how the sender
      should send data, and the receiver store it.  For example, when
      transmitting 32-bit bytes from a 32-bit word-length system to a
      36-bit word-length system, it may be desirable (for reasons of
      efficiency and usefulness) to store the 32-bit bytes
      right-justified in a 36-bit word in the latter system.  In any
      case, the user should have the option of specifying data
      representation and transformation functions.  It should be noted



Postel & Reynolds                                              [Page 10]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      that FTP provides for very limited data type representations.
      Transformations desired beyond this limited capability should be
      performed by the user directly.

      3.1.1.  DATA TYPES

         Data representations are handled in FTP by a user specifying a
         representation type.  This type may implicitly (as in ASCII or
         EBCDIC) or explicitly (as in Local byte) define a byte size for
         interpretation which is referred to as the "logical byte size."
         Note that this has nothing to do with the byte size used for
         transmission over the data connection, called the "transfer
         byte size", and the two should not be confused.  For example,
         NVT-ASCII has a logical byte size of 8 bits.  If the type is
         Local byte, then the TYPE command has an obligatory second
         parameter specifying the logical byte size.  The transfer byte
         size is always 8 bits.

         3.1.1.1.  ASCII TYPE

            This is the default type and must be accepted by all FTP
            implementations.  It is intended primarily for the transfer
            of text files, except when both hosts would find the EBCDIC
            type more convenient.

            The sender converts the data from an internal character
            representation to the standard 8-bit NVT-ASCII
            representation (see the Telnet specification).  The receiver
            will convert the data from the standard form to his own
            internal form.

            In accordance with the NVT standard, the <CRLF> sequence
            should be used where necessary to denote the end of a line
            of text.  (See the discussion of file structure at the end
            of the Section on Data Representation and Storage.)

            Using the standard NVT-ASCII representation means that data
            must be interpreted as 8-bit bytes.

            The Format parameter for ASCII and EBCDIC types is discussed
            below.








Postel & Reynolds                                              [Page 11]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         3.1.1.2.  EBCDIC TYPE

            This type is intended for efficient transfer between hosts
            which use EBCDIC for their internal character
            representation.

            For transmission, the data are represented as 8-bit EBCDIC
            characters.  The character code is the only difference
            between the functional specifications of EBCDIC and ASCII
            types.

            End-of-line (as opposed to end-of-record--see the discussion
            of structure) will probably be rarely used with EBCDIC type
            for purposes of denoting structure, but where it is
            necessary the <NL> character should be used.

         3.1.1.3.  IMAGE TYPE

            The data are sent as contiguous bits which, for transfer,
            are packed into the 8-bit transfer bytes.  The receiving
            site must store the data as contiguous bits.  The structure
            of the storage system might necessitate the padding of the
            file (or of each record, for a record-structured file) to
            some convenient boundary (byte, word or block).  This
            padding, which must be all zeros, may occur only at the end
            of the file (or at the end of each record) and there must be
            a way of identifying the padding bits so that they may be
            stripped off if the file is retrieved.  The padding
            transformation should be well publicized to enable a user to
            process a file at the storage site.

            Image type is intended for the efficient storage and
            retrieval of files and for the transfer of binary data.  It
            is recommended that this type be accepted by all FTP
            implementations.

         3.1.1.4.  LOCAL TYPE

            The data is transferred in logical bytes of the size
            specified by the obligatory second parameter, Byte size.
            The value of Byte size must be a decimal integer; there is
            no default value.  The logical byte size is not necessarily
            the same as the transfer byte size.  If there is a
            difference in byte sizes, then the logical bytes should be
            packed contiguously, disregarding transfer byte boundaries
            and with any necessary padding at the end.



Postel & Reynolds                                              [Page 12]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            When the data reaches the receiving host, it will be
            transformed in a manner dependent on the logical byte size
            and the particular host.  This transformation must be
            invertible (i.e., an identical file can be retrieved if the
            same parameters are used) and should be well publicized by
            the FTP implementors.

            For example, a user sending 36-bit floating-point numbers to
            a host with a 32-bit word could send that data as Local byte
            with a logical byte size of 36.  The receiving host would
            then be expected to store the logical bytes so that they
            could be easily manipulated; in this example putting the
            36-bit logical bytes into 64-bit double words should
            suffice.

            In another example, a pair of hosts with a 36-bit word size
            may send data to one another in words by using TYPE L 36.
            The data would be sent in the 8-bit transmission bytes
            packed so that 9 transmission bytes carried two host words.

         3.1.1.5.  FORMAT CONTROL

            The types ASCII and EBCDIC also take a second (optional)
            parameter; this is to indicate what kind of vertical format
            control, if any, is associated with a file.  The following
            data representation types are defined in FTP:

            A character file may be transferred to a host for one of
            three purposes: for printing, for storage and later
            retrieval, or for processing.  If a file is sent for
            printing, the receiving host must know how the vertical
            format control is represented.  In the second case, it must
            be possible to store a file at a host and then retrieve it
            later in exactly the same form.  Finally, it should be
            possible to move a file from one host to another and process
            the file at the second host without undue trouble.  A single
            ASCII or EBCDIC format does not satisfy all these
            conditions.  Therefore, these types have a second parameter
            specifying one of the following three formats:

            3.1.1.5.1.  NON PRINT

               This is the default format to be used if the second
               (format) parameter is omitted.  Non-print format must be
               accepted by all FTP implementations.




Postel & Reynolds                                              [Page 13]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               The file need contain no vertical format information.  If
               it is passed to a printer process, this process may
               assume standard values for spacing and margins.

               Normally, this format will be used with files destined
               for processing or just storage.

            3.1.1.5.2.  TELNET FORMAT CONTROLS

               The file contains ASCII/EBCDIC vertical format controls
               (i.e., <CR>, <LF>, <NL>, <VT>, <FF>) which the printer
               process will interpret appropriately.  <CRLF>, in exactly
               this sequence, also denotes end-of-line.

            3.1.1.5.2.  CARRIAGE CONTROL (ASA)

               The file contains ASA (FORTRAN) vertical format control
               characters.  (See RFC 740 Appendix C; and Communications
               of the ACM, Vol. 7, No. 10, p. 606, October 1964.)  In a
               line or a record formatted according to the ASA Standard,
               the first character is not to be printed.  Instead, it
               should be used to determine the vertical movement of the
               paper which should take place before the rest of the
               record is printed.

               The ASA Standard specifies the following control
               characters:

                  Character     Vertical Spacing

                  blank         Move paper up one line
                  0             Move paper up two lines
                  1             Move paper to top of next page
                  +             No movement, i.e., overprint

               Clearly there must be some way for a printer process to
               distinguish the end of the structural entity.  If a file
               has record structure (see below) this is no problem;
               records will be explicitly marked during transfer and
               storage.  If the file has no record structure, the <CRLF>
               end-of-line sequence is used to separate printing lines,
               but these format effectors are overridden by the ASA
               controls.






Postel & Reynolds                                              [Page 14]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      3.1.2.  DATA STRUCTURES

         In addition to different representation types, FTP allows the
         structure of a file to be specified.  Three file structures are
         defined in FTP:

            file-structure,     where there is no internal structure and
                                the file is considered to be a
                                continuous sequence of data bytes,

            record-structure,   where the file is made up of sequential
                                records,

            and page-structure, where the file is made up of independent
                                indexed pages.

         File-structure is the default to be assumed if the STRUcture
         command has not been used but both file and record structures
         must be accepted for "text" files (i.e., files with TYPE ASCII
         or EBCDIC) by all FTP implementations.  The structure of a file
         will affect both the transfer mode of a file (see the Section
         on Transmission Modes) and the interpretation and storage of
         the file.

         The "natural" structure of a file will depend on which host
         stores the file.  A source-code file will usually be stored on
         an IBM Mainframe in fixed length records but on a DEC TOPS-20
         as a stream of characters partitioned into lines, for example
         by <CRLF>.  If the transfer of files between such disparate
         sites is to be useful, there must be some way for one site to
         recognize the other's assumptions about the file.

         With some sites being naturally file-oriented and others
         naturally record-oriented there may be problems if a file with
         one structure is sent to a host oriented to the other.  If a
         text file is sent with record-structure to a host which is file
         oriented, then that host should apply an internal
         transformation to the file based on the record structure.
         Obviously, this transformation should be useful, but it must
         also be invertible so that an identical file may be retrieved
         using record structure.

         In the case of a file being sent with file-structure to a
         record-oriented host, there exists the question of what
         criteria the host should use to divide the file into records
         which can be processed locally.  If this division is necessary,
         the FTP implementation should use the end-of-line sequence,


Postel & Reynolds                                              [Page 15]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         <CRLF> for ASCII, or <NL> for EBCDIC text files, as the
         delimiter.  If an FTP implementation adopts this technique, it
         must be prepared to reverse the transformation if the file is
         retrieved with file-structure.

         3.1.2.1.  FILE STRUCTURE

            File structure is the default to be assumed if the STRUcture
            command has not been used.

            In file-structure there is no internal structure and the
            file is considered to be a continuous sequence of data
            bytes.

         3.1.2.2.  RECORD STRUCTURE

            Record structures must be accepted for "text" files (i.e.,
            files with TYPE ASCII or EBCDIC) by all FTP implementations.

            In record-structure the file is made up of sequential
            records.

         3.1.2.3.  PAGE STRUCTURE

            To transmit files that are discontinuous, FTP defines a page
            structure.  Files of this type are sometimes known as
            "random access files" or even as "holey files".  In these
            files there is sometimes other information associated with
            the file as a whole (e.g., a file descriptor), or with a
            section of the file (e.g., page access controls), or both.
            In FTP, the sections of the file are called pages.

            To provide for various page sizes and associated
            information, each page is sent with a page header.  The page
            header has the following defined fields:

               Header Length

                  The number of logical bytes in the page header
                  including this byte.  The minimum header length is 4.

               Page Index

                  The logical page number of this section of the file.
                  This is not the transmission sequence number of this
                  page, but the index used to identify this page of the
                  file.


Postel & Reynolds                                              [Page 16]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               Data Length

                  The number of logical bytes in the page data.  The
                  minimum data length is 0.

               Page Type

                  The type of page this is.  The following page types
                  are defined:

                     0 = Last Page

                        This is used to indicate the end of a paged
                        structured transmission.  The header length must
                        be 4, and the data length must be 0.

                     1 = Simple Page

                        This is the normal type for simple paged files
                        with no page level associated control
                        information.  The header length must be 4.

                     2 = Descriptor Page

                        This type is used to transmit the descriptive
                        information for the file as a whole.

                     3 = Access Controlled Page

                        This type includes an additional header field
                        for paged files with page level access control
                        information.  The header length must be 5.

               Optional Fields

                  Further header fields may be used to supply per page
                  control information, for example, per page access
                  control.

            All fields are one logical byte in length.  The logical byte
            size is specified by the TYPE command.  See Appendix I for
            further details and a specific case at the page structure.

      A note of caution about parameters:  a file must be stored and
      retrieved with the same parameters if the retrieved version is to




Postel & Reynolds                                              [Page 17]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      be identical to the version originally transmitted.  Conversely,
      FTP implementations must return a file identical to the original
      if the parameters used to store and retrieve a file are the same.

   3.2.  ESTABLISHING DATA CONNECTIONS

      The mechanics of transferring data consists of setting up the data
      connection to the appropriate ports and choosing the parameters
      for transfer.  Both the user and the server-DTPs have a default
      data port.  The user-process default data port is the same as the
      control connection port (i.e., U).  The server-process default
      data port is the port adjacent to the control connection port
      (i.e., L-1).

      The transfer byte size is 8-bit bytes.  This byte size is relevant
      only for the actual transfer of the data; it has no bearing on
      representation of the data within a host's file system.

      The passive data transfer process (this may be a user-DTP or a
      second server-DTP) shall "listen" on the data port prior to
      sending a transfer request command.  The FTP request command
      determines the direction of the data transfer.  The server, upon
      receiving the transfer request, will initiate the data connection
      to the port.  When the connection is established, the data
      transfer begins between DTP's, and the server-PI sends a
      confirming reply to the user-PI.

      Every FTP implementation must support the use of the default data
      ports, and only the USER-PI can initiate a change to non-default
      ports.

      It is possible for the user to specify an alternate data port by
      use of the PORT command.  The user may want a file dumped on a TAC
      line printer or retrieved from a third party host.  In the latter
      case, the user-PI sets up control connections with both
      server-PI's.  One server is then told (by an FTP command) to
      "listen" for a connection which the other will initiate.  The
      user-PI sends one server-PI a PORT command indicating the data
      port of the other.  Finally, both are sent the appropriate
      transfer commands.  The exact sequence of commands and replies
      sent between the user-controller and the servers is defined in the
      Section on FTP Replies.

      In general, it is the server's responsibility to maintain the data
      connection--to initiate it and to close it.  The exception to this




Postel & Reynolds                                              [Page 18]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      is when the user-DTP is sending the data in a transfer mode that
      requires the connection to be closed to indicate EOF.  The server
      MUST close the data connection under the following conditions:

         1. The server has completed sending data in a transfer mode
            that requires a close to indicate EOF.

         2. The server receives an ABORT command from the user.

         3. The port specification is changed by a command from the
            user.

         4. The control connection is closed legally or otherwise.

         5. An irrecoverable error condition occurs.

      Otherwise the close is a server option, the exercise of which the
      server must indicate to the user-process by either a 250 or 226
      reply only.

   3.3.  DATA CONNECTION MANAGEMENT

      Default Data Connection Ports:  All FTP implementations must
      support use of the default data connection ports, and only the
      User-PI may initiate the use of non-default ports.

      Negotiating Non-Default Data Ports:   The User-PI may specify a
      non-default user side data port with the PORT command.  The
      User-PI may request the server side to identify a non-default
      server side data port with the PASV command.  Since a connection
      is defined by the pair of addresses, either of these actions is
      enough to get a different data connection, still it is permitted
      to do both commands to use new ports on both ends of the data
      connection.

      Reuse of the Data Connection:  When using the stream mode of data
      transfer the end of the file must be indicated by closing the
      connection.  This causes a problem if multiple files are to be
      transfered in the session, due to need for TCP to hold the
      connection record for a time out period to guarantee the reliable
      communication.  Thus the connection can not be reopened at once.

         There are two solutions to this problem.  The first is to
         negotiate a non-default port.  The second is to use another
         transfer mode.

         A comment on transfer modes.  The stream transfer mode is


Postel & Reynolds                                              [Page 19]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         inherently unreliable, since one can not determine if the
         connection closed prematurely or not.  The other transfer modes
         (Block, Compressed) do not close the connection to indicate the
         end of file.  They have enough FTP encoding that the data
         connection can be parsed to determine the end of the file.
         Thus using these modes one can leave the data connection open
         for multiple file transfers.

   3.4.  TRANSMISSION MODES

      The next consideration in transferring data is choosing the
      appropriate transmission mode.  There are three modes: one which
      formats the data and allows for restart procedures; one which also
      compresses the data for efficient transfer; and one which passes
      the data with little or no processing.  In this last case the mode
      interacts with the structure attribute to determine the type of
      processing.  In the compressed mode, the representation type
      determines the filler byte.

      All data transfers must be completed with an end-of-file (EOF)
      which may be explicitly stated or implied by the closing of the
      data connection.  For files with record structure, all the
      end-of-record markers (EOR) are explicit, including the final one.
      For files transmitted in page structure a "last-page" page type is
      used.

      NOTE:  In the rest of this section, byte means "transfer byte"
      except where explicitly stated otherwise.

      For the purpose of standardized transfer, the sending host will
      translate its internal end of line or end of record denotation
      into the representation prescribed by the transfer mode and file
      structure, and the receiving host will perform the inverse
      translation to its internal denotation.  An IBM Mainframe record
      count field may not be recognized at another host, so the
      end-of-record information may be transferred as a two byte control
      code in Stream mode or as a flagged bit in a Block or Compressed
      mode descriptor.  End-of-line in an ASCII or EBCDIC file with no
      record structure should be indicated by <CRLF> or <NL>,
      respectively.  Since these transformations imply extra work for
      some systems, identical systems transferring non-record structured
      text files might wish to use a binary representation and stream
      mode for the transfer.






Postel & Reynolds                                              [Page 20]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      The following transmission modes are defined in FTP:

      3.4.1.  STREAM MODE

         The data is transmitted as a stream of bytes.  There is no
         restriction on the representation type used; record structures
         are allowed.

         In a record structured file EOR and EOF will each be indicated
         by a two-byte control code.  The first byte of the control code
         will be all ones, the escape character.  The second byte will
         have the low order bit on and zeros elsewhere for EOR and the
         second low order bit on for EOF; that is, the byte will have
         value 1 for EOR and value 2 for EOF.  EOR and EOF may be
         indicated together on the last byte transmitted by turning both
         low order bits on (i.e., the value 3).  If a byte of all ones
         was intended to be sent as data, it should be repeated in the
         second byte of the control code.

         If the structure is a file structure, the EOF is indicated by
         the sending host closing the data connection and all bytes are
         data bytes.

      3.4.2.  BLOCK MODE

         The file is transmitted as a series of data blocks preceded by
         one or more header bytes.  The header bytes contain a count
         field, and descriptor code.  The count field indicates the
         total length of the data block in bytes, thus marking the
         beginning of the next data block (there are no filler bits).
         The descriptor code defines:  last block in the file (EOF) last
         block in the record (EOR), restart marker (see the Section on
         Error Recovery and Restart) or suspect data (i.e., the data
         being transferred is suspected of errors and is not reliable).
         This last code is NOT intended for error control within FTP.
         It is motivated by the desire of sites exchanging certain types
         of data (e.g., seismic or weather data) to send and receive all
         the data despite local errors (such as "magnetic tape read
         errors"), but to indicate in the transmission that certain
         portions are suspect).  Record structures are allowed in this
         mode, and any representation type may be used.

         The header consists of the three bytes.  Of the 24 bits of
         header information, the 16 low order bits shall represent byte
         count, and the 8 high order bits shall represent descriptor
         codes as shown below.



Postel & Reynolds                                              [Page 21]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         Block Header

            +----------------+----------------+----------------+
            | Descriptor     |    Byte Count                   |
            |         8 bits |                      16 bits    |
            +----------------+----------------+----------------+
            

         The descriptor codes are indicated by bit flags in the
         descriptor byte.  Four codes have been assigned, where each
         code number is the decimal value of the corresponding bit in
         the byte.

            Code     Meaning
            
             128     End of data block is EOR
              64     End of data block is EOF
              32     Suspected errors in data block
              16     Data block is a restart marker

         With this encoding, more than one descriptor coded condition
         may exist for a particular block.  As many bits as necessary
         may be flagged.

         The restart marker is embedded in the data stream as an
         integral number of 8-bit bytes representing printable
         characters in the language being used over the control
         connection (e.g., default--NVT-ASCII).  <SP> (Space, in the
         appropriate language) must not be used WITHIN a restart marker.

         For example, to transmit a six-character marker, the following
         would be sent:

            +--------+--------+--------+
            |Descrptr|  Byte count     |
            |code= 16|             = 6 |
            +--------+--------+--------+

            +--------+--------+--------+
            | Marker | Marker | Marker |
            | 8 bits | 8 bits | 8 bits |
            +--------+--------+--------+

            +--------+--------+--------+
            | Marker | Marker | Marker |
            | 8 bits | 8 bits | 8 bits |
            +--------+--------+--------+


Postel & Reynolds                                              [Page 22]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      3.4.3.  COMPRESSED MODE

         There are three kinds of information to be sent:  regular data,
         sent in a byte string; compressed data, consisting of
         replications or filler; and control information, sent in a
         two-byte escape sequence.  If n>0 bytes (up to 127) of regular
         data are sent, these n bytes are preceded by a byte with the
         left-most bit set to 0 and the right-most 7 bits containing the
         number n.

         Byte string:

             1       7                8                     8
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+     +-+-+-+-+-+-+-+-+
            |0|       n     | |    d(1)       | ... |      d(n)     |
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+     +-+-+-+-+-+-+-+-+
                                          ^             ^
                                          |---n bytes---|
                                              of data

            String of n data bytes d(1),..., d(n)
            Count n must be positive.

         To compress a string of n replications of the data byte d, the
         following 2 bytes are sent:

         Replicated Byte:

              2       6               8
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
            |1 0|     n     | |       d       |
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+

         A string of n filler bytes can be compressed into a single
         byte, where the filler byte varies with the representation
         type.  If the type is ASCII or EBCDIC the filler byte is <SP>
         (Space, ASCII code 32, EBCDIC code 64).  If the type is Image
         or Local byte the filler is a zero byte.

         Filler String:

              2       6
            +-+-+-+-+-+-+-+-+
            |1 1|     n     |
            +-+-+-+-+-+-+-+-+

         The escape sequence is a double byte, the first of which is the


Postel & Reynolds                                              [Page 23]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         escape byte (all zeros) and the second of which contains
         descriptor codes as defined in Block mode.  The descriptor
         codes have the same meaning as in Block mode and apply to the
         succeeding string of bytes.

         Compressed mode is useful for obtaining increased bandwidth on
         very large network transmissions at a little extra CPU cost.
         It can be most effectively used to reduce the size of printer
         files such as those generated by RJE hosts.

   3.5.  ERROR RECOVERY AND RESTART

      There is no provision for detecting bits lost or scrambled in data
      transfer; this level of error control is handled by the TCP.
      However, a restart procedure is provided to protect users from
      gross system failures (including failures of a host, an
      FTP-process, or the underlying network).

      The restart procedure is defined only for the block and compressed
      modes of data transfer.  It requires the sender of data to insert
      a special marker code in the data stream with some marker
      information.  The marker information has meaning only to the
      sender, but must consist of printable characters in the default or
      negotiated language of the control connection (ASCII or EBCDIC).
      The marker could represent a bit-count, a record-count, or any
      other information by which a system may identify a data
      checkpoint.  The receiver of data, if it implements the restart
      procedure, would then mark the corresponding position of this
      marker in the receiving system, and return this information to the
      user.

      In the event of a system failure, the user can restart the data
      transfer by identifying the marker point with the FTP restart
      procedure.  The following example illustrates the use of the
      restart procedure.

      The sender of the data inserts an appropriate marker block in the
      data stream at a convenient point.  The receiving host marks the
      corresponding data point in its file system and conveys the last
      known sender and receiver marker information to the user, either
      directly or over the control connection in a 110 reply (depending
      on who is the sender).  In the event of a system failure, the user
      or controller process restarts the server at the last server
      marker by sending a restart command with server's marker code as
      its argument.  The restart command is transmitted over the control




Postel & Reynolds                                              [Page 24]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      connection and is immediately followed by the command (such as
      RETR, STOR or LIST) which was being executed when the system
      failure occurred.

4.  FILE TRANSFER FUNCTIONS

   The communication channel from the user-PI to the server-PI is
   established as a TCP connection from the user to the standard server
   port.  The user protocol interpreter is responsible for sending FTP
   commands and interpreting the replies received; the server-PI
   interprets commands, sends replies and directs its DTP to set up the
   data connection and transfer the data.  If the second party to the
   data transfer (the passive transfer process) is the user-DTP, then it
   is governed through the internal protocol of the user-FTP host; if it
   is a second server-DTP, then it is governed by its PI on command from
   the user-PI.  The FTP replies are discussed in the next section.  In
   the description of a few of the commands in this section, it is
   helpful to be explicit about the possible replies.

   4.1.  FTP COMMANDS

      4.1.1.  ACCESS CONTROL COMMANDS

         The following commands specify access control identifiers
         (command codes are shown in parentheses).

         USER NAME (USER)

            The argument field is a Telnet string identifying the user.
            The user identification is that which is required by the
            server for access to its file system.  This command will
            normally be the first command transmitted by the user after
            the control connections are made (some servers may require
            this).  Additional identification information in the form of
            a password and/or an account command may also be required by
            some servers.  Servers may allow a new USER command to be
            entered at any point in order to change the access control
            and/or accounting information.  This has the effect of
            flushing any user, password, and account information already
            supplied and beginning the login sequence again.  All
            transfer parameters are unchanged and any file transfer in
            progress is completed under the old access control
            parameters.






Postel & Reynolds                                              [Page 25]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         PASSWORD (PASS)

            The argument field is a Telnet string specifying the user's
            password.  This command must be immediately preceded by the
            user name command, and, for some sites, completes the user's
            identification for access control.  Since password
            information is quite sensitive, it is desirable in general
            to "mask" it or suppress typeout.  It appears that the
            server has no foolproof way to achieve this.  It is
            therefore the responsibility of the user-FTP process to hide
            the sensitive password information.

         ACCOUNT (ACCT)

            The argument field is a Telnet string identifying the user's
            account.  The command is not necessarily related to the USER
            command, as some sites may require an account for login and
            others only for specific access, such as storing files.  In
            the latter case the command may arrive at any time.

            There are reply codes to differentiate these cases for the
            automation: when account information is required for login,
            the response to a successful PASSword command is reply code
            332.  On the other hand, if account information is NOT
            required for login, the reply to a successful PASSword
            command is 230; and if the account information is needed for
            a command issued later in the dialogue, the server should
            return a 332 or 532 reply depending on whether it stores
            (pending receipt of the ACCounT command) or discards the
            command, respectively.

         CHANGE WORKING DIRECTORY (CWD)

            This command allows the user to work with a different
            directory or dataset for file storage or retrieval without
            altering his login or accounting information.  Transfer
            parameters are similarly unchanged.  The argument is a
            pathname specifying a directory or other system dependent
            file group designator.

         CHANGE TO PARENT DIRECTORY (CDUP)

            This command is a special case of CWD, and is included to
            simplify the implementation of programs for transferring
            directory trees between operating systems having different




Postel & Reynolds                                              [Page 26]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            syntaxes for naming the parent directory.  The reply codes
            shall be identical to the reply codes of CWD.  See
            Appendix II for further details.

         STRUCTURE MOUNT (SMNT)

            This command allows the user to mount a different file
            system data structure without altering his login or
            accounting information.  Transfer parameters are similarly
            unchanged.  The argument is a pathname specifying a
            directory or other system dependent file group designator.

         REINITIALIZE (REIN)

            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.  This is identical
            to the state in which a user finds himself immediately after
            the control connection is opened.  A USER command may be
            expected to follow.

         LOGOUT (QUIT)

            This command terminates a USER 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.
            If the user-process is transferring files for several USERs
            but does not wish to close and then reopen connections for
            each, then the REIN command should be used instead of QUIT.

            An unexpected close on the control connection will cause the
            server to take the effective action of an abort (ABOR) and a
            logout (QUIT).

      4.1.2.  TRANSFER PARAMETER COMMANDS

         All data transfer parameters have default values, and the
         commands specifying data transfer parameters are required only
         if the default parameter values are to be changed.  The default
         value is the last specified value, or if no value has been
         specified, the standard default value is as stated here.  This
         implies that the server must "remember" the applicable default
         values.  The commands may be in any order except that they must
         precede the FTP service request.  The following commands
         specify data transfer parameters:


Postel & Reynolds                                              [Page 27]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         DATA PORT (PORT)

            The argument is a HOST-PORT specification for the data port
            to be used in data connection.  There are defaults for both
            the user and server data ports, and under normal
            circumstances this command and its reply are not needed.  If
            this command is used, the argument is the concatenation of a
            32-bit internet host address and a 16-bit TCP port address.
            This address information is broken into 8-bit fields and the
            value of each field is transmitted as a decimal number (in
            character string representation).  The fields are separated
            by commas.  A port command would be:

               PORT h1,h2,h3,h4,p1,p2

            where h1 is the high order 8 bits of the internet host
            address.

         PASSIVE (PASV)

            This command requests the server-DTP to "listen" on a data
            port (which is not its default data port) and to wait for a
            connection rather than initiate one upon receipt of a
            transfer command.  The response to this command includes the
            host and port address this server is listening on.

         REPRESENTATION TYPE (TYPE)

            The argument specifies the representation type as described
            in the Section on Data Representation and Storage.  Several
            types take a second parameter.  The first parameter is
            denoted by a single Telnet character, as is the second
            Format parameter for ASCII and EBCDIC; the second parameter
            for local byte is a decimal integer to indicate Bytesize.
            The parameters are separated by a <SP> (Space, ASCII code
            32).

            The following codes are assigned for type:

                         \    /
               A - ASCII |    | N - Non-print
                         |-><-| T - Telnet format effectors
               E - EBCDIC|    | C - Carriage Control (ASA)
                         /    \
               I - Image
               
               L <byte size> - Local byte Byte size


Postel & Reynolds                                              [Page 28]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            The default representation type is ASCII Non-print.  If the
            Format parameter is changed, and later just the first
            argument is changed, Format then returns to the Non-print
            default.

         FILE STRUCTURE (STRU)

            The argument is a single Telnet character code specifying
            file structure described in the Section on Data
            Representation and Storage.

            The following codes are assigned for structure:

               F - File (no record structure)
               R - Record structure
               P - Page structure

            The default structure is File.

         TRANSFER MODE (MODE)

            The argument is a single Telnet character code specifying
            the data transfer modes described in the Section on
            Transmission Modes.

            The following codes are assigned for transfer modes:

               S - Stream
               B - Block
               C - Compressed

            The default transfer mode is Stream.

      4.1.3.  FTP SERVICE COMMANDS

         The FTP service commands define the file transfer or the file
         system function requested by the user.  The argument of an FTP
         service command will normally be a pathname.  The syntax of
         pathnames must conform to server site conventions (with
         standard defaults applicable), and the language conventions of
         the control connection.  The suggested default handling is to
         use the last specified device, directory or file name, or the
         standard default defined for local users.  The commands may be
         in any order except that a "rename from" command must be
         followed by a "rename to" command and the restart command must
         be followed by the interrupted service command (e.g., STOR or
         RETR).  The data, when transferred in response to FTP service


Postel & Reynolds                                              [Page 29]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         commands, shall always be sent over the data connection, except
         for certain informative replies.  The following commands
         specify FTP service requests:

         RETRIEVE (RETR)

            This command causes the server-DTP to transfer a copy of the
            file, specified in the pathname, to the server- or user-DTP
            at the other end of the data connection.  The status and
            contents of the file at the server site shall be unaffected.

         STORE (STOR)

            This command causes the server-DTP to accept the data
            transferred via the data connection and to store the data as
            a file at the server site.  If the file specified in the
            pathname 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 specified in the
            pathname does not already exist.

         STORE UNIQUE (STOU)

            This command behaves like STOR except that the resultant
            file is to be created in the current directory under a name
            unique to that directory.  The 250 Transfer Started response
            must include the name generated.

         APPEND (with create) (APPE)

            This command causes the server-DTP to accept the data
            transferred via the data connection and to store the data in
            a file at the server site.  If the file specified in the
            pathname 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.

         ALLOCATE (ALLO)

            This command may be required by some servers to reserve
            sufficient storage to accommodate the new file to be
            transferred.  The argument shall be a decimal integer
            representing the number of bytes (using the logical byte
            size) of storage to be reserved for the file.  For files
            sent with record or page structure a maximum record or page
            size (in logical bytes) might also be necessary; this is
            indicated by a decimal integer in a second argument field of


Postel & Reynolds                                              [Page 30]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            the command.  This second argument is optional, but when
            present should be separated from the first by the three
            Telnet characters <SP> R <SP>.  This command shall be
            followed by a STORe or APPEnd command.  The ALLO command
            should be treated as a NOOP (no operation) by those servers
            which do not require that the maximum size of the file be
            declared beforehand, and those servers interested in only
            the maximum record or page size should accept a dummy value
            in the first argument and ignore it.

         RESTART (REST)

            The argument field represents the server marker at which
            file transfer is to be restarted.  This command does not
            cause file transfer but skips over the file to the specified
            data checkpoint.  This command shall be immediately followed
            by the appropriate FTP service command which shall cause
            file transfer to resume.

         RENAME FROM (RNFR)

            This command specifies the old pathname of the file which is
            to be renamed.  This command must be immediately followed by
            a "rename to" command specifying the new file pathname.

         RENAME TO (RNTO)

            This command specifies the new pathname of the file
            specified in the immediately preceding "rename from"
            command.  Together the two commands cause a file to be
            renamed.

         ABORT (ABOR)

            This command tells the server to abort the previous FTP
            service command and any associated transfer of data.  The
            abort command may require "special action", as discussed in
            the Section on FTP Commands, to force recognition by the
            server.  No action is to be taken if the previous command
            has been completed (including data transfer).  The control
            connection is not to be closed by the server, but the data
            connection must be closed.

            There are two cases for the server upon receipt of this
            command: (1) the FTP service command was already completed,
            or (2) the FTP service command is still in progress.



Postel & Reynolds                                              [Page 31]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               In the first case, the server closes the data connection
               (if it is open) and responds with a 226 reply, indicating
               that the abort command was successfully processed.

               In the second case, the server aborts the FTP service in
               progress and closes the data connection, returning a 426
               reply to indicate that the service request terminated
               abnormally.  The server then sends a 226 reply,
               indicating that the abort command was successfully
               processed.

         DELETE (DELE)

            This command causes the file specified in the pathname to be
            deleted at the server site.  If an extra level of protection
            is desired (such as the query, "Do you really wish to
            delete?"), it should be provided by the user-FTP process.

         REMOVE DIRECTORY (RMD)

            This command causes the directory specified in the pathname
            to be removed as a directory (if the pathname is absolute)
            or as a subdirectory of the current working directory (if
            the pathname is relative).  See Appendix II.

         MAKE DIRECTORY (MKD)

            This command causes the directory specified in the pathname
            to be created as a directory (if the pathname is absolute)
            or as a subdirectory of the current working directory (if
            the pathname is relative).  See Appendix II.

         PRINT WORKING DIRECTORY (PWD)

            This command causes the name of the current working
            directory to be returned in the reply.  See Appendix II.

         LIST (LIST)

            This command causes a list to be sent from the server to the
            passive DTP.  If the pathname specifies a directory or other
            group of files, the server should transfer a list of files
            in the specified directory.  If the pathname 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.  The data transfer is over the data
            connection in type ASCII or type EBCDIC.  (The user must


Postel & Reynolds                                              [Page 32]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            ensure that the TYPE is appropriately ASCII or EBCDIC).
            Since the information on a file may vary widely from system
            to system, this information may be hard to use automatically
            in a program, but may be quite useful to a human user.

         NAME LIST (NLST)

            This command causes a directory listing to be sent from
            server to user site.  The pathname should specify a
            directory or other system-specific file group descriptor; a
            null argument implies the current directory.  The server
            will return a stream of names of files and no other
            information.  The data will be transferred in ASCII or
            EBCDIC type over the data connection as valid pathname
            strings separated by <CRLF> or <NL>.  (Again the user must
            ensure that the TYPE is correct.)  This command is intended
            to return information that can be used by a program to
            further process the files automatically.  For example, in
            the implementation of a "multiple get" function.

         SITE PARAMETERS (SITE)

            This command is used by the server to provide services
            specific to his system that are essential to file transfer
            but not sufficiently universal to be included as commands in
            the protocol.  The nature of these services and the
            specification of their syntax can be stated in a reply to
            the HELP SITE command.

         SYSTEM (SYST)

            This command is used to find out the type of operating
            system at the server.  The reply shall have as its first
            word one of the system names listed in the current version
            of the Assigned Numbers document [4].

         STATUS (STAT)

            This command shall cause a status response to be sent over
            the control connection in the form of a reply.  The command
            may be sent during a file transfer (along with the Telnet IP
            and Synch signals--see the Section on FTP Commands) in which
            case the server will respond with the status of the
            operation in progress, or it may be sent between file
            transfers.  In the latter case, the command may have an
            argument field.  If the argument is a pathname, the command
            is analogous to the "list" command except that data shall be


Postel & Reynolds                                              [Page 33]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            transferred over the control connection.  If a partial
            pathname is given, the server may respond with a list of
            file names or attributes associated with that specification.
            If no argument is given, the server should return general
            status information about the server FTP process.  This
            should include current values of all transfer parameters and
            the status of connections.

         HELP (HELP)

            This command shall cause the server to send helpful
            information regarding its implementation status over the
            control connection to the user.  The command may take an
            argument (e.g., any command name) and return more specific
            information as a response.  The reply is type 211 or 214.
            It is suggested that HELP be allowed before entering a USER
            command. The server may use this reply to specify
            site-dependent parameters, e.g., in response to HELP SITE.

         NOOP (NOOP)

            This command does not affect any parameters or previously
            entered commands. It specifies no action other than that the
            server send an OK reply.

   The File Transfer Protocol follows the specifications of the Telnet
   protocol for all communications over the control connection.  Since
   the language used for Telnet communication may be a negotiated
   option, all references in the next two sections will be to the
   "Telnet language" and the corresponding "Telnet end-of-line code".
   Currently, one may take these to mean NVT-ASCII and <CRLF>.  No other
   specifications of the Telnet protocol will be cited.

   FTP commands are "Telnet strings" terminated by the "Telnet end of
   line code".  The command codes themselves are alphabetic characters
   terminated by the character <SP> (Space) if parameters follow and
   Telnet-EOL otherwise.  The command codes and the semantics of
   commands are described in this section; the detailed syntax of
   commands is specified in the Section on Commands, the reply sequences
   are discussed in the Section on Sequencing of Commands and Replies,
   and scenarios illustrating the use of commands are provided in the
   Section on Typical FTP Scenarios.

   FTP commands may be partitioned as those specifying access-control
   identifiers, data transfer parameters, or FTP service requests.
   Certain commands (such as ABOR, STAT, QUIT) may be sent over the
   control connection while a data transfer is in progress.  Some


Postel & Reynolds                                              [Page 34]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   servers may not be able to monitor the control and data connections
   simultaneously, in which case some special action will be necessary
   to get the server's attention.  The following ordered format is
   tentatively recommended:

      1. User system inserts the Telnet "Interrupt Process" (IP) signal
      in the Telnet stream.

      2. User system sends the Telnet "Synch" signal.

      3. User system inserts the command (e.g., ABOR) in the Telnet
      stream.

      4. Server PI, after receiving "IP", scans the Telnet stream for
      EXACTLY ONE FTP command.

   (For other servers this may not be necessary but the actions listed
   above should have no unusual effect.)

   4.2.  FTP REPLIES

      Replies to File Transfer Protocol commands are devised to ensure
      the synchronization of requests and actions in the process of file
      transfer, and to guarantee that the user process always knows the
      state of the Server.  Every command must generate at least one
      reply, although there may be more than one; in the latter case,
      the multiple replies must be easily distinguished.  In addition,
      some commands occur in sequential groups, such as USER, PASS and
      ACCT, or RNFR and RNTO.  The replies show the existence of an
      intermediate state if all preceding commands have been successful.
      A failure at any point in the sequence necessitates the repetition
      of the entire sequence from the beginning.

         The details of the command-reply sequence are made explicit in
         a set of state diagrams below.

      An FTP reply consists of a three digit number (transmitted as
      three alphanumeric characters) followed by some text.  The number
      is intended for use by automata to determine what state to enter
      next; the text is intended for the human user.  It is intended
      that the three digits contain enough encoded information that the
      user-process (the User-PI) will not need to examine the text and
      may either discard it or pass it on to the user, as appropriate.
      In particular, the text may be server-dependent, so there are
      likely to be varying texts for each reply code.

      A reply is defined to contain the 3-digit code, followed by Space


Postel & Reynolds                                              [Page 35]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      <SP>, followed by one line of text (where some maximum line length
      has been specified), and terminated by the Telnet end-of-line
      code.  There will be cases however, where the text is longer than
      a single line.  In these cases the complete text must be bracketed
      so the User-process knows when it may stop reading the reply (i.e.
      stop processing input on the control connection) and go do other
      things.  This requires a special format on the first line to
      indicate that more than one line is coming, and another on the
      last line to designate it as the last.  At least one of these must
      contain the appropriate reply code to indicate the state of the
      transaction.  To satisfy all factions, it was decided that both
      the first and last line codes should be the same.

         Thus the format for multi-line replies is that the first line
         will begin with the exact required reply code, followed
         immediately by a Hyphen, "-" (also known as Minus), followed by
         text.  The last line will begin with the same code, followed
         immediately by Space <SP>, optionally some text, and the Telnet
         end-of-line code.

            For example:
                                123-First line
                                Second line
                                  234 A line beginning with numbers
                                123 The last line

         The user-process then simply needs to search for the second
         occurrence of the same reply code, followed by <SP> (Space), at
         the beginning of a line, and ignore all intermediary lines.  If
         an intermediary line begins with a 3-digit number, the Server
         must pad the front  to avoid confusion.

            This scheme allows standard system routines to be used for
            reply information (such as for the STAT reply), with
            "artificial" first and last lines tacked on.  In rare cases
            where these routines are able to generate three digits and a
            Space at the beginning of any line, the beginning of each
            text line should be offset by some neutral text, like Space.

         This scheme assumes that multi-line replies may not be nested.

      The three digits of the reply each have a special significance.
      This is intended to allow a range of very simple to very
      sophisticated responses by the user-process.  The first digit
      denotes whether the response is good, bad or incomplete.
      (Referring to the state diagram), an unsophisticated user-process
      will be able to determine its next action (proceed as planned,


Postel & Reynolds                                              [Page 36]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      redo, retrench, etc.) by simply examining this first digit.  A
      user-process that wants to know approximately what kind of error
      occurred (e.g. file system error, command syntax error) may
      examine the second digit, reserving the third digit for the finest
      gradation of information (e.g., RNTO command without a preceding
      RNFR).

         There are five values for the first digit of the reply code:

            1yz   Positive Preliminary reply

               The requested action is being initiated; expect another
               reply before proceeding with a new command.  (The
               user-process sending another command before the
               completion reply would be in violation of protocol; but
               server-FTP processes should queue any commands that
               arrive while a preceding command is in progress.)  This
               type of reply can be used to indicate that the command
               was accepted and the user-process may now pay attention
               to the data connections, for implementations where
               simultaneous monitoring is difficult.  The server-FTP
               process may send at most, one 1yz reply per command.

            2yz   Positive Completion reply

               The requested action has been successfully completed.  A
               new request may be initiated.

            3yz   Positive Intermediate reply

               The command has been accepted, but the requested action
               is being held in abeyance, pending receipt of further
               information.  The user should send another command
               specifying this information.  This reply is used in
               command sequence groups.

            4yz   Transient Negative Completion reply

               The command was not accepted and the requested action did
               not take place, but the error condition is temporary and
               the action may be requested again.  The user should
               return to the beginning of the command sequence, if any.
               It is difficult to assign a meaning to "transient",
               particularly when two distinct sites (Server- and
               User-processes) have to agree on the interpretation.
               Each reply in the 4yz category might have a slightly
               different time value, but the intent is that the


Postel & Reynolds                                              [Page 37]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               user-process is encouraged to try again.  A rule of thumb
               in determining if a reply fits into the 4yz or the 5yz
               (Permanent Negative) category is that replies are 4yz if
               the commands can be repeated without any change in
               command form or in properties of the User or Server
               (e.g., the command is spelled the same with the same
               arguments used; the user does not change his file access
               or user name; the server does not put up a new
               implementation.)

            5yz   Permanent Negative Completion reply

               The command was not accepted and the requested action did
               not take place.  The User-process is discouraged from
               repeating the exact request (in the same sequence).  Even
               some "permanent" error conditions can be corrected, so
               the human user may want to direct his User-process to
               reinitiate the command sequence by direct action at some
               point in the future (e.g., after the spelling has been
               changed, or the user has altered his directory status.)

         The following function groupings are encoded in the second
         digit:

            x0z   Syntax - These replies refer to syntax errors,
                  syntactically correct commands that don't fit any
                  functional category, unimplemented or superfluous
                  commands.

            x1z   Information -  These are replies to requests for
                  information, such as status or help.

            x2z   Connections - Replies referring to the control and
                  data connections.

            x3z   Authentication and accounting - Replies for the login
                  process and accounting procedures.

            x4z   Unspecified as yet.

            x5z   File system - These replies indicate the status of the
                  Server file system vis-a-vis the requested transfer or
                  other file system action.

         The third digit gives a finer gradation of meaning in each of
         the function categories, specified by the second digit.  The
         list of replies below will illustrate this.  Note that the text


Postel & Reynolds                                              [Page 38]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         associated with each reply is recommended, rather than
         mandatory, and may even change according to the command with
         which it is associated.  The reply codes, on the other hand,
         must strictly follow the specifications in the last section;
         that is, Server implementations should not invent new codes for
         situations that are only slightly different from the ones
         described here, but rather should adapt codes already defined.

            A command such as TYPE or ALLO whose successful execution
            does not offer the user-process any new information will
            cause a 200 reply to be returned.  If the command is not
            implemented by a particular Server-FTP process because it
            has no relevance to that computer system, for example ALLO
            at a TOPS20 site, a Positive Completion reply is still
            desired so that the simple User-process knows it can proceed
            with its course of action.  A 202 reply is used in this case
            with, for example, the reply text:  "No storage allocation
            necessary."  If, on the other hand, the command requests a
            non-site-specific action and is unimplemented, the response
            is 502.  A refinement of that is the 504 reply for a command
            that is implemented, but that requests an unimplemented
            parameter.

      4.2.1  Reply Codes by Function Groups

         200 Command okay.
         500 Syntax error, command unrecognized.
             This may include errors such as command line too long.
         501 Syntax error in parameters or arguments.
         202 Command not implemented, superfluous at this site.
         502 Command not implemented.
         503 Bad sequence of commands.
         504 Command not implemented for that parameter.
          















Postel & Reynolds                                              [Page 39]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         110 Restart marker reply.
             In this case, the text is exact and not left to the
             particular implementation; it must read:
                  MARK yyyy = mmmm
             Where yyyy is User-process data stream marker, and mmmm
             server's equivalent marker (note the spaces between markers
             and "=").
         211 System status, or system help reply.
         212 Directory status.
         213 File status.
         214 Help message.
             On how to use the server or the meaning of a particular
             non-standard command.  This reply is useful only to the
             human user.
         215 NAME system type.
             Where NAME is an official system name from the list in the
             Assigned Numbers document.
          
         120 Service ready in nnn minutes.
         220 Service ready for new user.
         221 Service closing control connection.
             Logged out if appropriate.
         421 Service not available, closing control connection.
             This may be a reply to any command if the service knows it
             must shut down.
         125 Data connection already open; transfer starting.
         225 Data connection open; no transfer in progress.
         425 Can't open data connection.
         226 Closing data connection.
             Requested file action successful (for example, file
             transfer or file abort).
         426 Connection closed; transfer aborted.
         227 Entering Passive Mode (h1,h2,h3,h4,p1,p2).
          
         230 User logged in, proceed.
         530 Not logged in.
         331 User name okay, need password.
         332 Need account for login.
         532 Need account for storing files.
          









Postel & Reynolds                                              [Page 40]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         150 File status okay; about to open data connection.
         250 Requested file action okay, completed.
         257 "PATHNAME" created.
         350 Requested file action pending further information.
         450 Requested file action not taken.
             File unavailable (e.g., file busy).
         550 Requested action not taken.
             File unavailable (e.g., file not found, no access).
         451 Requested action aborted. Local error in processing.
         551 Requested action aborted. Page type unknown.
         452 Requested action not taken.
             Insufficient storage space in system.
         552 Requested file action aborted.
             Exceeded storage allocation (for current directory or
             dataset).
         553 Requested action not taken.
             File name not allowed.
         

      4.2.2 Numeric  Order List of Reply Codes

         110 Restart marker reply.
             In this case, the text is exact and not left to the
             particular implementation; it must read:
                  MARK yyyy = mmmm
             Where yyyy is User-process data stream marker, and mmmm
             server's equivalent marker (note the spaces between markers
             and "=").
         120 Service ready in nnn minutes.
         125 Data connection already open; transfer starting.
         150 File status okay; about to open data connection.
          

















Postel & Reynolds                                              [Page 41]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         200 Command okay.
         202 Command not implemented, superfluous at this site.
         211 System status, or system help reply.
         212 Directory status.
         213 File status.
         214 Help message.
             On how to use the server or the meaning of a particular
             non-standard command.  This reply is useful only to the
             human user.
         215 NAME system type.
             Where NAME is an official system name from the list in the
             Assigned Numbers document.
         220 Service ready for new user.
         221 Service closing control connection.
             Logged out if appropriate.
         225 Data connection open; no transfer in progress.
         226 Closing data connection.
             Requested file action successful (for example, file
             transfer or file abort).
         227 Entering Passive Mode (h1,h2,h3,h4,p1,p2).
         230 User logged in, proceed.
         250 Requested file action okay, completed.
         257 "PATHNAME" created.
          
         331 User name okay, need password.
         332 Need account for login.
         350 Requested file action pending further information.
          
         421 Service not available, closing control connection.
             This may be a reply to any command if the service knows it
             must shut down.
         425 Can't open data connection.
         426 Connection closed; transfer aborted.
         450 Requested file action not taken.
             File unavailable (e.g., file busy).
         451 Requested action aborted: local error in processing.
         452 Requested action not taken.
             Insufficient storage space in system.
          










Postel & Reynolds                                              [Page 42]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         500 Syntax error, command unrecognized.
             This may include errors such as command line too long.
         501 Syntax error in parameters or arguments.
         502 Command not implemented.
         503 Bad sequence of commands.
         504 Command not implemented for that parameter.
         530 Not logged in.
         532 Need account for storing files.
         550 Requested action not taken.
             File unavailable (e.g., file not found, no access).
         551 Requested action aborted: page type unknown.
         552 Requested file action aborted.
             Exceeded storage allocation (for current directory or
             dataset).
         553 Requested action not taken.
             File name not allowed.
         

5.  DECLARATIVE SPECIFICATIONS

   5.1.  MINIMUM IMPLEMENTATION

      In order to make FTP workable without needless error messages, the
      following minimum implementation is required for all servers:

         TYPE - ASCII Non-print
         MODE - Stream
         STRUCTURE - File, Record
         COMMANDS - USER, QUIT, PORT,
                    TYPE, MODE, STRU,
                      for the default values
                    RETR, STOR,
                    NOOP.

      The default values for transfer parameters are:

         TYPE - ASCII Non-print
         MODE - Stream
         STRU - File

      All hosts must accept the above as the standard defaults.








Postel & Reynolds                                              [Page 43]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   5.2.  CONNECTIONS

      The server protocol interpreter shall "listen" on Port L.  The
      user or user protocol interpreter shall initiate the full-duplex
      control connection.  Server- and user- processes should follow the
      conventions of the Telnet protocol as specified in the
      ARPA-Internet Protocol Handbook [1].  Servers are under no
      obligation to provide for editing of command lines and may require
      that it be done in the user host.  The control connection shall be
      closed by the server at the user's request after all transfers and
      replies are completed.

      The user-DTP must "listen" on the specified data port; this may be
      the default user port (U) or a port specified in the PORT command.
      The server shall initiate the data connection from his own default
      data port (L-1) using the specified user data port.  The direction
      of the transfer and the port used will be determined by the FTP
      service command.

      Note that all FTP implementation must support data transfer using
      the default port, and that only the USER-PI may initiate the use
      of non-default ports.

      When data is to be transferred between two servers, A and B (refer
      to Figure 2), the user-PI, C, sets up control connections with
      both server-PI's.  One of the servers, say A, is then sent a PASV
      command telling him to "listen" on his data port rather than
      initiate a connection when he receives a transfer service command.
      When the user-PI receives an acknowledgment to the PASV command,
      which includes the identity of the host and port being listened
      on, the user-PI then sends A's port, a, to B in a PORT command; a
      reply is returned.  The user-PI may then send the corresponding
      service commands to A and B.  Server B initiates the connection
      and the transfer proceeds.  The command-reply sequence is listed
      below where the messages are vertically synchronous but
      horizontally asynchronous:













Postel & Reynolds                                              [Page 44]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         User-PI - Server A                User-PI - Server B
         ------------------                ------------------
         
         C->A : Connect                    C->B : Connect
         C->A : PASV
         A->C : 227 Entering Passive Mode. A1,A2,A3,A4,a1,a2
                                           C->B : PORT A1,A2,A3,A4,a1,a2
                                           B->C : 200 Okay
         C->A : STOR                       C->B : RETR
                    B->A : Connect to HOST-A, PORT-a

                                Figure 3

      The data connection shall be closed by the server under the
      conditions described in the Section on Establishing Data
      Connections.  If the data connection is to be closed following a
      data transfer where closing the connection is not required to
      indicate the end-of-file, the server must do so immediately.
      Waiting until after a new transfer command is not permitted
      because the user-process will have already tested the data
      connection to see if it needs to do a "listen"; (remember that the
      user must "listen" on a closed data port BEFORE sending the
      transfer request).  To prevent a race condition here, the server
      sends a reply (226) after closing the data connection (or if the
      connection is left open, a "file transfer completed" reply (250)
      and the user-PI should wait for one of these replies before
      issuing a new transfer command).

      Any time either the user or server see that the connection is
      being closed by the other side, it should promptly read any
      remaining data queued on the connection and issue the close on its
      own side.

   5.3.  COMMANDS

      The commands are Telnet character strings transmitted over the
      control connections as described in the Section on FTP Commands.
      The command functions and semantics are described in the Section
      on Access Control Commands, Transfer Parameter Commands, FTP
      Service Commands, and Miscellaneous Commands.  The command syntax
      is specified here.

      The commands begin with a command code followed by an argument
      field.  The command codes are four or fewer alphabetic characters.
      Upper and lower case alphabetic characters are to be treated
      identically.  Thus, any of the following may represent the
      retrieve command:


Postel & Reynolds                                              [Page 45]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


                  RETR    Retr    retr    ReTr    rETr

      This also applies to any symbols representing parameter values,
      such as A or a for ASCII TYPE.  The command codes and the argument
      fields are separated by one or more spaces.

      The argument field consists of a variable length character string
      ending with the character sequence <CRLF> (Carriage Return, Line
      Feed) for NVT-ASCII representation; for other negotiated languages
      a different end of line character might be used.  It should be
      noted that the server is to take no action until the end of line
      code is received.

      The syntax is specified below in NVT-ASCII.  All characters in the
      argument field are ASCII characters including any ASCII
      represented decimal integers.  Square brackets denote an optional
      argument field.  If the option is not taken, the appropriate
      default is implied.































Postel & Reynolds                                              [Page 46]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      5.3.1.  FTP COMMANDS

         The following are the FTP commands:

            USER <SP> <username> <CRLF>
            PASS <SP> <password> <CRLF>
            ACCT <SP> <account-information> <CRLF>
            CWD  <SP> <pathname> <CRLF>
            CDUP <CRLF>
            SMNT <SP> <pathname> <CRLF>
            QUIT <CRLF>
            REIN <CRLF>
            PORT <SP> <host-port> <CRLF>
            PASV <CRLF>
            TYPE <SP> <type-code> <CRLF>
            STRU <SP> <structure-code> <CRLF>
            MODE <SP> <mode-code> <CRLF>
            RETR <SP> <pathname> <CRLF>
            STOR <SP> <pathname> <CRLF>
            STOU <CRLF>
            APPE <SP> <pathname> <CRLF>
            ALLO <SP> <decimal-integer>
                [<SP> R <SP> <decimal-integer>] <CRLF>
            REST <SP> <marker> <CRLF>
            RNFR <SP> <pathname> <CRLF>
            RNTO <SP> <pathname> <CRLF>
            ABOR <CRLF>
            DELE <SP> <pathname> <CRLF>
            RMD  <SP> <pathname> <CRLF>
            MKD  <SP> <pathname> <CRLF>
            PWD  <CRLF>
            LIST [<SP> <pathname>] <CRLF>
            NLST [<SP> <pathname>] <CRLF>
            SITE <SP> <string> <CRLF>
            SYST <CRLF>
            STAT [<SP> <pathname>] <CRLF>
            HELP [<SP> <string>] <CRLF>
            NOOP <CRLF>











Postel & Reynolds                                              [Page 47]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      5.3.2.  FTP COMMAND ARGUMENTS

         The syntax of the above argument fields (using BNF notation
         where applicable) is:

            <username> ::= <string>
            <password> ::= <string>
            <account-information> ::= <string>
            <string> ::= <char> | <char><string>
            <char> ::= any of the 128 ASCII characters except <CR> and
            <LF>
            <marker> ::= <pr-string>
            <pr-string> ::= <pr-char> | <pr-char><pr-string>
            <pr-char> ::= printable characters, any
                          ASCII code 33 through 126
            <byte-size> ::= <number>
            <host-port> ::= <host-number>,<port-number>
            <host-number> ::= <number>,<number>,<number>,<number>
            <port-number> ::= <number>,<number>
            <number> ::= any decimal integer 1 through 255
            <form-code> ::= N | T | C
            <type-code> ::= A [<sp> <form-code>]
                          | E [<sp> <form-code>]
                          | I
                          | L <sp> <byte-size>
            <structure-code> ::= F | R | P
            <mode-code> ::= S | B | C
            <pathname> ::= <string>
            <decimal-integer> ::= any decimal integer




















Postel & Reynolds                                              [Page 48]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   5.4.  SEQUENCING OF COMMANDS AND REPLIES

      The communication between the user and server is intended to be an
      alternating dialogue.  As such, the user issues an FTP command and
      the server responds with a prompt primary reply.  The user should
      wait for this initial primary success or failure response before
      sending further commands.

      Certain commands require a second reply for which the user should
      also wait.  These replies may, for example, report on the progress
      or completion of file transfer or the closing of the data
      connection.  They are secondary replies to file transfer commands.

      One important group of informational replies is the connection
      greetings.  Under normal circumstances, a server will send a 220
      reply, "awaiting input", when the connection is completed.  The
      user should wait for this greeting message before sending any
      commands.  If the server is unable to accept input right away, a
      120 "expected delay" reply should be sent immediately and a 220
      reply when ready.  The user will then know not to hang up if there
      is a delay.

      Spontaneous Replies

         Sometimes "the system" spontaneously has a message to be sent
         to a user (usually all users).  For example, "System going down
         in 15 minutes".  There is no provision in FTP for such
         spontaneous information to be sent from the server to the user.
         It is recommended that such information be queued in the
         server-PI and delivered to the user-PI in the next reply
         (possibly making it a multi-line reply).

      The table below lists alternative success and failure replies for
      each command.  These must be strictly adhered to; a server may
      substitute text in the replies, but the meaning and action implied
      by the code numbers and by the specific command reply sequence
      cannot be altered.

      Command-Reply Sequences

         In this section, the command-reply sequence is presented.  Each
         command is listed with its possible replies; command groups are
         listed together.  Preliminary replies are listed first (with
         their succeeding replies indented and under them), then
         positive and negative completion, and finally intermediary




Postel & Reynolds                                              [Page 49]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         replies with the remaining commands from the sequence
         following.  This listing forms the basis for the state
         diagrams, which will be presented separately.

            Connection Establishment
               120
                  220
               220
               421
            Login
               USER
                  230
                  530
                  500, 501, 421
                  331, 332
               PASS
                  230
                  202
                  530
                  500, 501, 503, 421
                  332
               ACCT
                  230
                  202
                  530
                  500, 501, 503, 421
               CWD
                  250
                  500, 501, 502, 421, 530, 550
               CDUP
                  200
                  500, 501, 502, 421, 530, 550
               SMNT
                  202, 250
                  500, 501, 502, 421, 530, 550
            Logout
               REIN
                  120
                     220
                  220
                  421
                  500, 502
               QUIT
                  221
                  500




Postel & Reynolds                                              [Page 50]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            Transfer parameters
               PORT
                  200
                  500, 501, 421, 530
               PASV
                  227
                  500, 501, 502, 421, 530
               MODE
                  200
                  500, 501, 504, 421, 530
               TYPE
                  200
                  500, 501, 504, 421, 530
               STRU
                  200
                  500, 501, 504, 421, 530
            File action commands
               ALLO
                  200
                  202
                  500, 501, 504, 421, 530
               REST
                  500, 501, 502, 421, 530
                  350
               STOR
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451, 551, 552
                  532, 450, 452, 553
                  500, 501, 421, 530
               STOU
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451, 551, 552
                  532, 450, 452, 553
                  500, 501, 421, 530
               RETR
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451
                  450, 550
                  500, 501, 421, 530




Postel & Reynolds                                              [Page 51]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               LIST
                  125, 150
                     226, 250
                     425, 426, 451
                  450
                  500, 501, 502, 421, 530
               NLST
                  125, 150
                     226, 250
                     425, 426, 451
                  450
                  500, 501, 502, 421, 530
               APPE
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451, 551, 552
                  532, 450, 550, 452, 553
                  500, 501, 502, 421, 530
               RNFR
                  450, 550
                  500, 501, 502, 421, 530
                  350
               RNTO
                  250
                  532, 553
                  500, 501, 502, 503, 421, 530
               DELE
                  250
                  450, 550
                  500, 501, 502, 421, 530
               RMD
                  250
                  500, 501, 502, 421, 530, 550
               MKD
                  257
                  500, 501, 502, 421, 530, 550
               PWD
                  257
                  500, 501, 502, 421, 550
               ABOR
                  225, 226
                  500, 501, 502, 421






Postel & Reynolds                                              [Page 52]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            Informational commands
               SYST
                  215
                  500, 501, 502, 421
               STAT
                  211, 212, 213
                  450
                  500, 501, 502, 421, 530
               HELP
                  211, 214
                  500, 501, 502, 421
            Miscellaneous commands
               SITE
                  200
                  202
                  500, 501, 530
               NOOP
                  200
                  500 421






























Postel & Reynolds                                              [Page 53]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


6.  STATE DIAGRAMS

   Here we present state diagrams for a very simple minded FTP
   implementation.  Only the first digit of the reply codes is used.
   There is one state diagram for each group of FTP commands or command
   sequences.

   The command groupings were determined by constructing a model for
   each command then collecting together the commands with structurally
   identical models.

   For each command or command sequence there are three possible
   outcomes: success (S), failure (F), and error (E).  In the state
   diagrams below we use the symbol B for "begin", and the symbol W for
   "wait for reply".

   We first present the diagram that represents the largest group of FTP
   commands:

      
                               1,3    +---+
                          ----------->| E |
                         |            +---+
                         |
      +---+    cmd    +---+    2      +---+
      | B |---------->| W |---------->| S |
      +---+           +---+           +---+
                         |
                         |     4,5    +---+
                          ----------->| F |
                                      +---+
      

      This diagram models the commands:

         ABOR, ALLO, DELE, CWD, CDUP, SMNT, HELP, MODE, NOOP, PASV,
         QUIT, SITE, PORT, SYST, STAT, RMD, MKD, PWD, STRU, and TYPE.












Postel & Reynolds                                              [Page 54]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The other large group of commands is represented by a very similar
   diagram:

      
                               3      +---+
                          ----------->| E |
                         |            +---+
                         |
      +---+    cmd    +---+    2      +---+
      | B |---------->| W |---------->| S |
      +---+       --->+---+           +---+
                 |     | |
                 |     | |     4,5    +---+
                 |  1  |  ----------->| F |
                  -----               +---+
      

      This diagram models the commands:

         APPE, LIST, NLST, REIN, RETR, STOR, and STOU.

   Note that this second model could also be used to represent the first
   group of commands, the only difference being that in the first group
   the 100 series replies are unexpected and therefore treated as error,
   while the second group expects (some may require) 100 series replies.
   Remember that at most, one 100 series reply is allowed per command.

   The remaining diagrams model command sequences, perhaps the simplest
   of these is the rename sequence:

      
      +---+   RNFR    +---+    1,2    +---+
      | B |---------->| W |---------->| E |
      +---+           +---+        -->+---+
                       | |        |
                3      | | 4,5    |
         --------------  ------   |
        |                      |  |   +---+
        |               ------------->| S |
        |              |   1,3 |  |   +---+
        |             2|  --------
        |              | |     |
        V              | |     |
      +---+   RNTO    +---+ 4,5 ----->+---+
      |   |---------->| W |---------->| F |
      +---+           +---+           +---+
      


Postel & Reynolds                                              [Page 55]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The next diagram is a simple model of the Restart command:

      
      +---+   REST    +---+    1,2    +---+
      | B |---------->| W |---------->| E |
      +---+           +---+        -->+---+
                       | |        |
                3      | | 4,5    |
         --------------  ------   |
        |                      |  |   +---+
        |               ------------->| S |
        |              |   3   |  |   +---+
        |             2|  --------
        |              | |     |
        V              | |     |
      +---+   cmd     +---+ 4,5 ----->+---+
      |   |---------->| W |---------->| F |
      +---+        -->+---+           +---+
                  |      |
                  |  1   |
                   ------
      

         Where "cmd" is APPE, STOR, or RETR.

   We note that the above three models are similar.  The Restart differs
   from the Rename two only in the treatment of 100 series replies at
   the second stage, while the second group expects (some may require)
   100 series replies.  Remember that at most, one 100 series reply is
   allowed per command.



















Postel & Reynolds                                              [Page 56]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The most complicated diagram is for the Login sequence:

      
                            1
      +---+   USER    +---+------------->+---+
      | B |---------->| W | 2       ---->| E |
      +---+           +---+------  |  -->+---+
                       | |       | | |
                     3 | | 4,5   | | |
         --------------   -----  | | |
        |                      | | | |
        |                      | | | |
        |                 ---------  |
        |               1|     | |   |
        V                |     | |   |
      +---+   PASS    +---+ 2  |  ------>+---+
      |   |---------->| W |------------->| S |
      +---+           +---+   ---------->+---+
                       | |   | |     |
                     3 | |4,5| |     |
         --------------   --------   |
        |                    | |  |  |
        |                    | |  |  |
        |                 -----------
        |             1,3|   | |  |
        V                |  2| |  |
      +---+   ACCT    +---+--  |   ----->+---+
      |   |---------->| W | 4,5 -------->| F |
      +---+           +---+------------->+---+




















Postel & Reynolds                                              [Page 57]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   Finally, we present a generalized diagram that could be used to model
   the command and reply interchange:

      
               ------------------------------------
              |                                    |
      Begin   |                                    |
        |     V                                    |
        |   +---+  cmd   +---+ 2         +---+     |
         -->|   |------->|   |---------->|   |     |
            |   |        | W |           | S |-----|
         -->|   |     -->|   |-----      |   |     |
        |   +---+    |   +---+ 4,5 |     +---+     |
        |     |      |    | |      |               |
        |     |      |   1| |3     |     +---+     |
        |     |      |    | |      |     |   |     |
        |     |       ----  |       ---->| F |-----
        |     |             |            |   |
        |     |             |            +---+
         -------------------
              |
              |
              V
             End
      
























Postel & Reynolds                                              [Page 58]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


7.  TYPICAL FTP SCENARIO

   User at host U wanting to transfer files to/from host S:

   In general, the user will communicate to the server via a mediating
   user-FTP process.  The following may be a typical scenario.  The
   user-FTP prompts are shown in parentheses, '---->' represents
   commands from host U to host S, and '<----' represents replies from
   host S to host U.

      LOCAL COMMANDS BY USER              ACTION INVOLVED

      ftp (host) multics<CR>         Connect to host S, port L,
                                     establishing control connections.
                                     <---- 220 Service ready <CRLF>.
      username Doe <CR>              USER Doe<CRLF>---->
                                     <---- 331 User name ok,
                                               need password<CRLF>.
      password mumble <CR>           PASS mumble<CRLF>---->
                                     <---- 230 User logged in<CRLF>.
      retrieve (local type) ASCII<CR>
      (local pathname) test 1 <CR>   User-FTP opens local file in ASCII.
      (for. pathname) test.pl1<CR>   RETR test.pl1<CRLF> ---->
                                     <---- 150 File status okay;
                                           about to open data
                                           connection<CRLF>.
                                     Server makes data connection
                                     to port U.
      
                                     <---- 226 Closing data connection,
                                         file transfer successful<CRLF>.
      type Image<CR>                 TYPE I<CRLF> ---->
                                     <---- 200 Command OK<CRLF>
      store (local type) image<CR>
      (local pathname) file dump<CR> User-FTP opens local file in Image.
      (for.pathname) >udd>cn>fd<CR>  STOR >udd>cn>fd<CRLF> ---->
                                     <---- 550 Access denied<CRLF>
      terminate                      QUIT <CRLF> ---->
                                     Server closes all
                                     connections.

8.  CONNECTION ESTABLISHMENT

   The FTP control connection is established via TCP between the user
   process port U and the server process port L.  This protocol is
   assigned the service port 21 (25 octal), that is L=21.



Postel & Reynolds                                              [Page 59]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


APPENDIX I -  PAGE STRUCTURE

   The need for FTP to support page structure derives principally from
   the  need to support efficient transmission of files between TOPS-20
   systems, particularly the files used by NLS.

   The file system of TOPS-20 is based on the concept of pages.  The
   operating system is most efficient at manipulating files as pages.
   The operating system provides an interface to the file system so that
   many applications view files as sequential streams of characters.
   However, a few applications use the underlying page structures
   directly, and some of these create holey files.

   A TOPS-20 disk file consists of four things: a pathname, a page
   table, a (possibly empty) set of pages, and a set of attributes.

   The pathname is specified in the RETR or STOR command.  It includes
   the directory name, file name, file name extension, and generation
   number.

   The page table contains up to 2**18 entries.  Each entry may be
   EMPTY, or may point to a page.  If it is not empty, there are also
   some page-specific access bits; not all pages of a file need have the
   same access protection.

      A page is a contiguous set of 512 words of 36 bits each.

   The attributes of the file, in the File Descriptor Block (FDB),
   contain such things as creation time, write time, read time, writer's
   byte-size, end-of-file pointer, count of reads and writes, backup
   system tape numbers, etc.

   Note that there is NO requirement that entries in the page table be
   contiguous.  There may be empty page table slots between occupied
   ones.  Also, the end of file pointer is simply a number.  There is no
   requirement that it in fact point at the "last" datum in the file.
   Ordinary sequential I/O calls in TOPS-20 will cause the end of file
   pointer to be left after the last datum written, but other operations
   may cause it not to be so, if a particular programming system so
   requires.

   In fact, in both of these special cases, "holey" files and
   end-of-file pointers NOT at the end of the file, occur with NLS data
   files.





Postel & Reynolds                                              [Page 60]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The TOPS-20 paged files can be sent with the FTP transfer parameters:
   TYPE L 36, STRU P, and MODE S (in fact, any mode could be used).

   Each page of information has a header.  Each header field, which is a
   logical byte, is a TOPS-20 word, since the TYPE is L 36.

   The header fields are:

      Word 0: Header Length.

         The header length is 5.

      Word 1: Page Index.

         If the data is a disk file page, this is the number of that
         page in the file's page map.  Empty pages (holes) in the file
         are simply not sent.  Note that a hole is NOT the same as a
         page of zeros.

      Word 2: Data Length.

         The number of data words in this page, following the header.
         Thus, the total length of the transmission unit is the Header
         Length plus the Data Length.

      Word 3: Page Type.

         A code for what type of chunk this is.  A data page is type 3,
         the FDB page is type 2.

      Word 4: Page Access Control.

         The access bits associated with the page in the file's page
         map.  (This full word quantity is put into AC2 of an SPACS by
         the program reading from net to disk.)

   After the header are Data Length data words.  Data Length is
   currently either 512 for a data page or 31 for an FDB.  Trailing
   zeros in a disk file page may be discarded, making Data Length less
   than 512 in that case.









Postel & Reynolds                                              [Page 61]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


APPENDIX II -  DIRECTORY COMMANDS

   Since UNIX has a tree-like directory structure in which directories
   are as easy to manipulate as ordinary files, it is useful to expand
   the FTP servers on these machines to include commands which deal with
   the creation of directories.  Since there are other hosts on the
   ARPA-Internet which have tree-like directories (including TOPS-20 and
   Multics), these commands are as general as possible.

      Four directory commands have been added to FTP:

         MKD pathname

            Make a directory with the name "pathname".

         RMD pathname

            Remove the directory with the name "pathname".

         PWD

            Print the current working directory name.

         CDUP

            Change to the parent of the current working directory.

   The  "pathname"  argument should be created (removed) as a
   subdirectory of the current working directory, unless the "pathname"
   string contains sufficient information to specify otherwise to the
   server, e.g., "pathname" is an absolute pathname (in UNIX and
   Multics), or pathname is something like "<abso.lute.path>" to
   TOPS-20.

   REPLY CODES

      The CDUP command is a special case of CWD, and is included to
      simplify the implementation of programs for transferring directory
      trees between operating systems having different syntaxes for
      naming the parent directory.  The reply codes for CDUP be
      identical to the reply codes of CWD.

      The reply codes for RMD be identical to the reply codes for its
      file analogue, DELE.

      The reply codes for MKD, however, are a bit more complicated.  A
      freshly created directory will probably be the object of a future


Postel & Reynolds                                              [Page 62]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      CWD command.  Unfortunately, the argument to MKD may not always be
      a suitable argument for CWD.  This is the case, for example, when
      a TOPS-20 subdirectory is created by giving just the subdirectory
      name.  That is, with a TOPS-20 server FTP, the command sequence

         MKD MYDIR
         CWD MYDIR

      will fail.  The new directory may only be referred to by its
      "absolute" name; e.g., if the MKD command above were issued while
      connected to the directory <DFRANKLIN>, the new subdirectory
      could only be referred to by the name <DFRANKLIN.MYDIR>.

      Even on UNIX and Multics, however, the argument given to MKD may
      not be suitable.  If it is a "relative" pathname (i.e., a pathname
      which is interpreted relative to the current directory), the user
      would need to be in the same current directory in order to reach
      the subdirectory.  Depending on the application, this may be
      inconvenient.  It is not very robust in any case.

      To solve these problems, upon successful completion of an MKD
      command, the server should return a line of the form:

         257<space>"<directory-name>"<space><commentary>

      That is, the server will tell the user what string to use when
      referring to the created  directory.  The directory name can
      contain any character; embedded double-quotes should be escaped by
      double-quotes (the "quote-doubling" convention).

      For example, a user connects to the directory /usr/dm, and creates
      a subdirectory, named pathname:

         CWD /usr/dm
         200 directory changed to /usr/dm
         MKD pathname
         257 "/usr/dm/pathname" directory created

      An example with an embedded double quote:

         MKD foo"bar
         257 "/usr/dm/foo""bar" directory created
         CWD /usr/dm/foo"bar
         200 directory changed to /usr/dm/foo"bar





Postel & Reynolds                                              [Page 63]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      The prior existence of a subdirectory with the same name is an
      error, and the server must return an "access denied" error reply
      in that case.

         CWD /usr/dm
         200 directory changed to /usr/dm
         MKD pathname
         521-"/usr/dm/pathname" directory already exists;
         521 taking no action.

      The failure replies for MKD are analogous to its file  creating
      cousin, STOR.  Also, an "access denied" return is given if a file
      name with the same name as the subdirectory will conflict with the
      creation of the subdirectory (this is a problem on UNIX, but
      shouldn't be one on TOPS-20).

      Essentially because the PWD command returns the same type of
      information as the successful MKD command, the successful PWD
      command uses the 257 reply code as well.

   SUBTLETIES

      Because these commands will be most useful in transferring
      subtrees from one machine to another, carefully observe that the
      argument to MKD is to be interpreted as a sub-directory of  the
      current working directory, unless it contains enough information
      for the destination host to tell otherwise.  A hypothetical
      example of its use in the TOPS-20 world:

         CWD <some.where>
         200 Working directory changed
         MKD overrainbow
         257 "<some.where.overrainbow>" directory created
         CWD overrainbow
         431 No such directory
         CWD <some.where.overrainbow>
         200 Working directory changed

         CWD <some.where>
         200 Working directory changed to <some.where>
         MKD <unambiguous>
         257 "<unambiguous>" directory created
         CWD <unambiguous>

      Note that the first example results in a subdirectory of the
      connected directory.  In contrast, the argument in the second
      example contains enough information for TOPS-20 to tell that  the


Postel & Reynolds                                              [Page 64]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      <unambiguous> directory is a top-level directory.  Note also that
      in the first example the user "violated" the protocol by
      attempting to access the freshly created directory with a name
      other than the one returned by TOPS-20.  Problems could have
      resulted in this case had there been an <overrainbow> directory;
      this is an ambiguity inherent in some TOPS-20 implementations.
      Similar considerations apply to the RMD command.  The point is
      this: except where to do so would violate a host's conventions for
      denoting relative versus absolute pathnames, the host should treat
      the operands of the MKD and RMD commands as subdirectories.  The
      257 reply to the MKD command must always contain the absolute
      pathname of the created directory.





































Postel & Reynolds                                              [Page 65]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


APPENDIX III - RFCs on FTP

   Bhushan, Abhay, "A File Transfer Protocol", RFC 114 (NIC 5823),
   MIT-Project MAC, 16 April 1971.

   Harslem, Eric, and John Heafner, "Comments on RFC 114 (A File
   Transfer Protocol)", RFC 141 (NIC 6726), RAND, 29 April 1971.

   Bhushan, Abhay, et al, "The File Transfer Protocol", RFC 172
   (NIC 6794), MIT-Project MAC, 23 June 1971.

   Braden, Bob, "Comments on DTP and FTP Proposals", RFC 238 (NIC 7663),
   UCLA/CCN, 29 September 1971.

   Bhushan, Abhay, et al, "The File Transfer Protocol", RFC 265
   (NIC 7813), MIT-Project MAC, 17 November 1971.

   McKenzie, Alex, "A Suggested Addition to File Transfer Protocol",
   RFC 281 (NIC 8163), BBN, 8 December 1971.

   Bhushan, Abhay, "The Use of "Set Data Type" Transaction in File
   Transfer Protocol", RFC 294 (NIC 8304), MIT-Project MAC,
   25 January 1972.

   Bhushan, Abhay, "The File Transfer Protocol", RFC 354 (NIC 10596),
   MIT-Project MAC, 8 July 1972.

   Bhushan, Abhay, "Comments on the File Transfer Protocol (RFC 354)",
   RFC 385 (NIC 11357), MIT-Project MAC, 18 August 1972.

   Hicks, Greg, "User FTP Documentation", RFC 412 (NIC 12404), Utah,
   27 November 1972.

   Bhushan, Abhay, "File Transfer Protocol (FTP) Status and Further
   Comments", RFC 414 (NIC 12406), MIT-Project MAC, 20 November 1972.

   Braden, Bob, "Comments on File Transfer Protocol", RFC 430
   (NIC 13299), UCLA/CCN, 7 February 1973.

   Thomas, Bob, and Bob Clements, "FTP Server-Server Interaction",
   RFC 438 (NIC 13770), BBN, 15 January 1973.

   Braden, Bob, "Print Files in FTP", RFC 448 (NIC 13299), UCLA/CCN,
   27 February 1973.

   McKenzie, Alex, "File Transfer Protocol", RFC 454 (NIC 14333), BBN,
   16 February 1973.


Postel & Reynolds                                              [Page 66]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   Bressler, Bob, and Bob Thomas, "Mail Retrieval via FTP", RFC 458
   (NIC 14378), BBN-NET and BBN-TENEX, 20 February 1973.

   Neigus, Nancy, "File Transfer Protocol", RFC 542 (NIC 17759), BBN,
   12 July 1973.

   Krilanovich, Mark, and George Gregg, "Comments on the File Transfer
   Protocol", RFC 607 (NIC 21255), UCSB, 7 January 1974.

   Pogran, Ken, and Nancy Neigus, "Response to RFC 607 - Comments on the
   File Transfer Protocol", RFC 614 (NIC 21530), BBN, 28 January 1974.

   Krilanovich, Mark, George Gregg, Wayne Hathaway, and Jim White,
   "Comments on the File Transfer Protocol", RFC 624 (NIC 22054), UCSB,
   Ames Research Center, SRI-ARC, 28 February 1974.

   Bhushan, Abhay, "FTP Comments and Response to RFC 430", RFC 463
   (NIC 14573), MIT-DMCG, 21 February 1973.

   Braden, Bob, "FTP Data Compression", RFC 468 (NIC 14742), UCLA/CCN,
   8 March 1973.

   Bhushan, Abhay, "FTP and Network Mail System", RFC 475 (NIC 14919),
   MIT-DMCG, 6 March 1973.

   Bressler, Bob, and Bob Thomas "FTP Server-Server Interaction - II",
   RFC 478 (NIC 14947), BBN-NET and BBN-TENEX, 26 March 1973.

   White, Jim, "Use of FTP by the NIC Journal", RFC 479 (NIC 14948),
   SRI-ARC, 8 March 1973.

   White, Jim, "Host-Dependent FTP Parameters", RFC 480 (NIC 14949),
   SRI-ARC, 8 March 1973.

   Padlipsky, Mike, "An FTP Command-Naming Problem", RFC 506
   (NIC 16157), MIT-Multics, 26 June 1973.

   Day, John, "Memo to FTP Group (Proposal for File Access Protocol)",
   RFC 520 (NIC 16819), Illinois, 25 June 1973.

   Merryman, Robert, "The UCSD-CC Server-FTP Facility", RFC 532
   (NIC 17451), UCSD-CC, 22 June 1973.

   Braden, Bob, "TENEX FTP Problem", RFC 571 (NIC 18974), UCLA/CCN,
   15 November 1973.




Postel & Reynolds                                              [Page 67]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   McKenzie, Alex, and Jon Postel, "Telnet and FTP Implementation -
   Schedule Change", RFC 593 (NIC 20615), BBN and MITRE,
   29 November 1973.

   Sussman, Julie, "FTP Error Code Usage for More Reliable Mail
   Service", RFC 630 (NIC 30237), BBN, 10 April 1974.

   Postel, Jon, "Revised FTP Reply Codes", RFC 640 (NIC 30843),
   UCLA/NMC, 5 June 1974.

   Harvey, Brian, "Leaving Well Enough Alone", RFC 686 (NIC 32481),
   SU-AI, 10 May 1975.

   Harvey, Brian, "One More Try on the FTP", RFC 691 (NIC 32700), SU-AI,
   28 May 1975.

   Lieb, J., "CWD Command of FTP", RFC 697 (NIC 32963), 14 July 1975.

   Harrenstien, Ken, "FTP Extension: XSEN", RFC 737 (NIC 42217), SRI-KL,
   31 October 1977.

   Harrenstien, Ken, "FTP Extension: XRSQ/XRCP", RFC 743 (NIC 42758),
   SRI-KL, 30 December 1977.

   Lebling, P. David, "Survey of FTP Mail and MLFL", RFC 751, MIT,
   10 December 1978.

   Postel, Jon, "File Transfer Protocol Specification", RFC 765, ISI,
   June 1980.

   Mankins, David, Dan Franklin, and Buzz Owen, "Directory Oriented FTP
   Commands", RFC 776, BBN, December 1980.

   Padlipsky, Michael, "FTP Unique-Named Store Command", RFC 949, MITRE,
   July 1985.














Postel & Reynolds                                              [Page 68]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


REFERENCES

   [1]  Feinler, Elizabeth, "Internet Protocol Transition Workbook",
        Network Information Center, SRI International, March 1982.

   [2]  Postel, Jon, "Transmission Control Protocol - DARPA Internet
        Program Protocol Specification", RFC 793, DARPA, September 1981.

   [3]  Postel, Jon, and Joyce Reynolds, "Telnet Protocol
        Specification", RFC 854, ISI, May 1983.

   [4]  Reynolds, Joyce, and Jon Postel, "Assigned Numbers", RFC 943,
        ISI, April 1985.




































Postel & Reynolds                                              [Page 69]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ftpd/std9.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933

                                                                        
Network Working Group                                          J. Postel
Request for Comments: 959                                    J. Reynolds
                                                                     ISI
Obsoletes RFC: 765 (IEN 149)                                October 1985

                      FILE TRANSFER PROTOCOL (FTP)


Status of this Memo

   This memo is the official specification of the File Transfer
   Protocol (FTP).  Distribution of this memo is unlimited.

   The following new optional commands are included in this edition of
   the specification:

      CDUP (Change to Parent Directory), SMNT (Structure Mount), STOU
      (Store Unique), RMD (Remove Directory), MKD (Make Directory), PWD
      (Print Directory), and SYST (System).

   Note that this specification is compatible with the previous edition.

1.  INTRODUCTION

   The objectives of FTP are 1) to promote sharing of files (computer
   programs and/or data), 2) to encourage indirect or implicit (via
   programs) use of remote computers, 3) to shield a user from
   variations in file storage systems among hosts, and 4) to transfer
   data reliably and efficiently.  FTP, though usable directly by a user
   at a terminal, is designed mainly for use by programs.

   The attempt in this specification is to satisfy the diverse needs of
   users of maxi-hosts, mini-hosts, personal workstations, and TACs,
   with a simple, and easily implemented protocol design.

   This paper assumes knowledge of the Transmission Control Protocol
   (TCP) [2] and the Telnet Protocol [3].  These documents are contained
   in the ARPA-Internet protocol handbook [1].

2.  OVERVIEW

   In this section, the history, the terminology, and the FTP model are
   discussed.  The terms defined in this section are only those that
   have special significance in FTP.  Some of the terminology is very
   specific to the FTP model; some readers may wish to turn to the
   section on the FTP model while reviewing the terminology.







Postel & Reynolds                                               [Page 1]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   2.1.  HISTORY

      FTP has had a long evolution over the years.  Appendix III is a
      chronological compilation of Request for Comments documents
      relating to FTP.  These include the first proposed file transfer
      mechanisms in 1971 that were developed for implementation on hosts
      at M.I.T. (RFC 114), plus comments and discussion in RFC 141.

      RFC 172 provided a user-level oriented protocol for file transfer
      between host computers (including terminal IMPs).  A revision of
      this as RFC 265, restated FTP for additional review, while RFC 281
      suggested further changes.  The use of a "Set Data Type"
      transaction was proposed in RFC 294 in January 1982.

      RFC 354 obsoleted RFCs 264 and 265.  The File Transfer Protocol
      was now defined as a protocol for file transfer between HOSTs on
      the ARPANET, with the primary function of FTP defined as
      transfering files efficiently and reliably among hosts and
      allowing the convenient use of remote file storage capabilities.
      RFC 385 further commented on errors, emphasis points, and
      additions to the protocol, while RFC 414 provided a status report
      on the working server and user FTPs.  RFC 430, issued in 1973,
      (among other RFCs too numerous to mention) presented further
      comments on FTP.  Finally, an "official" FTP document was
      published as RFC 454.

      By July 1973, considerable changes from the last versions of FTP
      were made, but the general structure remained the same.  RFC 542
      was published as a new "official" specification to reflect these
      changes.  However, many implementations based on the older
      specification were not updated.

      In 1974, RFCs 607 and 614 continued comments on FTP.  RFC 624
      proposed further design changes and minor modifications.  In 1975,
      RFC 686 entitled, "Leaving Well Enough Alone", discussed the
      differences between all of the early and later versions of FTP.
      RFC 691 presented a minor revision of RFC 686, regarding the
      subject of print files.

      Motivated by the transition from the NCP to the TCP as the
      underlying protocol, a phoenix was born out of all of the above
      efforts in RFC 765 as the specification of FTP for use on TCP.

      This current edition of the FTP specification is intended to
      correct some minor documentation errors, to improve the
      explanation of some protocol features, and to add some new
      optional commands.


Postel & Reynolds                                               [Page 2]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      In particular, the following new optional commands are included in
      this edition of the specification:

         CDUP - Change to Parent Directory

         SMNT - Structure Mount

         STOU - Store Unique

         RMD - Remove Directory

         MKD - Make Directory

         PWD - Print Directory

         SYST - System

      This specification is compatible with the previous edition.  A
      program implemented in conformance to the previous specification
      should automatically be in conformance to this specification.

   2.2.  TERMINOLOGY

      ASCII

         The ASCII character set is as defined in the ARPA-Internet
         Protocol Handbook.  In FTP, ASCII characters are defined to be
         the lower half of an eight-bit code set (i.e., the most
         significant bit is zero).

      access controls

         Access controls define users' access privileges to the use of a
         system, and to the files in that system.  Access controls are
         necessary to prevent unauthorized or accidental use of files.
         It is the prerogative of a server-FTP process to invoke access
         controls.

      byte size

         There are two byte sizes of interest in FTP:  the logical byte
         size of the file, and the transfer byte size used for the
         transmission of the data.  The transfer byte size is always 8
         bits.  The transfer byte size is not necessarily the byte size
         in which data is to be stored in a system, nor the logical byte
         size for interpretation of the structure of the data.



Postel & Reynolds                                               [Page 3]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      control connection

         The communication path between the USER-PI and SERVER-PI for
         the exchange of commands and replies.  This connection follows
         the Telnet Protocol.

      data connection

         A full duplex connection over which data is transferred, in a
         specified mode and type. The data transferred may be a part of
         a file, an entire file or a number of files.  The path may be
         between a server-DTP and a user-DTP, or between two
         server-DTPs.

      data port

         The passive data transfer process "listens" on the data port
         for a connection from the active transfer process in order to
         open the data connection.

      DTP

         The data transfer process establishes and manages the data
         connection.  The DTP can be passive or active.

      End-of-Line

         The end-of-line sequence defines the separation of printing
         lines.  The sequence is Carriage Return, followed by Line Feed.

      EOF

         The end-of-file condition that defines the end of a file being
         transferred.

      EOR

         The end-of-record condition that defines the end of a record
         being transferred.

      error recovery

         A procedure that allows a user to recover from certain errors
         such as failure of either host system or transfer process.  In
         FTP, error recovery may involve restarting a file transfer at a
         given checkpoint.



Postel & Reynolds                                               [Page 4]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      FTP commands

         A set of commands that comprise the control information flowing
         from the user-FTP to the server-FTP process.

      file

         An ordered set of computer data (including programs), of
         arbitrary length, uniquely identified by a pathname.

      mode

         The mode in which data is to be transferred via the data
         connection.  The mode defines the data format during transfer
         including EOR and EOF.  The transfer modes defined in FTP are
         described in the Section on Transmission Modes.

      NVT

         The Network Virtual Terminal as defined in the Telnet Protocol.

      NVFS

         The Network Virtual File System.  A concept which defines a
         standard network file system with standard commands and
         pathname conventions.

      page

         A file may be structured as a set of independent parts called
         pages.  FTP supports the transmission of discontinuous files as
         independent indexed pages.

      pathname

         Pathname is defined to be the character string which must be
         input to a file system by a user in order to identify a file.
         Pathname normally contains device and/or directory names, and
         file name specification.  FTP does not yet specify a standard
         pathname convention.  Each user must follow the file naming
         conventions of the file systems involved in the transfer.

      PI

         The protocol interpreter.  The user and server sides of the
         protocol have distinct roles implemented in a user-PI and a
         server-PI.


Postel & Reynolds                                               [Page 5]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      record

         A sequential file may be structured as a number of contiguous
         parts called records.  Record structures are supported by FTP
         but a file need not have record structure.

      reply

         A reply is an acknowledgment (positive or negative) sent from
         server to user via the control connection in response to FTP
         commands.  The general form of a reply is a completion code
         (including error codes) followed by a text string.  The codes
         are for use by programs and the text is usually intended for
         human users.

      server-DTP

         The data transfer process, in its normal "active" state,
         establishes the data connection with the "listening" data port.
         It sets up parameters for transfer and storage, and transfers
         data on command from its PI.  The DTP can be placed in a
         "passive" state to listen for, rather than initiate a
         connection on the data port.

      server-FTP process

         A process or set of processes which perform the function of
         file transfer in cooperation with a user-FTP process and,
         possibly, another server.  The functions consist of a protocol
         interpreter (PI) and a data transfer process (DTP).

      server-PI

         The server protocol interpreter "listens" on Port L for a
         connection from a user-PI and establishes a control
         communication connection.  It receives standard FTP commands
         from the user-PI, sends replies, and governs the server-DTP.

      type

         The data representation type used for data transfer and
         storage.  Type implies certain transformations between the time
         of data storage and data transfer.  The representation types
         defined in FTP are described in the Section on Establishing
         Data Connections.




Postel & Reynolds                                               [Page 6]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      user

         A person or a process on behalf of a person wishing to obtain
         file transfer service.  The human user may interact directly
         with a server-FTP process, but use of a user-FTP process is
         preferred since the protocol design is weighted towards
         automata.

      user-DTP

         The data transfer process "listens" on the data port for a
         connection from a server-FTP process.  If two servers are
         transferring data between them, the user-DTP is inactive.

      user-FTP process

         A set of functions including a protocol interpreter, a data
         transfer process and a user interface which together perform
         the function of file transfer in cooperation with one or more
         server-FTP processes.  The user interface allows a local
         language to be used in the command-reply dialogue with the
         user.

      user-PI

         The user protocol interpreter initiates the control connection
         from its port U to the server-FTP process, initiates FTP
         commands, and governs the user-DTP if that process is part of
         the file transfer.




















Postel & Reynolds                                               [Page 7]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   2.3.  THE FTP MODEL

      With the above definitions in mind, the following model (shown in
      Figure 1) may be diagrammed for an FTP service.

                                            -------------
                                            |/---------\|
                                            ||   User  ||    --------
                                            ||Interface|<--->| User |
                                            |\----^----/|    --------
                  ----------                |     |     |
                  |/------\|  FTP Commands  |/----V----\|
                  ||Server|<---------------->|   User  ||
                  ||  PI  ||   FTP Replies  ||    PI   ||
                  |\--^---/|                |\----^----/|
                  |   |    |                |     |     |
      --------    |/--V---\|      Data      |/----V----\|    --------
      | File |<--->|Server|<---------------->|  User   |<--->| File |
      |System|    || DTP  ||   Connection   ||   DTP   ||    |System|
      --------    |\------/|                |\---------/|    --------
                  ----------                -------------

                  Server-FTP                   USER-FTP

      NOTES: 1. The data connection may be used in either direction.
             2. The data connection need not exist all of the time.

                      Figure 1  Model for FTP Use

      In the model described in Figure 1, the user-protocol interpreter
      initiates the control connection.  The control connection follows
      the Telnet protocol.  At the initiation of the user, standard FTP
      commands are generated by the user-PI and transmitted to the
      server process via the control connection.  (The user may
      establish a direct control connection to the server-FTP, from a
      TAC terminal for example, and generate standard FTP commands
      independently, bypassing the user-FTP process.) Standard replies
      are sent from the server-PI to the user-PI over the control
      connection in response to the commands.

      The FTP commands specify the parameters for the data connection
      (data port, transfer mode, representation type, and structure) and
      the nature of file system operation (store, retrieve, append,
      delete, etc.).  The user-DTP or its designate should "listen" on
      the specified data port, and the server initiate the data
      connection and data transfer in accordance with the specified
      parameters.  It should be noted that the data port need not be in


Postel & Reynolds                                               [Page 8]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      the same host that initiates the FTP commands via the control
      connection, but the user or the user-FTP process must ensure a
      "listen" on the specified data port.  It ought to also be noted
      that the data connection may be used for simultaneous sending and
      receiving.

      In another situation a user might wish to transfer files between
      two hosts, neither of which is a local host. The user sets up
      control connections to the two servers and then arranges for a
      data connection between them.  In this manner, control information
      is passed to the user-PI but data is transferred between the
      server data transfer processes.  Following is a model of this
      server-server interaction.

      
                    Control     ------------   Control
                    ---------->| User-FTP |<-----------
                    |          | User-PI  |           |
                    |          |   "C"    |           |
                    V          ------------           V
            --------------                        --------------
            | Server-FTP |   Data Connection      | Server-FTP |
            |    "A"     |<---------------------->|    "B"     |
            -------------- Port (A)      Port (B) --------------
      

                                 Figure 2

      The protocol requires that the control connections be open while
      data transfer is in progress.  It is the responsibility of the
      user to request the closing of the control connections when
      finished using the FTP service, while it is the server who takes
      the action.  The server may abort data transfer if the control
      connections are closed without command.

      The Relationship between FTP and Telnet:

         The FTP uses the Telnet protocol on the control connection.
         This can be achieved in two ways: first, the user-PI or the
         server-PI may implement the rules of the Telnet Protocol
         directly in their own procedures; or, second, the user-PI or
         the server-PI may make use of the existing Telnet module in the
         system.

         Ease of implementaion, sharing code, and modular programming
         argue for the second approach.  Efficiency and independence



Postel & Reynolds                                               [Page 9]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         argue for the first approach.  In practice, FTP relies on very
         little of the Telnet Protocol, so the first approach does not
         necessarily involve a large amount of code.

3.  DATA TRANSFER FUNCTIONS

   Files are transferred only via the data connection.  The control
   connection is used for the transfer of commands, which describe the
   functions to be performed, and the replies to these commands (see the
   Section on FTP Replies).  Several commands are concerned with the
   transfer of data between hosts.  These data transfer commands include
   the MODE command which specify how the bits of the data are to be
   transmitted, and the STRUcture and TYPE commands, which are used to
   define the way in which the data are to be represented.  The
   transmission and representation are basically independent but the
   "Stream" transmission mode is dependent on the file structure
   attribute and if "Compressed" transmission mode is used, the nature
   of the filler byte depends on the representation type.

   3.1.  DATA REPRESENTATION AND STORAGE

      Data is transferred from a storage device in the sending host to a
      storage device in the receiving host.  Often it is necessary to
      perform certain transformations on the data because data storage
      representations in the two systems are different.  For example,
      NVT-ASCII has different data storage representations in different
      systems.  DEC TOPS-20s's generally store NVT-ASCII as five 7-bit
      ASCII characters, left-justified in a 36-bit word. IBM Mainframe's
      store NVT-ASCII as 8-bit EBCDIC codes.  Multics stores NVT-ASCII
      as four 9-bit characters in a 36-bit word.  It is desirable to
      convert characters into the standard NVT-ASCII representation when
      transmitting text between dissimilar systems.  The sending and
      receiving sites would have to perform the necessary
      transformations between the standard representation and their
      internal representations.

      A different problem in representation arises when transmitting
      binary data (not character codes) between host systems with
      different word lengths.  It is not always clear how the sender
      should send data, and the receiver store it.  For example, when
      transmitting 32-bit bytes from a 32-bit word-length system to a
      36-bit word-length system, it may be desirable (for reasons of
      efficiency and usefulness) to store the 32-bit bytes
      right-justified in a 36-bit word in the latter system.  In any
      case, the user should have the option of specifying data
      representation and transformation functions.  It should be noted



Postel & Reynolds                                              [Page 10]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      that FTP provides for very limited data type representations.
      Transformations desired beyond this limited capability should be
      performed by the user directly.

      3.1.1.  DATA TYPES

         Data representations are handled in FTP by a user specifying a
         representation type.  This type may implicitly (as in ASCII or
         EBCDIC) or explicitly (as in Local byte) define a byte size for
         interpretation which is referred to as the "logical byte size."
         Note that this has nothing to do with the byte size used for
         transmission over the data connection, called the "transfer
         byte size", and the two should not be confused.  For example,
         NVT-ASCII has a logical byte size of 8 bits.  If the type is
         Local byte, then the TYPE command has an obligatory second
         parameter specifying the logical byte size.  The transfer byte
         size is always 8 bits.

         3.1.1.1.  ASCII TYPE

            This is the default type and must be accepted by all FTP
            implementations.  It is intended primarily for the transfer
            of text files, except when both hosts would find the EBCDIC
            type more convenient.

            The sender converts the data from an internal character
            representation to the standard 8-bit NVT-ASCII
            representation (see the Telnet specification).  The receiver
            will convert the data from the standard form to his own
            internal form.

            In accordance with the NVT standard, the <CRLF> sequence
            should be used where necessary to denote the end of a line
            of text.  (See the discussion of file structure at the end
            of the Section on Data Representation and Storage.)

            Using the standard NVT-ASCII representation means that data
            must be interpreted as 8-bit bytes.

            The Format parameter for ASCII and EBCDIC types is discussed
            below.








Postel & Reynolds                                              [Page 11]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         3.1.1.2.  EBCDIC TYPE

            This type is intended for efficient transfer between hosts
            which use EBCDIC for their internal character
            representation.

            For transmission, the data are represented as 8-bit EBCDIC
            characters.  The character code is the only difference
            between the functional specifications of EBCDIC and ASCII
            types.

            End-of-line (as opposed to end-of-record--see the discussion
            of structure) will probably be rarely used with EBCDIC type
            for purposes of denoting structure, but where it is
            necessary the <NL> character should be used.

         3.1.1.3.  IMAGE TYPE

            The data are sent as contiguous bits which, for transfer,
            are packed into the 8-bit transfer bytes.  The receiving
            site must store the data as contiguous bits.  The structure
            of the storage system might necessitate the padding of the
            file (or of each record, for a record-structured file) to
            some convenient boundary (byte, word or block).  This
            padding, which must be all zeros, may occur only at the end
            of the file (or at the end of each record) and there must be
            a way of identifying the padding bits so that they may be
            stripped off if the file is retrieved.  The padding
            transformation should be well publicized to enable a user to
            process a file at the storage site.

            Image type is intended for the efficient storage and
            retrieval of files and for the transfer of binary data.  It
            is recommended that this type be accepted by all FTP
            implementations.

         3.1.1.4.  LOCAL TYPE

            The data is transferred in logical bytes of the size
            specified by the obligatory second parameter, Byte size.
            The value of Byte size must be a decimal integer; there is
            no default value.  The logical byte size is not necessarily
            the same as the transfer byte size.  If there is a
            difference in byte sizes, then the logical bytes should be
            packed contiguously, disregarding transfer byte boundaries
            and with any necessary padding at the end.



Postel & Reynolds                                              [Page 12]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            When the data reaches the receiving host, it will be
            transformed in a manner dependent on the logical byte size
            and the particular host.  This transformation must be
            invertible (i.e., an identical file can be retrieved if the
            same parameters are used) and should be well publicized by
            the FTP implementors.

            For example, a user sending 36-bit floating-point numbers to
            a host with a 32-bit word could send that data as Local byte
            with a logical byte size of 36.  The receiving host would
            then be expected to store the logical bytes so that they
            could be easily manipulated; in this example putting the
            36-bit logical bytes into 64-bit double words should
            suffice.

            In another example, a pair of hosts with a 36-bit word size
            may send data to one another in words by using TYPE L 36.
            The data would be sent in the 8-bit transmission bytes
            packed so that 9 transmission bytes carried two host words.

         3.1.1.5.  FORMAT CONTROL

            The types ASCII and EBCDIC also take a second (optional)
            parameter; this is to indicate what kind of vertical format
            control, if any, is associated with a file.  The following
            data representation types are defined in FTP:

            A character file may be transferred to a host for one of
            three purposes: for printing, for storage and later
            retrieval, or for processing.  If a file is sent for
            printing, the receiving host must know how the vertical
            format control is represented.  In the second case, it must
            be possible to store a file at a host and then retrieve it
            later in exactly the same form.  Finally, it should be
            possible to move a file from one host to another and process
            the file at the second host without undue trouble.  A single
            ASCII or EBCDIC format does not satisfy all these
            conditions.  Therefore, these types have a second parameter
            specifying one of the following three formats:

            3.1.1.5.1.  NON PRINT

               This is the default format to be used if the second
               (format) parameter is omitted.  Non-print format must be
               accepted by all FTP implementations.




Postel & Reynolds                                              [Page 13]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               The file need contain no vertical format information.  If
               it is passed to a printer process, this process may
               assume standard values for spacing and margins.

               Normally, this format will be used with files destined
               for processing or just storage.

            3.1.1.5.2.  TELNET FORMAT CONTROLS

               The file contains ASCII/EBCDIC vertical format controls
               (i.e., <CR>, <LF>, <NL>, <VT>, <FF>) which the printer
               process will interpret appropriately.  <CRLF>, in exactly
               this sequence, also denotes end-of-line.

            3.1.1.5.2.  CARRIAGE CONTROL (ASA)

               The file contains ASA (FORTRAN) vertical format control
               characters.  (See RFC 740 Appendix C; and Communications
               of the ACM, Vol. 7, No. 10, p. 606, October 1964.)  In a
               line or a record formatted according to the ASA Standard,
               the first character is not to be printed.  Instead, it
               should be used to determine the vertical movement of the
               paper which should take place before the rest of the
               record is printed.

               The ASA Standard specifies the following control
               characters:

                  Character     Vertical Spacing

                  blank         Move paper up one line
                  0             Move paper up two lines
                  1             Move paper to top of next page
                  +             No movement, i.e., overprint

               Clearly there must be some way for a printer process to
               distinguish the end of the structural entity.  If a file
               has record structure (see below) this is no problem;
               records will be explicitly marked during transfer and
               storage.  If the file has no record structure, the <CRLF>
               end-of-line sequence is used to separate printing lines,
               but these format effectors are overridden by the ASA
               controls.






Postel & Reynolds                                              [Page 14]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      3.1.2.  DATA STRUCTURES

         In addition to different representation types, FTP allows the
         structure of a file to be specified.  Three file structures are
         defined in FTP:

            file-structure,     where there is no internal structure and
                                the file is considered to be a
                                continuous sequence of data bytes,

            record-structure,   where the file is made up of sequential
                                records,

            and page-structure, where the file is made up of independent
                                indexed pages.

         File-structure is the default to be assumed if the STRUcture
         command has not been used but both file and record structures
         must be accepted for "text" files (i.e., files with TYPE ASCII
         or EBCDIC) by all FTP implementations.  The structure of a file
         will affect both the transfer mode of a file (see the Section
         on Transmission Modes) and the interpretation and storage of
         the file.

         The "natural" structure of a file will depend on which host
         stores the file.  A source-code file will usually be stored on
         an IBM Mainframe in fixed length records but on a DEC TOPS-20
         as a stream of characters partitioned into lines, for example
         by <CRLF>.  If the transfer of files between such disparate
         sites is to be useful, there must be some way for one site to
         recognize the other's assumptions about the file.

         With some sites being naturally file-oriented and others
         naturally record-oriented there may be problems if a file with
         one structure is sent to a host oriented to the other.  If a
         text file is sent with record-structure to a host which is file
         oriented, then that host should apply an internal
         transformation to the file based on the record structure.
         Obviously, this transformation should be useful, but it must
         also be invertible so that an identical file may be retrieved
         using record structure.

         In the case of a file being sent with file-structure to a
         record-oriented host, there exists the question of what
         criteria the host should use to divide the file into records
         which can be processed locally.  If this division is necessary,
         the FTP implementation should use the end-of-line sequence,


Postel & Reynolds                                              [Page 15]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         <CRLF> for ASCII, or <NL> for EBCDIC text files, as the
         delimiter.  If an FTP implementation adopts this technique, it
         must be prepared to reverse the transformation if the file is
         retrieved with file-structure.

         3.1.2.1.  FILE STRUCTURE

            File structure is the default to be assumed if the STRUcture
            command has not been used.

            In file-structure there is no internal structure and the
            file is considered to be a continuous sequence of data
            bytes.

         3.1.2.2.  RECORD STRUCTURE

            Record structures must be accepted for "text" files (i.e.,
            files with TYPE ASCII or EBCDIC) by all FTP implementations.

            In record-structure the file is made up of sequential
            records.

         3.1.2.3.  PAGE STRUCTURE

            To transmit files that are discontinuous, FTP defines a page
            structure.  Files of this type are sometimes known as
            "random access files" or even as "holey files".  In these
            files there is sometimes other information associated with
            the file as a whole (e.g., a file descriptor), or with a
            section of the file (e.g., page access controls), or both.
            In FTP, the sections of the file are called pages.

            To provide for various page sizes and associated
            information, each page is sent with a page header.  The page
            header has the following defined fields:

               Header Length

                  The number of logical bytes in the page header
                  including this byte.  The minimum header length is 4.

               Page Index

                  The logical page number of this section of the file.
                  This is not the transmission sequence number of this
                  page, but the index used to identify this page of the
                  file.


Postel & Reynolds                                              [Page 16]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               Data Length

                  The number of logical bytes in the page data.  The
                  minimum data length is 0.

               Page Type

                  The type of page this is.  The following page types
                  are defined:

                     0 = Last Page

                        This is used to indicate the end of a paged
                        structured transmission.  The header length must
                        be 4, and the data length must be 0.

                     1 = Simple Page

                        This is the normal type for simple paged files
                        with no page level associated control
                        information.  The header length must be 4.

                     2 = Descriptor Page

                        This type is used to transmit the descriptive
                        information for the file as a whole.

                     3 = Access Controlled Page

                        This type includes an additional header field
                        for paged files with page level access control
                        information.  The header length must be 5.

               Optional Fields

                  Further header fields may be used to supply per page
                  control information, for example, per page access
                  control.

            All fields are one logical byte in length.  The logical byte
            size is specified by the TYPE command.  See Appendix I for
            further details and a specific case at the page structure.

      A note of caution about parameters:  a file must be stored and
      retrieved with the same parameters if the retrieved version is to




Postel & Reynolds                                              [Page 17]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      be identical to the version originally transmitted.  Conversely,
      FTP implementations must return a file identical to the original
      if the parameters used to store and retrieve a file are the same.

   3.2.  ESTABLISHING DATA CONNECTIONS

      The mechanics of transferring data consists of setting up the data
      connection to the appropriate ports and choosing the parameters
      for transfer.  Both the user and the server-DTPs have a default
      data port.  The user-process default data port is the same as the
      control connection port (i.e., U).  The server-process default
      data port is the port adjacent to the control connection port
      (i.e., L-1).

      The transfer byte size is 8-bit bytes.  This byte size is relevant
      only for the actual transfer of the data; it has no bearing on
      representation of the data within a host's file system.

      The passive data transfer process (this may be a user-DTP or a
      second server-DTP) shall "listen" on the data port prior to
      sending a transfer request command.  The FTP request command
      determines the direction of the data transfer.  The server, upon
      receiving the transfer request, will initiate the data connection
      to the port.  When the connection is established, the data
      transfer begins between DTP's, and the server-PI sends a
      confirming reply to the user-PI.

      Every FTP implementation must support the use of the default data
      ports, and only the USER-PI can initiate a change to non-default
      ports.

      It is possible for the user to specify an alternate data port by
      use of the PORT command.  The user may want a file dumped on a TAC
      line printer or retrieved from a third party host.  In the latter
      case, the user-PI sets up control connections with both
      server-PI's.  One server is then told (by an FTP command) to
      "listen" for a connection which the other will initiate.  The
      user-PI sends one server-PI a PORT command indicating the data
      port of the other.  Finally, both are sent the appropriate
      transfer commands.  The exact sequence of commands and replies
      sent between the user-controller and the servers is defined in the
      Section on FTP Replies.

      In general, it is the server's responsibility to maintain the data
      connection--to initiate it and to close it.  The exception to this




Postel & Reynolds                                              [Page 18]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      is when the user-DTP is sending the data in a transfer mode that
      requires the connection to be closed to indicate EOF.  The server
      MUST close the data connection under the following conditions:

         1. The server has completed sending data in a transfer mode
            that requires a close to indicate EOF.

         2. The server receives an ABORT command from the user.

         3. The port specification is changed by a command from the
            user.

         4. The control connection is closed legally or otherwise.

         5. An irrecoverable error condition occurs.

      Otherwise the close is a server option, the exercise of which the
      server must indicate to the user-process by either a 250 or 226
      reply only.

   3.3.  DATA CONNECTION MANAGEMENT

      Default Data Connection Ports:  All FTP implementations must
      support use of the default data connection ports, and only the
      User-PI may initiate the use of non-default ports.

      Negotiating Non-Default Data Ports:   The User-PI may specify a
      non-default user side data port with the PORT command.  The
      User-PI may request the server side to identify a non-default
      server side data port with the PASV command.  Since a connection
      is defined by the pair of addresses, either of these actions is
      enough to get a different data connection, still it is permitted
      to do both commands to use new ports on both ends of the data
      connection.

      Reuse of the Data Connection:  When using the stream mode of data
      transfer the end of the file must be indicated by closing the
      connection.  This causes a problem if multiple files are to be
      transfered in the session, due to need for TCP to hold the
      connection record for a time out period to guarantee the reliable
      communication.  Thus the connection can not be reopened at once.

         There are two solutions to this problem.  The first is to
         negotiate a non-default port.  The second is to use another
         transfer mode.

         A comment on transfer modes.  The stream transfer mode is


Postel & Reynolds                                              [Page 19]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         inherently unreliable, since one can not determine if the
         connection closed prematurely or not.  The other transfer modes
         (Block, Compressed) do not close the connection to indicate the
         end of file.  They have enough FTP encoding that the data
         connection can be parsed to determine the end of the file.
         Thus using these modes one can leave the data connection open
         for multiple file transfers.

   3.4.  TRANSMISSION MODES

      The next consideration in transferring data is choosing the
      appropriate transmission mode.  There are three modes: one which
      formats the data and allows for restart procedures; one which also
      compresses the data for efficient transfer; and one which passes
      the data with little or no processing.  In this last case the mode
      interacts with the structure attribute to determine the type of
      processing.  In the compressed mode, the representation type
      determines the filler byte.

      All data transfers must be completed with an end-of-file (EOF)
      which may be explicitly stated or implied by the closing of the
      data connection.  For files with record structure, all the
      end-of-record markers (EOR) are explicit, including the final one.
      For files transmitted in page structure a "last-page" page type is
      used.

      NOTE:  In the rest of this section, byte means "transfer byte"
      except where explicitly stated otherwise.

      For the purpose of standardized transfer, the sending host will
      translate its internal end of line or end of record denotation
      into the representation prescribed by the transfer mode and file
      structure, and the receiving host will perform the inverse
      translation to its internal denotation.  An IBM Mainframe record
      count field may not be recognized at another host, so the
      end-of-record information may be transferred as a two byte control
      code in Stream mode or as a flagged bit in a Block or Compressed
      mode descriptor.  End-of-line in an ASCII or EBCDIC file with no
      record structure should be indicated by <CRLF> or <NL>,
      respectively.  Since these transformations imply extra work for
      some systems, identical systems transferring non-record structured
      text files might wish to use a binary representation and stream
      mode for the transfer.






Postel & Reynolds                                              [Page 20]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      The following transmission modes are defined in FTP:

      3.4.1.  STREAM MODE

         The data is transmitted as a stream of bytes.  There is no
         restriction on the representation type used; record structures
         are allowed.

         In a record structured file EOR and EOF will each be indicated
         by a two-byte control code.  The first byte of the control code
         will be all ones, the escape character.  The second byte will
         have the low order bit on and zeros elsewhere for EOR and the
         second low order bit on for EOF; that is, the byte will have
         value 1 for EOR and value 2 for EOF.  EOR and EOF may be
         indicated together on the last byte transmitted by turning both
         low order bits on (i.e., the value 3).  If a byte of all ones
         was intended to be sent as data, it should be repeated in the
         second byte of the control code.

         If the structure is a file structure, the EOF is indicated by
         the sending host closing the data connection and all bytes are
         data bytes.

      3.4.2.  BLOCK MODE

         The file is transmitted as a series of data blocks preceded by
         one or more header bytes.  The header bytes contain a count
         field, and descriptor code.  The count field indicates the
         total length of the data block in bytes, thus marking the
         beginning of the next data block (there are no filler bits).
         The descriptor code defines:  last block in the file (EOF) last
         block in the record (EOR), restart marker (see the Section on
         Error Recovery and Restart) or suspect data (i.e., the data
         being transferred is suspected of errors and is not reliable).
         This last code is NOT intended for error control within FTP.
         It is motivated by the desire of sites exchanging certain types
         of data (e.g., seismic or weather data) to send and receive all
         the data despite local errors (such as "magnetic tape read
         errors"), but to indicate in the transmission that certain
         portions are suspect).  Record structures are allowed in this
         mode, and any representation type may be used.

         The header consists of the three bytes.  Of the 24 bits of
         header information, the 16 low order bits shall represent byte
         count, and the 8 high order bits shall represent descriptor
         codes as shown below.



Postel & Reynolds                                              [Page 21]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         Block Header

            +----------------+----------------+----------------+
            | Descriptor     |    Byte Count                   |
            |         8 bits |                      16 bits    |
            +----------------+----------------+----------------+
            

         The descriptor codes are indicated by bit flags in the
         descriptor byte.  Four codes have been assigned, where each
         code number is the decimal value of the corresponding bit in
         the byte.

            Code     Meaning
            
             128     End of data block is EOR
              64     End of data block is EOF
              32     Suspected errors in data block
              16     Data block is a restart marker

         With this encoding, more than one descriptor coded condition
         may exist for a particular block.  As many bits as necessary
         may be flagged.

         The restart marker is embedded in the data stream as an
         integral number of 8-bit bytes representing printable
         characters in the language being used over the control
         connection (e.g., default--NVT-ASCII).  <SP> (Space, in the
         appropriate language) must not be used WITHIN a restart marker.

         For example, to transmit a six-character marker, the following
         would be sent:

            +--------+--------+--------+
            |Descrptr|  Byte count     |
            |code= 16|             = 6 |
            +--------+--------+--------+

            +--------+--------+--------+
            | Marker | Marker | Marker |
            | 8 bits | 8 bits | 8 bits |
            +--------+--------+--------+

            +--------+--------+--------+
            | Marker | Marker | Marker |
            | 8 bits | 8 bits | 8 bits |
            +--------+--------+--------+


Postel & Reynolds                                              [Page 22]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      3.4.3.  COMPRESSED MODE

         There are three kinds of information to be sent:  regular data,
         sent in a byte string; compressed data, consisting of
         replications or filler; and control information, sent in a
         two-byte escape sequence.  If n>0 bytes (up to 127) of regular
         data are sent, these n bytes are preceded by a byte with the
         left-most bit set to 0 and the right-most 7 bits containing the
         number n.

         Byte string:

             1       7                8                     8
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+     +-+-+-+-+-+-+-+-+
            |0|       n     | |    d(1)       | ... |      d(n)     |
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+     +-+-+-+-+-+-+-+-+
                                          ^             ^
                                          |---n bytes---|
                                              of data

            String of n data bytes d(1),..., d(n)
            Count n must be positive.

         To compress a string of n replications of the data byte d, the
         following 2 bytes are sent:

         Replicated Byte:

              2       6               8
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+
            |1 0|     n     | |       d       |
            +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+

         A string of n filler bytes can be compressed into a single
         byte, where the filler byte varies with the representation
         type.  If the type is ASCII or EBCDIC the filler byte is <SP>
         (Space, ASCII code 32, EBCDIC code 64).  If the type is Image
         or Local byte the filler is a zero byte.

         Filler String:

              2       6
            +-+-+-+-+-+-+-+-+
            |1 1|     n     |
            +-+-+-+-+-+-+-+-+

         The escape sequence is a double byte, the first of which is the


Postel & Reynolds                                              [Page 23]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         escape byte (all zeros) and the second of which contains
         descriptor codes as defined in Block mode.  The descriptor
         codes have the same meaning as in Block mode and apply to the
         succeeding string of bytes.

         Compressed mode is useful for obtaining increased bandwidth on
         very large network transmissions at a little extra CPU cost.
         It can be most effectively used to reduce the size of printer
         files such as those generated by RJE hosts.

   3.5.  ERROR RECOVERY AND RESTART

      There is no provision for detecting bits lost or scrambled in data
      transfer; this level of error control is handled by the TCP.
      However, a restart procedure is provided to protect users from
      gross system failures (including failures of a host, an
      FTP-process, or the underlying network).

      The restart procedure is defined only for the block and compressed
      modes of data transfer.  It requires the sender of data to insert
      a special marker code in the data stream with some marker
      information.  The marker information has meaning only to the
      sender, but must consist of printable characters in the default or
      negotiated language of the control connection (ASCII or EBCDIC).
      The marker could represent a bit-count, a record-count, or any
      other information by which a system may identify a data
      checkpoint.  The receiver of data, if it implements the restart
      procedure, would then mark the corresponding position of this
      marker in the receiving system, and return this information to the
      user.

      In the event of a system failure, the user can restart the data
      transfer by identifying the marker point with the FTP restart
      procedure.  The following example illustrates the use of the
      restart procedure.

      The sender of the data inserts an appropriate marker block in the
      data stream at a convenient point.  The receiving host marks the
      corresponding data point in its file system and conveys the last
      known sender and receiver marker information to the user, either
      directly or over the control connection in a 110 reply (depending
      on who is the sender).  In the event of a system failure, the user
      or controller process restarts the server at the last server
      marker by sending a restart command with server's marker code as
      its argument.  The restart command is transmitted over the control




Postel & Reynolds                                              [Page 24]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      connection and is immediately followed by the command (such as
      RETR, STOR or LIST) which was being executed when the system
      failure occurred.

4.  FILE TRANSFER FUNCTIONS

   The communication channel from the user-PI to the server-PI is
   established as a TCP connection from the user to the standard server
   port.  The user protocol interpreter is responsible for sending FTP
   commands and interpreting the replies received; the server-PI
   interprets commands, sends replies and directs its DTP to set up the
   data connection and transfer the data.  If the second party to the
   data transfer (the passive transfer process) is the user-DTP, then it
   is governed through the internal protocol of the user-FTP host; if it
   is a second server-DTP, then it is governed by its PI on command from
   the user-PI.  The FTP replies are discussed in the next section.  In
   the description of a few of the commands in this section, it is
   helpful to be explicit about the possible replies.

   4.1.  FTP COMMANDS

      4.1.1.  ACCESS CONTROL COMMANDS

         The following commands specify access control identifiers
         (command codes are shown in parentheses).

         USER NAME (USER)

            The argument field is a Telnet string identifying the user.
            The user identification is that which is required by the
            server for access to its file system.  This command will
            normally be the first command transmitted by the user after
            the control connections are made (some servers may require
            this).  Additional identification information in the form of
            a password and/or an account command may also be required by
            some servers.  Servers may allow a new USER command to be
            entered at any point in order to change the access control
            and/or accounting information.  This has the effect of
            flushing any user, password, and account information already
            supplied and beginning the login sequence again.  All
            transfer parameters are unchanged and any file transfer in
            progress is completed under the old access control
            parameters.






Postel & Reynolds                                              [Page 25]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         PASSWORD (PASS)

            The argument field is a Telnet string specifying the user's
            password.  This command must be immediately preceded by the
            user name command, and, for some sites, completes the user's
            identification for access control.  Since password
            information is quite sensitive, it is desirable in general
            to "mask" it or suppress typeout.  It appears that the
            server has no foolproof way to achieve this.  It is
            therefore the responsibility of the user-FTP process to hide
            the sensitive password information.

         ACCOUNT (ACCT)

            The argument field is a Telnet string identifying the user's
            account.  The command is not necessarily related to the USER
            command, as some sites may require an account for login and
            others only for specific access, such as storing files.  In
            the latter case the command may arrive at any time.

            There are reply codes to differentiate these cases for the
            automation: when account information is required for login,
            the response to a successful PASSword command is reply code
            332.  On the other hand, if account information is NOT
            required for login, the reply to a successful PASSword
            command is 230; and if the account information is needed for
            a command issued later in the dialogue, the server should
            return a 332 or 532 reply depending on whether it stores
            (pending receipt of the ACCounT command) or discards the
            command, respectively.

         CHANGE WORKING DIRECTORY (CWD)

            This command allows the user to work with a different
            directory or dataset for file storage or retrieval without
            altering his login or accounting information.  Transfer
            parameters are similarly unchanged.  The argument is a
            pathname specifying a directory or other system dependent
            file group designator.

         CHANGE TO PARENT DIRECTORY (CDUP)

            This command is a special case of CWD, and is included to
            simplify the implementation of programs for transferring
            directory trees between operating systems having different




Postel & Reynolds                                              [Page 26]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            syntaxes for naming the parent directory.  The reply codes
            shall be identical to the reply codes of CWD.  See
            Appendix II for further details.

         STRUCTURE MOUNT (SMNT)

            This command allows the user to mount a different file
            system data structure without altering his login or
            accounting information.  Transfer parameters are similarly
            unchanged.  The argument is a pathname specifying a
            directory or other system dependent file group designator.

         REINITIALIZE (REIN)

            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.  This is identical
            to the state in which a user finds himself immediately after
            the control connection is opened.  A USER command may be
            expected to follow.

         LOGOUT (QUIT)

            This command terminates a USER 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.
            If the user-process is transferring files for several USERs
            but does not wish to close and then reopen connections for
            each, then the REIN command should be used instead of QUIT.

            An unexpected close on the control connection will cause the
            server to take the effective action of an abort (ABOR) and a
            logout (QUIT).

      4.1.2.  TRANSFER PARAMETER COMMANDS

         All data transfer parameters have default values, and the
         commands specifying data transfer parameters are required only
         if the default parameter values are to be changed.  The default
         value is the last specified value, or if no value has been
         specified, the standard default value is as stated here.  This
         implies that the server must "remember" the applicable default
         values.  The commands may be in any order except that they must
         precede the FTP service request.  The following commands
         specify data transfer parameters:


Postel & Reynolds                                              [Page 27]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         DATA PORT (PORT)

            The argument is a HOST-PORT specification for the data port
            to be used in data connection.  There are defaults for both
            the user and server data ports, and under normal
            circumstances this command and its reply are not needed.  If
            this command is used, the argument is the concatenation of a
            32-bit internet host address and a 16-bit TCP port address.
            This address information is broken into 8-bit fields and the
            value of each field is transmitted as a decimal number (in
            character string representation).  The fields are separated
            by commas.  A port command would be:

               PORT h1,h2,h3,h4,p1,p2

            where h1 is the high order 8 bits of the internet host
            address.

         PASSIVE (PASV)

            This command requests the server-DTP to "listen" on a data
            port (which is not its default data port) and to wait for a
            connection rather than initiate one upon receipt of a
            transfer command.  The response to this command includes the
            host and port address this server is listening on.

         REPRESENTATION TYPE (TYPE)

            The argument specifies the representation type as described
            in the Section on Data Representation and Storage.  Several
            types take a second parameter.  The first parameter is
            denoted by a single Telnet character, as is the second
            Format parameter for ASCII and EBCDIC; the second parameter
            for local byte is a decimal integer to indicate Bytesize.
            The parameters are separated by a <SP> (Space, ASCII code
            32).

            The following codes are assigned for type:

                         \    /
               A - ASCII |    | N - Non-print
                         |-><-| T - Telnet format effectors
               E - EBCDIC|    | C - Carriage Control (ASA)
                         /    \
               I - Image
               
               L <byte size> - Local byte Byte size


Postel & Reynolds                                              [Page 28]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            The default representation type is ASCII Non-print.  If the
            Format parameter is changed, and later just the first
            argument is changed, Format then returns to the Non-print
            default.

         FILE STRUCTURE (STRU)

            The argument is a single Telnet character code specifying
            file structure described in the Section on Data
            Representation and Storage.

            The following codes are assigned for structure:

               F - File (no record structure)
               R - Record structure
               P - Page structure

            The default structure is File.

         TRANSFER MODE (MODE)

            The argument is a single Telnet character code specifying
            the data transfer modes described in the Section on
            Transmission Modes.

            The following codes are assigned for transfer modes:

               S - Stream
               B - Block
               C - Compressed

            The default transfer mode is Stream.

      4.1.3.  FTP SERVICE COMMANDS

         The FTP service commands define the file transfer or the file
         system function requested by the user.  The argument of an FTP
         service command will normally be a pathname.  The syntax of
         pathnames must conform to server site conventions (with
         standard defaults applicable), and the language conventions of
         the control connection.  The suggested default handling is to
         use the last specified device, directory or file name, or the
         standard default defined for local users.  The commands may be
         in any order except that a "rename from" command must be
         followed by a "rename to" command and the restart command must
         be followed by the interrupted service command (e.g., STOR or
         RETR).  The data, when transferred in response to FTP service


Postel & Reynolds                                              [Page 29]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         commands, shall always be sent over the data connection, except
         for certain informative replies.  The following commands
         specify FTP service requests:

         RETRIEVE (RETR)

            This command causes the server-DTP to transfer a copy of the
            file, specified in the pathname, to the server- or user-DTP
            at the other end of the data connection.  The status and
            contents of the file at the server site shall be unaffected.

         STORE (STOR)

            This command causes the server-DTP to accept the data
            transferred via the data connection and to store the data as
            a file at the server site.  If the file specified in the
            pathname 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 specified in the
            pathname does not already exist.

         STORE UNIQUE (STOU)

            This command behaves like STOR except that the resultant
            file is to be created in the current directory under a name
            unique to that directory.  The 250 Transfer Started response
            must include the name generated.

         APPEND (with create) (APPE)

            This command causes the server-DTP to accept the data
            transferred via the data connection and to store the data in
            a file at the server site.  If the file specified in the
            pathname 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.

         ALLOCATE (ALLO)

            This command may be required by some servers to reserve
            sufficient storage to accommodate the new file to be
            transferred.  The argument shall be a decimal integer
            representing the number of bytes (using the logical byte
            size) of storage to be reserved for the file.  For files
            sent with record or page structure a maximum record or page
            size (in logical bytes) might also be necessary; this is
            indicated by a decimal integer in a second argument field of


Postel & Reynolds                                              [Page 30]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            the command.  This second argument is optional, but when
            present should be separated from the first by the three
            Telnet characters <SP> R <SP>.  This command shall be
            followed by a STORe or APPEnd command.  The ALLO command
            should be treated as a NOOP (no operation) by those servers
            which do not require that the maximum size of the file be
            declared beforehand, and those servers interested in only
            the maximum record or page size should accept a dummy value
            in the first argument and ignore it.

         RESTART (REST)

            The argument field represents the server marker at which
            file transfer is to be restarted.  This command does not
            cause file transfer but skips over the file to the specified
            data checkpoint.  This command shall be immediately followed
            by the appropriate FTP service command which shall cause
            file transfer to resume.

         RENAME FROM (RNFR)

            This command specifies the old pathname of the file which is
            to be renamed.  This command must be immediately followed by
            a "rename to" command specifying the new file pathname.

         RENAME TO (RNTO)

            This command specifies the new pathname of the file
            specified in the immediately preceding "rename from"
            command.  Together the two commands cause a file to be
            renamed.

         ABORT (ABOR)

            This command tells the server to abort the previous FTP
            service command and any associated transfer of data.  The
            abort command may require "special action", as discussed in
            the Section on FTP Commands, to force recognition by the
            server.  No action is to be taken if the previous command
            has been completed (including data transfer).  The control
            connection is not to be closed by the server, but the data
            connection must be closed.

            There are two cases for the server upon receipt of this
            command: (1) the FTP service command was already completed,
            or (2) the FTP service command is still in progress.



Postel & Reynolds                                              [Page 31]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               In the first case, the server closes the data connection
               (if it is open) and responds with a 226 reply, indicating
               that the abort command was successfully processed.

               In the second case, the server aborts the FTP service in
               progress and closes the data connection, returning a 426
               reply to indicate that the service request terminated
               abnormally.  The server then sends a 226 reply,
               indicating that the abort command was successfully
               processed.

         DELETE (DELE)

            This command causes the file specified in the pathname to be
            deleted at the server site.  If an extra level of protection
            is desired (such as the query, "Do you really wish to
            delete?"), it should be provided by the user-FTP process.

         REMOVE DIRECTORY (RMD)

            This command causes the directory specified in the pathname
            to be removed as a directory (if the pathname is absolute)
            or as a subdirectory of the current working directory (if
            the pathname is relative).  See Appendix II.

         MAKE DIRECTORY (MKD)

            This command causes the directory specified in the pathname
            to be created as a directory (if the pathname is absolute)
            or as a subdirectory of the current working directory (if
            the pathname is relative).  See Appendix II.

         PRINT WORKING DIRECTORY (PWD)

            This command causes the name of the current working
            directory to be returned in the reply.  See Appendix II.

         LIST (LIST)

            This command causes a list to be sent from the server to the
            passive DTP.  If the pathname specifies a directory or other
            group of files, the server should transfer a list of files
            in the specified directory.  If the pathname 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.  The data transfer is over the data
            connection in type ASCII or type EBCDIC.  (The user must


Postel & Reynolds                                              [Page 32]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            ensure that the TYPE is appropriately ASCII or EBCDIC).
            Since the information on a file may vary widely from system
            to system, this information may be hard to use automatically
            in a program, but may be quite useful to a human user.

         NAME LIST (NLST)

            This command causes a directory listing to be sent from
            server to user site.  The pathname should specify a
            directory or other system-specific file group descriptor; a
            null argument implies the current directory.  The server
            will return a stream of names of files and no other
            information.  The data will be transferred in ASCII or
            EBCDIC type over the data connection as valid pathname
            strings separated by <CRLF> or <NL>.  (Again the user must
            ensure that the TYPE is correct.)  This command is intended
            to return information that can be used by a program to
            further process the files automatically.  For example, in
            the implementation of a "multiple get" function.

         SITE PARAMETERS (SITE)

            This command is used by the server to provide services
            specific to his system that are essential to file transfer
            but not sufficiently universal to be included as commands in
            the protocol.  The nature of these services and the
            specification of their syntax can be stated in a reply to
            the HELP SITE command.

         SYSTEM (SYST)

            This command is used to find out the type of operating
            system at the server.  The reply shall have as its first
            word one of the system names listed in the current version
            of the Assigned Numbers document [4].

         STATUS (STAT)

            This command shall cause a status response to be sent over
            the control connection in the form of a reply.  The command
            may be sent during a file transfer (along with the Telnet IP
            and Synch signals--see the Section on FTP Commands) in which
            case the server will respond with the status of the
            operation in progress, or it may be sent between file
            transfers.  In the latter case, the command may have an
            argument field.  If the argument is a pathname, the command
            is analogous to the "list" command except that data shall be


Postel & Reynolds                                              [Page 33]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            transferred over the control connection.  If a partial
            pathname is given, the server may respond with a list of
            file names or attributes associated with that specification.
            If no argument is given, the server should return general
            status information about the server FTP process.  This
            should include current values of all transfer parameters and
            the status of connections.

         HELP (HELP)

            This command shall cause the server to send helpful
            information regarding its implementation status over the
            control connection to the user.  The command may take an
            argument (e.g., any command name) and return more specific
            information as a response.  The reply is type 211 or 214.
            It is suggested that HELP be allowed before entering a USER
            command. The server may use this reply to specify
            site-dependent parameters, e.g., in response to HELP SITE.

         NOOP (NOOP)

            This command does not affect any parameters or previously
            entered commands. It specifies no action other than that the
            server send an OK reply.

   The File Transfer Protocol follows the specifications of the Telnet
   protocol for all communications over the control connection.  Since
   the language used for Telnet communication may be a negotiated
   option, all references in the next two sections will be to the
   "Telnet language" and the corresponding "Telnet end-of-line code".
   Currently, one may take these to mean NVT-ASCII and <CRLF>.  No other
   specifications of the Telnet protocol will be cited.

   FTP commands are "Telnet strings" terminated by the "Telnet end of
   line code".  The command codes themselves are alphabetic characters
   terminated by the character <SP> (Space) if parameters follow and
   Telnet-EOL otherwise.  The command codes and the semantics of
   commands are described in this section; the detailed syntax of
   commands is specified in the Section on Commands, the reply sequences
   are discussed in the Section on Sequencing of Commands and Replies,
   and scenarios illustrating the use of commands are provided in the
   Section on Typical FTP Scenarios.

   FTP commands may be partitioned as those specifying access-control
   identifiers, data transfer parameters, or FTP service requests.
   Certain commands (such as ABOR, STAT, QUIT) may be sent over the
   control connection while a data transfer is in progress.  Some


Postel & Reynolds                                              [Page 34]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   servers may not be able to monitor the control and data connections
   simultaneously, in which case some special action will be necessary
   to get the server's attention.  The following ordered format is
   tentatively recommended:

      1. User system inserts the Telnet "Interrupt Process" (IP) signal
      in the Telnet stream.

      2. User system sends the Telnet "Synch" signal.

      3. User system inserts the command (e.g., ABOR) in the Telnet
      stream.

      4. Server PI, after receiving "IP", scans the Telnet stream for
      EXACTLY ONE FTP command.

   (For other servers this may not be necessary but the actions listed
   above should have no unusual effect.)

   4.2.  FTP REPLIES

      Replies to File Transfer Protocol commands are devised to ensure
      the synchronization of requests and actions in the process of file
      transfer, and to guarantee that the user process always knows the
      state of the Server.  Every command must generate at least one
      reply, although there may be more than one; in the latter case,
      the multiple replies must be easily distinguished.  In addition,
      some commands occur in sequential groups, such as USER, PASS and
      ACCT, or RNFR and RNTO.  The replies show the existence of an
      intermediate state if all preceding commands have been successful.
      A failure at any point in the sequence necessitates the repetition
      of the entire sequence from the beginning.

         The details of the command-reply sequence are made explicit in
         a set of state diagrams below.

      An FTP reply consists of a three digit number (transmitted as
      three alphanumeric characters) followed by some text.  The number
      is intended for use by automata to determine what state to enter
      next; the text is intended for the human user.  It is intended
      that the three digits contain enough encoded information that the
      user-process (the User-PI) will not need to examine the text and
      may either discard it or pass it on to the user, as appropriate.
      In particular, the text may be server-dependent, so there are
      likely to be varying texts for each reply code.

      A reply is defined to contain the 3-digit code, followed by Space


Postel & Reynolds                                              [Page 35]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      <SP>, followed by one line of text (where some maximum line length
      has been specified), and terminated by the Telnet end-of-line
      code.  There will be cases however, where the text is longer than
      a single line.  In these cases the complete text must be bracketed
      so the User-process knows when it may stop reading the reply (i.e.
      stop processing input on the control connection) and go do other
      things.  This requires a special format on the first line to
      indicate that more than one line is coming, and another on the
      last line to designate it as the last.  At least one of these must
      contain the appropriate reply code to indicate the state of the
      transaction.  To satisfy all factions, it was decided that both
      the first and last line codes should be the same.

         Thus the format for multi-line replies is that the first line
         will begin with the exact required reply code, followed
         immediately by a Hyphen, "-" (also known as Minus), followed by
         text.  The last line will begin with the same code, followed
         immediately by Space <SP>, optionally some text, and the Telnet
         end-of-line code.

            For example:
                                123-First line
                                Second line
                                  234 A line beginning with numbers
                                123 The last line

         The user-process then simply needs to search for the second
         occurrence of the same reply code, followed by <SP> (Space), at
         the beginning of a line, and ignore all intermediary lines.  If
         an intermediary line begins with a 3-digit number, the Server
         must pad the front  to avoid confusion.

            This scheme allows standard system routines to be used for
            reply information (such as for the STAT reply), with
            "artificial" first and last lines tacked on.  In rare cases
            where these routines are able to generate three digits and a
            Space at the beginning of any line, the beginning of each
            text line should be offset by some neutral text, like Space.

         This scheme assumes that multi-line replies may not be nested.

      The three digits of the reply each have a special significance.
      This is intended to allow a range of very simple to very
      sophisticated responses by the user-process.  The first digit
      denotes whether the response is good, bad or incomplete.
      (Referring to the state diagram), an unsophisticated user-process
      will be able to determine its next action (proceed as planned,


Postel & Reynolds                                              [Page 36]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      redo, retrench, etc.) by simply examining this first digit.  A
      user-process that wants to know approximately what kind of error
      occurred (e.g. file system error, command syntax error) may
      examine the second digit, reserving the third digit for the finest
      gradation of information (e.g., RNTO command without a preceding
      RNFR).

         There are five values for the first digit of the reply code:

            1yz   Positive Preliminary reply

               The requested action is being initiated; expect another
               reply before proceeding with a new command.  (The
               user-process sending another command before the
               completion reply would be in violation of protocol; but
               server-FTP processes should queue any commands that
               arrive while a preceding command is in progress.)  This
               type of reply can be used to indicate that the command
               was accepted and the user-process may now pay attention
               to the data connections, for implementations where
               simultaneous monitoring is difficult.  The server-FTP
               process may send at most, one 1yz reply per command.

            2yz   Positive Completion reply

               The requested action has been successfully completed.  A
               new request may be initiated.

            3yz   Positive Intermediate reply

               The command has been accepted, but the requested action
               is being held in abeyance, pending receipt of further
               information.  The user should send another command
               specifying this information.  This reply is used in
               command sequence groups.

            4yz   Transient Negative Completion reply

               The command was not accepted and the requested action did
               not take place, but the error condition is temporary and
               the action may be requested again.  The user should
               return to the beginning of the command sequence, if any.
               It is difficult to assign a meaning to "transient",
               particularly when two distinct sites (Server- and
               User-processes) have to agree on the interpretation.
               Each reply in the 4yz category might have a slightly
               different time value, but the intent is that the


Postel & Reynolds                                              [Page 37]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               user-process is encouraged to try again.  A rule of thumb
               in determining if a reply fits into the 4yz or the 5yz
               (Permanent Negative) category is that replies are 4yz if
               the commands can be repeated without any change in
               command form or in properties of the User or Server
               (e.g., the command is spelled the same with the same
               arguments used; the user does not change his file access
               or user name; the server does not put up a new
               implementation.)

            5yz   Permanent Negative Completion reply

               The command was not accepted and the requested action did
               not take place.  The User-process is discouraged from
               repeating the exact request (in the same sequence).  Even
               some "permanent" error conditions can be corrected, so
               the human user may want to direct his User-process to
               reinitiate the command sequence by direct action at some
               point in the future (e.g., after the spelling has been
               changed, or the user has altered his directory status.)

         The following function groupings are encoded in the second
         digit:

            x0z   Syntax - These replies refer to syntax errors,
                  syntactically correct commands that don't fit any
                  functional category, unimplemented or superfluous
                  commands.

            x1z   Information -  These are replies to requests for
                  information, such as status or help.

            x2z   Connections - Replies referring to the control and
                  data connections.

            x3z   Authentication and accounting - Replies for the login
                  process and accounting procedures.

            x4z   Unspecified as yet.

            x5z   File system - These replies indicate the status of the
                  Server file system vis-a-vis the requested transfer or
                  other file system action.

         The third digit gives a finer gradation of meaning in each of
         the function categories, specified by the second digit.  The
         list of replies below will illustrate this.  Note that the text


Postel & Reynolds                                              [Page 38]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         associated with each reply is recommended, rather than
         mandatory, and may even change according to the command with
         which it is associated.  The reply codes, on the other hand,
         must strictly follow the specifications in the last section;
         that is, Server implementations should not invent new codes for
         situations that are only slightly different from the ones
         described here, but rather should adapt codes already defined.

            A command such as TYPE or ALLO whose successful execution
            does not offer the user-process any new information will
            cause a 200 reply to be returned.  If the command is not
            implemented by a particular Server-FTP process because it
            has no relevance to that computer system, for example ALLO
            at a TOPS20 site, a Positive Completion reply is still
            desired so that the simple User-process knows it can proceed
            with its course of action.  A 202 reply is used in this case
            with, for example, the reply text:  "No storage allocation
            necessary."  If, on the other hand, the command requests a
            non-site-specific action and is unimplemented, the response
            is 502.  A refinement of that is the 504 reply for a command
            that is implemented, but that requests an unimplemented
            parameter.

      4.2.1  Reply Codes by Function Groups

         200 Command okay.
         500 Syntax error, command unrecognized.
             This may include errors such as command line too long.
         501 Syntax error in parameters or arguments.
         202 Command not implemented, superfluous at this site.
         502 Command not implemented.
         503 Bad sequence of commands.
         504 Command not implemented for that parameter.
          















Postel & Reynolds                                              [Page 39]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         110 Restart marker reply.
             In this case, the text is exact and not left to the
             particular implementation; it must read:
                  MARK yyyy = mmmm
             Where yyyy is User-process data stream marker, and mmmm
             server's equivalent marker (note the spaces between markers
             and "=").
         211 System status, or system help reply.
         212 Directory status.
         213 File status.
         214 Help message.
             On how to use the server or the meaning of a particular
             non-standard command.  This reply is useful only to the
             human user.
         215 NAME system type.
             Where NAME is an official system name from the list in the
             Assigned Numbers document.
          
         120 Service ready in nnn minutes.
         220 Service ready for new user.
         221 Service closing control connection.
             Logged out if appropriate.
         421 Service not available, closing control connection.
             This may be a reply to any command if the service knows it
             must shut down.
         125 Data connection already open; transfer starting.
         225 Data connection open; no transfer in progress.
         425 Can't open data connection.
         226 Closing data connection.
             Requested file action successful (for example, file
             transfer or file abort).
         426 Connection closed; transfer aborted.
         227 Entering Passive Mode (h1,h2,h3,h4,p1,p2).
          
         230 User logged in, proceed.
         530 Not logged in.
         331 User name okay, need password.
         332 Need account for login.
         532 Need account for storing files.
          









Postel & Reynolds                                              [Page 40]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         150 File status okay; about to open data connection.
         250 Requested file action okay, completed.
         257 "PATHNAME" created.
         350 Requested file action pending further information.
         450 Requested file action not taken.
             File unavailable (e.g., file busy).
         550 Requested action not taken.
             File unavailable (e.g., file not found, no access).
         451 Requested action aborted. Local error in processing.
         551 Requested action aborted. Page type unknown.
         452 Requested action not taken.
             Insufficient storage space in system.
         552 Requested file action aborted.
             Exceeded storage allocation (for current directory or
             dataset).
         553 Requested action not taken.
             File name not allowed.
         

      4.2.2 Numeric  Order List of Reply Codes

         110 Restart marker reply.
             In this case, the text is exact and not left to the
             particular implementation; it must read:
                  MARK yyyy = mmmm
             Where yyyy is User-process data stream marker, and mmmm
             server's equivalent marker (note the spaces between markers
             and "=").
         120 Service ready in nnn minutes.
         125 Data connection already open; transfer starting.
         150 File status okay; about to open data connection.
          

















Postel & Reynolds                                              [Page 41]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         200 Command okay.
         202 Command not implemented, superfluous at this site.
         211 System status, or system help reply.
         212 Directory status.
         213 File status.
         214 Help message.
             On how to use the server or the meaning of a particular
             non-standard command.  This reply is useful only to the
             human user.
         215 NAME system type.
             Where NAME is an official system name from the list in the
             Assigned Numbers document.
         220 Service ready for new user.
         221 Service closing control connection.
             Logged out if appropriate.
         225 Data connection open; no transfer in progress.
         226 Closing data connection.
             Requested file action successful (for example, file
             transfer or file abort).
         227 Entering Passive Mode (h1,h2,h3,h4,p1,p2).
         230 User logged in, proceed.
         250 Requested file action okay, completed.
         257 "PATHNAME" created.
          
         331 User name okay, need password.
         332 Need account for login.
         350 Requested file action pending further information.
          
         421 Service not available, closing control connection.
             This may be a reply to any command if the service knows it
             must shut down.
         425 Can't open data connection.
         426 Connection closed; transfer aborted.
         450 Requested file action not taken.
             File unavailable (e.g., file busy).
         451 Requested action aborted: local error in processing.
         452 Requested action not taken.
             Insufficient storage space in system.
          










Postel & Reynolds                                              [Page 42]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         500 Syntax error, command unrecognized.
             This may include errors such as command line too long.
         501 Syntax error in parameters or arguments.
         502 Command not implemented.
         503 Bad sequence of commands.
         504 Command not implemented for that parameter.
         530 Not logged in.
         532 Need account for storing files.
         550 Requested action not taken.
             File unavailable (e.g., file not found, no access).
         551 Requested action aborted: page type unknown.
         552 Requested file action aborted.
             Exceeded storage allocation (for current directory or
             dataset).
         553 Requested action not taken.
             File name not allowed.
         

5.  DECLARATIVE SPECIFICATIONS

   5.1.  MINIMUM IMPLEMENTATION

      In order to make FTP workable without needless error messages, the
      following minimum implementation is required for all servers:

         TYPE - ASCII Non-print
         MODE - Stream
         STRUCTURE - File, Record
         COMMANDS - USER, QUIT, PORT,
                    TYPE, MODE, STRU,
                      for the default values
                    RETR, STOR,
                    NOOP.

      The default values for transfer parameters are:

         TYPE - ASCII Non-print
         MODE - Stream
         STRU - File

      All hosts must accept the above as the standard defaults.








Postel & Reynolds                                              [Page 43]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   5.2.  CONNECTIONS

      The server protocol interpreter shall "listen" on Port L.  The
      user or user protocol interpreter shall initiate the full-duplex
      control connection.  Server- and user- processes should follow the
      conventions of the Telnet protocol as specified in the
      ARPA-Internet Protocol Handbook [1].  Servers are under no
      obligation to provide for editing of command lines and may require
      that it be done in the user host.  The control connection shall be
      closed by the server at the user's request after all transfers and
      replies are completed.

      The user-DTP must "listen" on the specified data port; this may be
      the default user port (U) or a port specified in the PORT command.
      The server shall initiate the data connection from his own default
      data port (L-1) using the specified user data port.  The direction
      of the transfer and the port used will be determined by the FTP
      service command.

      Note that all FTP implementation must support data transfer using
      the default port, and that only the USER-PI may initiate the use
      of non-default ports.

      When data is to be transferred between two servers, A and B (refer
      to Figure 2), the user-PI, C, sets up control connections with
      both server-PI's.  One of the servers, say A, is then sent a PASV
      command telling him to "listen" on his data port rather than
      initiate a connection when he receives a transfer service command.
      When the user-PI receives an acknowledgment to the PASV command,
      which includes the identity of the host and port being listened
      on, the user-PI then sends A's port, a, to B in a PORT command; a
      reply is returned.  The user-PI may then send the corresponding
      service commands to A and B.  Server B initiates the connection
      and the transfer proceeds.  The command-reply sequence is listed
      below where the messages are vertically synchronous but
      horizontally asynchronous:













Postel & Reynolds                                              [Page 44]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         User-PI - Server A                User-PI - Server B
         ------------------                ------------------
         
         C->A : Connect                    C->B : Connect
         C->A : PASV
         A->C : 227 Entering Passive Mode. A1,A2,A3,A4,a1,a2
                                           C->B : PORT A1,A2,A3,A4,a1,a2
                                           B->C : 200 Okay
         C->A : STOR                       C->B : RETR
                    B->A : Connect to HOST-A, PORT-a

                                Figure 3

      The data connection shall be closed by the server under the
      conditions described in the Section on Establishing Data
      Connections.  If the data connection is to be closed following a
      data transfer where closing the connection is not required to
      indicate the end-of-file, the server must do so immediately.
      Waiting until after a new transfer command is not permitted
      because the user-process will have already tested the data
      connection to see if it needs to do a "listen"; (remember that the
      user must "listen" on a closed data port BEFORE sending the
      transfer request).  To prevent a race condition here, the server
      sends a reply (226) after closing the data connection (or if the
      connection is left open, a "file transfer completed" reply (250)
      and the user-PI should wait for one of these replies before
      issuing a new transfer command).

      Any time either the user or server see that the connection is
      being closed by the other side, it should promptly read any
      remaining data queued on the connection and issue the close on its
      own side.

   5.3.  COMMANDS

      The commands are Telnet character strings transmitted over the
      control connections as described in the Section on FTP Commands.
      The command functions and semantics are described in the Section
      on Access Control Commands, Transfer Parameter Commands, FTP
      Service Commands, and Miscellaneous Commands.  The command syntax
      is specified here.

      The commands begin with a command code followed by an argument
      field.  The command codes are four or fewer alphabetic characters.
      Upper and lower case alphabetic characters are to be treated
      identically.  Thus, any of the following may represent the
      retrieve command:


Postel & Reynolds                                              [Page 45]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


                  RETR    Retr    retr    ReTr    rETr

      This also applies to any symbols representing parameter values,
      such as A or a for ASCII TYPE.  The command codes and the argument
      fields are separated by one or more spaces.

      The argument field consists of a variable length character string
      ending with the character sequence <CRLF> (Carriage Return, Line
      Feed) for NVT-ASCII representation; for other negotiated languages
      a different end of line character might be used.  It should be
      noted that the server is to take no action until the end of line
      code is received.

      The syntax is specified below in NVT-ASCII.  All characters in the
      argument field are ASCII characters including any ASCII
      represented decimal integers.  Square brackets denote an optional
      argument field.  If the option is not taken, the appropriate
      default is implied.































Postel & Reynolds                                              [Page 46]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      5.3.1.  FTP COMMANDS

         The following are the FTP commands:

            USER <SP> <username> <CRLF>
            PASS <SP> <password> <CRLF>
            ACCT <SP> <account-information> <CRLF>
            CWD  <SP> <pathname> <CRLF>
            CDUP <CRLF>
            SMNT <SP> <pathname> <CRLF>
            QUIT <CRLF>
            REIN <CRLF>
            PORT <SP> <host-port> <CRLF>
            PASV <CRLF>
            TYPE <SP> <type-code> <CRLF>
            STRU <SP> <structure-code> <CRLF>
            MODE <SP> <mode-code> <CRLF>
            RETR <SP> <pathname> <CRLF>
            STOR <SP> <pathname> <CRLF>
            STOU <CRLF>
            APPE <SP> <pathname> <CRLF>
            ALLO <SP> <decimal-integer>
                [<SP> R <SP> <decimal-integer>] <CRLF>
            REST <SP> <marker> <CRLF>
            RNFR <SP> <pathname> <CRLF>
            RNTO <SP> <pathname> <CRLF>
            ABOR <CRLF>
            DELE <SP> <pathname> <CRLF>
            RMD  <SP> <pathname> <CRLF>
            MKD  <SP> <pathname> <CRLF>
            PWD  <CRLF>
            LIST [<SP> <pathname>] <CRLF>
            NLST [<SP> <pathname>] <CRLF>
            SITE <SP> <string> <CRLF>
            SYST <CRLF>
            STAT [<SP> <pathname>] <CRLF>
            HELP [<SP> <string>] <CRLF>
            NOOP <CRLF>











Postel & Reynolds                                              [Page 47]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      5.3.2.  FTP COMMAND ARGUMENTS

         The syntax of the above argument fields (using BNF notation
         where applicable) is:

            <username> ::= <string>
            <password> ::= <string>
            <account-information> ::= <string>
            <string> ::= <char> | <char><string>
            <char> ::= any of the 128 ASCII characters except <CR> and
            <LF>
            <marker> ::= <pr-string>
            <pr-string> ::= <pr-char> | <pr-char><pr-string>
            <pr-char> ::= printable characters, any
                          ASCII code 33 through 126
            <byte-size> ::= <number>
            <host-port> ::= <host-number>,<port-number>
            <host-number> ::= <number>,<number>,<number>,<number>
            <port-number> ::= <number>,<number>
            <number> ::= any decimal integer 1 through 255
            <form-code> ::= N | T | C
            <type-code> ::= A [<sp> <form-code>]
                          | E [<sp> <form-code>]
                          | I
                          | L <sp> <byte-size>
            <structure-code> ::= F | R | P
            <mode-code> ::= S | B | C
            <pathname> ::= <string>
            <decimal-integer> ::= any decimal integer




















Postel & Reynolds                                              [Page 48]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   5.4.  SEQUENCING OF COMMANDS AND REPLIES

      The communication between the user and server is intended to be an
      alternating dialogue.  As such, the user issues an FTP command and
      the server responds with a prompt primary reply.  The user should
      wait for this initial primary success or failure response before
      sending further commands.

      Certain commands require a second reply for which the user should
      also wait.  These replies may, for example, report on the progress
      or completion of file transfer or the closing of the data
      connection.  They are secondary replies to file transfer commands.

      One important group of informational replies is the connection
      greetings.  Under normal circumstances, a server will send a 220
      reply, "awaiting input", when the connection is completed.  The
      user should wait for this greeting message before sending any
      commands.  If the server is unable to accept input right away, a
      120 "expected delay" reply should be sent immediately and a 220
      reply when ready.  The user will then know not to hang up if there
      is a delay.

      Spontaneous Replies

         Sometimes "the system" spontaneously has a message to be sent
         to a user (usually all users).  For example, "System going down
         in 15 minutes".  There is no provision in FTP for such
         spontaneous information to be sent from the server to the user.
         It is recommended that such information be queued in the
         server-PI and delivered to the user-PI in the next reply
         (possibly making it a multi-line reply).

      The table below lists alternative success and failure replies for
      each command.  These must be strictly adhered to; a server may
      substitute text in the replies, but the meaning and action implied
      by the code numbers and by the specific command reply sequence
      cannot be altered.

      Command-Reply Sequences

         In this section, the command-reply sequence is presented.  Each
         command is listed with its possible replies; command groups are
         listed together.  Preliminary replies are listed first (with
         their succeeding replies indented and under them), then
         positive and negative completion, and finally intermediary




Postel & Reynolds                                              [Page 49]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


         replies with the remaining commands from the sequence
         following.  This listing forms the basis for the state
         diagrams, which will be presented separately.

            Connection Establishment
               120
                  220
               220
               421
            Login
               USER
                  230
                  530
                  500, 501, 421
                  331, 332
               PASS
                  230
                  202
                  530
                  500, 501, 503, 421
                  332
               ACCT
                  230
                  202
                  530
                  500, 501, 503, 421
               CWD
                  250
                  500, 501, 502, 421, 530, 550
               CDUP
                  200
                  500, 501, 502, 421, 530, 550
               SMNT
                  202, 250
                  500, 501, 502, 421, 530, 550
            Logout
               REIN
                  120
                     220
                  220
                  421
                  500, 502
               QUIT
                  221
                  500




Postel & Reynolds                                              [Page 50]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            Transfer parameters
               PORT
                  200
                  500, 501, 421, 530
               PASV
                  227
                  500, 501, 502, 421, 530
               MODE
                  200
                  500, 501, 504, 421, 530
               TYPE
                  200
                  500, 501, 504, 421, 530
               STRU
                  200
                  500, 501, 504, 421, 530
            File action commands
               ALLO
                  200
                  202
                  500, 501, 504, 421, 530
               REST
                  500, 501, 502, 421, 530
                  350
               STOR
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451, 551, 552
                  532, 450, 452, 553
                  500, 501, 421, 530
               STOU
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451, 551, 552
                  532, 450, 452, 553
                  500, 501, 421, 530
               RETR
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451
                  450, 550
                  500, 501, 421, 530




Postel & Reynolds                                              [Page 51]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


               LIST
                  125, 150
                     226, 250
                     425, 426, 451
                  450
                  500, 501, 502, 421, 530
               NLST
                  125, 150
                     226, 250
                     425, 426, 451
                  450
                  500, 501, 502, 421, 530
               APPE
                  125, 150
                     (110)
                     226, 250
                     425, 426, 451, 551, 552
                  532, 450, 550, 452, 553
                  500, 501, 502, 421, 530
               RNFR
                  450, 550
                  500, 501, 502, 421, 530
                  350
               RNTO
                  250
                  532, 553
                  500, 501, 502, 503, 421, 530
               DELE
                  250
                  450, 550
                  500, 501, 502, 421, 530
               RMD
                  250
                  500, 501, 502, 421, 530, 550
               MKD
                  257
                  500, 501, 502, 421, 530, 550
               PWD
                  257
                  500, 501, 502, 421, 550
               ABOR
                  225, 226
                  500, 501, 502, 421






Postel & Reynolds                                              [Page 52]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


            Informational commands
               SYST
                  215
                  500, 501, 502, 421
               STAT
                  211, 212, 213
                  450
                  500, 501, 502, 421, 530
               HELP
                  211, 214
                  500, 501, 502, 421
            Miscellaneous commands
               SITE
                  200
                  202
                  500, 501, 530
               NOOP
                  200
                  500 421






























Postel & Reynolds                                              [Page 53]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


6.  STATE DIAGRAMS

   Here we present state diagrams for a very simple minded FTP
   implementation.  Only the first digit of the reply codes is used.
   There is one state diagram for each group of FTP commands or command
   sequences.

   The command groupings were determined by constructing a model for
   each command then collecting together the commands with structurally
   identical models.

   For each command or command sequence there are three possible
   outcomes: success (S), failure (F), and error (E).  In the state
   diagrams below we use the symbol B for "begin", and the symbol W for
   "wait for reply".

   We first present the diagram that represents the largest group of FTP
   commands:

      
                               1,3    +---+
                          ----------->| E |
                         |            +---+
                         |
      +---+    cmd    +---+    2      +---+
      | B |---------->| W |---------->| S |
      +---+           +---+           +---+
                         |
                         |     4,5    +---+
                          ----------->| F |
                                      +---+
      

      This diagram models the commands:

         ABOR, ALLO, DELE, CWD, CDUP, SMNT, HELP, MODE, NOOP, PASV,
         QUIT, SITE, PORT, SYST, STAT, RMD, MKD, PWD, STRU, and TYPE.












Postel & Reynolds                                              [Page 54]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The other large group of commands is represented by a very similar
   diagram:

      
                               3      +---+
                          ----------->| E |
                         |            +---+
                         |
      +---+    cmd    +---+    2      +---+
      | B |---------->| W |---------->| S |
      +---+       --->+---+           +---+
                 |     | |
                 |     | |     4,5    +---+
                 |  1  |  ----------->| F |
                  -----               +---+
      

      This diagram models the commands:

         APPE, LIST, NLST, REIN, RETR, STOR, and STOU.

   Note that this second model could also be used to represent the first
   group of commands, the only difference being that in the first group
   the 100 series replies are unexpected and therefore treated as error,
   while the second group expects (some may require) 100 series replies.
   Remember that at most, one 100 series reply is allowed per command.

   The remaining diagrams model command sequences, perhaps the simplest
   of these is the rename sequence:

      
      +---+   RNFR    +---+    1,2    +---+
      | B |---------->| W |---------->| E |
      +---+           +---+        -->+---+
                       | |        |
                3      | | 4,5    |
         --------------  ------   |
        |                      |  |   +---+
        |               ------------->| S |
        |              |   1,3 |  |   +---+
        |             2|  --------
        |              | |     |
        V              | |     |
      +---+   RNTO    +---+ 4,5 ----->+---+
      |   |---------->| W |---------->| F |
      +---+           +---+           +---+
      


Postel & Reynolds                                              [Page 55]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The next diagram is a simple model of the Restart command:

      
      +---+   REST    +---+    1,2    +---+
      | B |---------->| W |---------->| E |
      +---+           +---+        -->+---+
                       | |        |
                3      | | 4,5    |
         --------------  ------   |
        |                      |  |   +---+
        |               ------------->| S |
        |              |   3   |  |   +---+
        |             2|  --------
        |              | |     |
        V              | |     |
      +---+   cmd     +---+ 4,5 ----->+---+
      |   |---------->| W |---------->| F |
      +---+        -->+---+           +---+
                  |      |
                  |  1   |
                   ------
      

         Where "cmd" is APPE, STOR, or RETR.

   We note that the above three models are similar.  The Restart differs
   from the Rename two only in the treatment of 100 series replies at
   the second stage, while the second group expects (some may require)
   100 series replies.  Remember that at most, one 100 series reply is
   allowed per command.



















Postel & Reynolds                                              [Page 56]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The most complicated diagram is for the Login sequence:

      
                            1
      +---+   USER    +---+------------->+---+
      | B |---------->| W | 2       ---->| E |
      +---+           +---+------  |  -->+---+
                       | |       | | |
                     3 | | 4,5   | | |
         --------------   -----  | | |
        |                      | | | |
        |                      | | | |
        |                 ---------  |
        |               1|     | |   |
        V                |     | |   |
      +---+   PASS    +---+ 2  |  ------>+---+
      |   |---------->| W |------------->| S |
      +---+           +---+   ---------->+---+
                       | |   | |     |
                     3 | |4,5| |     |
         --------------   --------   |
        |                    | |  |  |
        |                    | |  |  |
        |                 -----------
        |             1,3|   | |  |
        V                |  2| |  |
      +---+   ACCT    +---+--  |   ----->+---+
      |   |---------->| W | 4,5 -------->| F |
      +---+           +---+------------->+---+




















Postel & Reynolds                                              [Page 57]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   Finally, we present a generalized diagram that could be used to model
   the command and reply interchange:

      
               ------------------------------------
              |                                    |
      Begin   |                                    |
        |     V                                    |
        |   +---+  cmd   +---+ 2         +---+     |
         -->|   |------->|   |---------->|   |     |
            |   |        | W |           | S |-----|
         -->|   |     -->|   |-----      |   |     |
        |   +---+    |   +---+ 4,5 |     +---+     |
        |     |      |    | |      |               |
        |     |      |   1| |3     |     +---+     |
        |     |      |    | |      |     |   |     |
        |     |       ----  |       ---->| F |-----
        |     |             |            |   |
        |     |             |            +---+
         -------------------
              |
              |
              V
             End
      
























Postel & Reynolds                                              [Page 58]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


7.  TYPICAL FTP SCENARIO

   User at host U wanting to transfer files to/from host S:

   In general, the user will communicate to the server via a mediating
   user-FTP process.  The following may be a typical scenario.  The
   user-FTP prompts are shown in parentheses, '---->' represents
   commands from host U to host S, and '<----' represents replies from
   host S to host U.

      LOCAL COMMANDS BY USER              ACTION INVOLVED

      ftp (host) multics<CR>         Connect to host S, port L,
                                     establishing control connections.
                                     <---- 220 Service ready <CRLF>.
      username Doe <CR>              USER Doe<CRLF>---->
                                     <---- 331 User name ok,
                                               need password<CRLF>.
      password mumble <CR>           PASS mumble<CRLF>---->
                                     <---- 230 User logged in<CRLF>.
      retrieve (local type) ASCII<CR>
      (local pathname) test 1 <CR>   User-FTP opens local file in ASCII.
      (for. pathname) test.pl1<CR>   RETR test.pl1<CRLF> ---->
                                     <---- 150 File status okay;
                                           about to open data
                                           connection<CRLF>.
                                     Server makes data connection
                                     to port U.
      
                                     <---- 226 Closing data connection,
                                         file transfer successful<CRLF>.
      type Image<CR>                 TYPE I<CRLF> ---->
                                     <---- 200 Command OK<CRLF>
      store (local type) image<CR>
      (local pathname) file dump<CR> User-FTP opens local file in Image.
      (for.pathname) >udd>cn>fd<CR>  STOR >udd>cn>fd<CRLF> ---->
                                     <---- 550 Access denied<CRLF>
      terminate                      QUIT <CRLF> ---->
                                     Server closes all
                                     connections.

8.  CONNECTION ESTABLISHMENT

   The FTP control connection is established via TCP between the user
   process port U and the server process port L.  This protocol is
   assigned the service port 21 (25 octal), that is L=21.



Postel & Reynolds                                              [Page 59]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


APPENDIX I -  PAGE STRUCTURE

   The need for FTP to support page structure derives principally from
   the  need to support efficient transmission of files between TOPS-20
   systems, particularly the files used by NLS.

   The file system of TOPS-20 is based on the concept of pages.  The
   operating system is most efficient at manipulating files as pages.
   The operating system provides an interface to the file system so that
   many applications view files as sequential streams of characters.
   However, a few applications use the underlying page structures
   directly, and some of these create holey files.

   A TOPS-20 disk file consists of four things: a pathname, a page
   table, a (possibly empty) set of pages, and a set of attributes.

   The pathname is specified in the RETR or STOR command.  It includes
   the directory name, file name, file name extension, and generation
   number.

   The page table contains up to 2**18 entries.  Each entry may be
   EMPTY, or may point to a page.  If it is not empty, there are also
   some page-specific access bits; not all pages of a file need have the
   same access protection.

      A page is a contiguous set of 512 words of 36 bits each.

   The attributes of the file, in the File Descriptor Block (FDB),
   contain such things as creation time, write time, read time, writer's
   byte-size, end-of-file pointer, count of reads and writes, backup
   system tape numbers, etc.

   Note that there is NO requirement that entries in the page table be
   contiguous.  There may be empty page table slots between occupied
   ones.  Also, the end of file pointer is simply a number.  There is no
   requirement that it in fact point at the "last" datum in the file.
   Ordinary sequential I/O calls in TOPS-20 will cause the end of file
   pointer to be left after the last datum written, but other operations
   may cause it not to be so, if a particular programming system so
   requires.

   In fact, in both of these special cases, "holey" files and
   end-of-file pointers NOT at the end of the file, occur with NLS data
   files.





Postel & Reynolds                                              [Page 60]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   The TOPS-20 paged files can be sent with the FTP transfer parameters:
   TYPE L 36, STRU P, and MODE S (in fact, any mode could be used).

   Each page of information has a header.  Each header field, which is a
   logical byte, is a TOPS-20 word, since the TYPE is L 36.

   The header fields are:

      Word 0: Header Length.

         The header length is 5.

      Word 1: Page Index.

         If the data is a disk file page, this is the number of that
         page in the file's page map.  Empty pages (holes) in the file
         are simply not sent.  Note that a hole is NOT the same as a
         page of zeros.

      Word 2: Data Length.

         The number of data words in this page, following the header.
         Thus, the total length of the transmission unit is the Header
         Length plus the Data Length.

      Word 3: Page Type.

         A code for what type of chunk this is.  A data page is type 3,
         the FDB page is type 2.

      Word 4: Page Access Control.

         The access bits associated with the page in the file's page
         map.  (This full word quantity is put into AC2 of an SPACS by
         the program reading from net to disk.)

   After the header are Data Length data words.  Data Length is
   currently either 512 for a data page or 31 for an FDB.  Trailing
   zeros in a disk file page may be discarded, making Data Length less
   than 512 in that case.









Postel & Reynolds                                              [Page 61]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


APPENDIX II -  DIRECTORY COMMANDS

   Since UNIX has a tree-like directory structure in which directories
   are as easy to manipulate as ordinary files, it is useful to expand
   the FTP servers on these machines to include commands which deal with
   the creation of directories.  Since there are other hosts on the
   ARPA-Internet which have tree-like directories (including TOPS-20 and
   Multics), these commands are as general as possible.

      Four directory commands have been added to FTP:

         MKD pathname

            Make a directory with the name "pathname".

         RMD pathname

            Remove the directory with the name "pathname".

         PWD

            Print the current working directory name.

         CDUP

            Change to the parent of the current working directory.

   The  "pathname"  argument should be created (removed) as a
   subdirectory of the current working directory, unless the "pathname"
   string contains sufficient information to specify otherwise to the
   server, e.g., "pathname" is an absolute pathname (in UNIX and
   Multics), or pathname is something like "<abso.lute.path>" to
   TOPS-20.

   REPLY CODES

      The CDUP command is a special case of CWD, and is included to
      simplify the implementation of programs for transferring directory
      trees between operating systems having different syntaxes for
      naming the parent directory.  The reply codes for CDUP be
      identical to the reply codes of CWD.

      The reply codes for RMD be identical to the reply codes for its
      file analogue, DELE.

      The reply codes for MKD, however, are a bit more complicated.  A
      freshly created directory will probably be the object of a future


Postel & Reynolds                                              [Page 62]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      CWD command.  Unfortunately, the argument to MKD may not always be
      a suitable argument for CWD.  This is the case, for example, when
      a TOPS-20 subdirectory is created by giving just the subdirectory
      name.  That is, with a TOPS-20 server FTP, the command sequence

         MKD MYDIR
         CWD MYDIR

      will fail.  The new directory may only be referred to by its
      "absolute" name; e.g., if the MKD command above were issued while
      connected to the directory <DFRANKLIN>, the new subdirectory
      could only be referred to by the name <DFRANKLIN.MYDIR>.

      Even on UNIX and Multics, however, the argument given to MKD may
      not be suitable.  If it is a "relative" pathname (i.e., a pathname
      which is interpreted relative to the current directory), the user
      would need to be in the same current directory in order to reach
      the subdirectory.  Depending on the application, this may be
      inconvenient.  It is not very robust in any case.

      To solve these problems, upon successful completion of an MKD
      command, the server should return a line of the form:

         257<space>"<directory-name>"<space><commentary>

      That is, the server will tell the user what string to use when
      referring to the created  directory.  The directory name can
      contain any character; embedded double-quotes should be escaped by
      double-quotes (the "quote-doubling" convention).

      For example, a user connects to the directory /usr/dm, and creates
      a subdirectory, named pathname:

         CWD /usr/dm
         200 directory changed to /usr/dm
         MKD pathname
         257 "/usr/dm/pathname" directory created

      An example with an embedded double quote:

         MKD foo"bar
         257 "/usr/dm/foo""bar" directory created
         CWD /usr/dm/foo"bar
         200 directory changed to /usr/dm/foo"bar





Postel & Reynolds                                              [Page 63]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      The prior existence of a subdirectory with the same name is an
      error, and the server must return an "access denied" error reply
      in that case.

         CWD /usr/dm
         200 directory changed to /usr/dm
         MKD pathname
         521-"/usr/dm/pathname" directory already exists;
         521 taking no action.

      The failure replies for MKD are analogous to its file  creating
      cousin, STOR.  Also, an "access denied" return is given if a file
      name with the same name as the subdirectory will conflict with the
      creation of the subdirectory (this is a problem on UNIX, but
      shouldn't be one on TOPS-20).

      Essentially because the PWD command returns the same type of
      information as the successful MKD command, the successful PWD
      command uses the 257 reply code as well.

   SUBTLETIES

      Because these commands will be most useful in transferring
      subtrees from one machine to another, carefully observe that the
      argument to MKD is to be interpreted as a sub-directory of  the
      current working directory, unless it contains enough information
      for the destination host to tell otherwise.  A hypothetical
      example of its use in the TOPS-20 world:

         CWD <some.where>
         200 Working directory changed
         MKD overrainbow
         257 "<some.where.overrainbow>" directory created
         CWD overrainbow
         431 No such directory
         CWD <some.where.overrainbow>
         200 Working directory changed

         CWD <some.where>
         200 Working directory changed to <some.where>
         MKD <unambiguous>
         257 "<unambiguous>" directory created
         CWD <unambiguous>

      Note that the first example results in a subdirectory of the
      connected directory.  In contrast, the argument in the second
      example contains enough information for TOPS-20 to tell that  the


Postel & Reynolds                                              [Page 64]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


      <unambiguous> directory is a top-level directory.  Note also that
      in the first example the user "violated" the protocol by
      attempting to access the freshly created directory with a name
      other than the one returned by TOPS-20.  Problems could have
      resulted in this case had there been an <overrainbow> directory;
      this is an ambiguity inherent in some TOPS-20 implementations.
      Similar considerations apply to the RMD command.  The point is
      this: except where to do so would violate a host's conventions for
      denoting relative versus absolute pathnames, the host should treat
      the operands of the MKD and RMD commands as subdirectories.  The
      257 reply to the MKD command must always contain the absolute
      pathname of the created directory.





































Postel & Reynolds                                              [Page 65]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


APPENDIX III - RFCs on FTP

   Bhushan, Abhay, "A File Transfer Protocol", RFC 114 (NIC 5823),
   MIT-Project MAC, 16 April 1971.

   Harslem, Eric, and John Heafner, "Comments on RFC 114 (A File
   Transfer Protocol)", RFC 141 (NIC 6726), RAND, 29 April 1971.

   Bhushan, Abhay, et al, "The File Transfer Protocol", RFC 172
   (NIC 6794), MIT-Project MAC, 23 June 1971.

   Braden, Bob, "Comments on DTP and FTP Proposals", RFC 238 (NIC 7663),
   UCLA/CCN, 29 September 1971.

   Bhushan, Abhay, et al, "The File Transfer Protocol", RFC 265
   (NIC 7813), MIT-Project MAC, 17 November 1971.

   McKenzie, Alex, "A Suggested Addition to File Transfer Protocol",
   RFC 281 (NIC 8163), BBN, 8 December 1971.

   Bhushan, Abhay, "The Use of "Set Data Type" Transaction in File
   Transfer Protocol", RFC 294 (NIC 8304), MIT-Project MAC,
   25 January 1972.

   Bhushan, Abhay, "The File Transfer Protocol", RFC 354 (NIC 10596),
   MIT-Project MAC, 8 July 1972.

   Bhushan, Abhay, "Comments on the File Transfer Protocol (RFC 354)",
   RFC 385 (NIC 11357), MIT-Project MAC, 18 August 1972.

   Hicks, Greg, "User FTP Documentation", RFC 412 (NIC 12404), Utah,
   27 November 1972.

   Bhushan, Abhay, "File Transfer Protocol (FTP) Status and Further
   Comments", RFC 414 (NIC 12406), MIT-Project MAC, 20 November 1972.

   Braden, Bob, "Comments on File Transfer Protocol", RFC 430
   (NIC 13299), UCLA/CCN, 7 February 1973.

   Thomas, Bob, and Bob Clements, "FTP Server-Server Interaction",
   RFC 438 (NIC 13770), BBN, 15 January 1973.

   Braden, Bob, "Print Files in FTP", RFC 448 (NIC 13299), UCLA/CCN,
   27 February 1973.

   McKenzie, Alex, "File Transfer Protocol", RFC 454 (NIC 14333), BBN,
   16 February 1973.


Postel & Reynolds                                              [Page 66]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   Bressler, Bob, and Bob Thomas, "Mail Retrieval via FTP", RFC 458
   (NIC 14378), BBN-NET and BBN-TENEX, 20 February 1973.

   Neigus, Nancy, "File Transfer Protocol", RFC 542 (NIC 17759), BBN,
   12 July 1973.

   Krilanovich, Mark, and George Gregg, "Comments on the File Transfer
   Protocol", RFC 607 (NIC 21255), UCSB, 7 January 1974.

   Pogran, Ken, and Nancy Neigus, "Response to RFC 607 - Comments on the
   File Transfer Protocol", RFC 614 (NIC 21530), BBN, 28 January 1974.

   Krilanovich, Mark, George Gregg, Wayne Hathaway, and Jim White,
   "Comments on the File Transfer Protocol", RFC 624 (NIC 22054), UCSB,
   Ames Research Center, SRI-ARC, 28 February 1974.

   Bhushan, Abhay, "FTP Comments and Response to RFC 430", RFC 463
   (NIC 14573), MIT-DMCG, 21 February 1973.

   Braden, Bob, "FTP Data Compression", RFC 468 (NIC 14742), UCLA/CCN,
   8 March 1973.

   Bhushan, Abhay, "FTP and Network Mail System", RFC 475 (NIC 14919),
   MIT-DMCG, 6 March 1973.

   Bressler, Bob, and Bob Thomas "FTP Server-Server Interaction - II",
   RFC 478 (NIC 14947), BBN-NET and BBN-TENEX, 26 March 1973.

   White, Jim, "Use of FTP by the NIC Journal", RFC 479 (NIC 14948),
   SRI-ARC, 8 March 1973.

   White, Jim, "Host-Dependent FTP Parameters", RFC 480 (NIC 14949),
   SRI-ARC, 8 March 1973.

   Padlipsky, Mike, "An FTP Command-Naming Problem", RFC 506
   (NIC 16157), MIT-Multics, 26 June 1973.

   Day, John, "Memo to FTP Group (Proposal for File Access Protocol)",
   RFC 520 (NIC 16819), Illinois, 25 June 1973.

   Merryman, Robert, "The UCSD-CC Server-FTP Facility", RFC 532
   (NIC 17451), UCSD-CC, 22 June 1973.

   Braden, Bob, "TENEX FTP Problem", RFC 571 (NIC 18974), UCLA/CCN,
   15 November 1973.




Postel & Reynolds                                              [Page 67]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


   McKenzie, Alex, and Jon Postel, "Telnet and FTP Implementation -
   Schedule Change", RFC 593 (NIC 20615), BBN and MITRE,
   29 November 1973.

   Sussman, Julie, "FTP Error Code Usage for More Reliable Mail
   Service", RFC 630 (NIC 30237), BBN, 10 April 1974.

   Postel, Jon, "Revised FTP Reply Codes", RFC 640 (NIC 30843),
   UCLA/NMC, 5 June 1974.

   Harvey, Brian, "Leaving Well Enough Alone", RFC 686 (NIC 32481),
   SU-AI, 10 May 1975.

   Harvey, Brian, "One More Try on the FTP", RFC 691 (NIC 32700), SU-AI,
   28 May 1975.

   Lieb, J., "CWD Command of FTP", RFC 697 (NIC 32963), 14 July 1975.

   Harrenstien, Ken, "FTP Extension: XSEN", RFC 737 (NIC 42217), SRI-KL,
   31 October 1977.

   Harrenstien, Ken, "FTP Extension: XRSQ/XRCP", RFC 743 (NIC 42758),
   SRI-KL, 30 December 1977.

   Lebling, P. David, "Survey of FTP Mail and MLFL", RFC 751, MIT,
   10 December 1978.

   Postel, Jon, "File Transfer Protocol Specification", RFC 765, ISI,
   June 1980.

   Mankins, David, Dan Franklin, and Buzz Owen, "Directory Oriented FTP
   Commands", RFC 776, BBN, December 1980.

   Padlipsky, Michael, "FTP Unique-Named Store Command", RFC 949, MITRE,
   July 1985.














Postel & Reynolds                                              [Page 68]


                                                                        
RFC 959                                                     October 1985
File Transfer Protocol


REFERENCES

   [1]  Feinler, Elizabeth, "Internet Protocol Transition Workbook",
        Network Information Center, SRI International, March 1982.

   [2]  Postel, Jon, "Transmission Control Protocol - DARPA Internet
        Program Protocol Specification", RFC 793, DARPA, September 1981.

   [3]  Postel, Jon, and Joyce Reynolds, "Telnet Protocol
        Specification", RFC 854, ISI, May 1983.

   [4]  Reynolds, Joyce, and Jon Postel, "Assigned Numbers", RFC 943,
        ISI, April 1985.




































Postel & Reynolds                                              [Page 69]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/html/ChangeLog.

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

	* 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  <[email protected]>

	* 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  <[email protected]>

	* html.man: More semantic markup, less visual one.

2002-08-30  Andreas Kupries  <[email protected]>

	* html.tcl: Updated 'info exist' to 'info exists'.

2002-06-03  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl:
	* html.tcl:
	* html.n:
	* html.man: Bumped to version 1.2.1.

2002-04-10  Andreas Kupries  <[email protected]>

	* html.man: Added doctools manpage.

2002-02-14  Joe English  <[email protected]>

	* html.n: Remove mention of (unimplemented, undocumented) 
	  formatCode procedure (SF BUG #461434).

2002-01-15  Andreas Kupries  <[email protected]>

	* Bumped version to 1.2

2002-01-11  Andreas Kupries <[email protected]>

	* html.n:
	* html.tcl: Accepted patch #484117 provided by Decoster Jos
	  <[email protected]> providing two new function
	  to generated lists and parameterized table rows.

2001-10-16  Andreas Kupries <[email protected]>

	* html.n:
	* html.test:
	* html.tcl:
	* pkgIndex.tcl: Version up to 1.1.1

2001-08-01  Jeff Hobbs  <[email protected]>

	* html.tcl: added 8.1+ improved version of quoteFormValue.

2001-07-10  Andreas Kupries <[email protected]>

	* html.tcl: Frink 2.2 run, fixed dubious code.

2001-06-19  Melissa Chawla <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

        * 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 <[email protected]>

	* 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 <[email protected]>

	* modules/html/html.tcl, html.n: Added html::passwordInputRow

2000-07-24  Brent Welch <[email protected]>

	* 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 <[email protected]>

	* modules/html/html.tcl: Added html::headTag to add any tag
	to the HEAD section generated by html::head.

2000-05-16  Brent Welch <[email protected]>

	* modules/html/html.tcl: Added html::refresh to generate
	META tags that cause a page to refresh.

2000-04-26  Brent Welch <[email protected]>

	* html/html.tcl:  Added urlResove and urlParent URL parsing
	routines.

2000-04-26  Brent Welch <[email protected]>

	* html/html.tcl: track name changes in ncgi

2000-04-24  Brent Welch  <[email protected]>
	
	* 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

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































Deleted modules/html/html.man.

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


[call [cmd ::html::checkbox] [arg {name value}]]

Generate a 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 CHECKBOX form elements and associated labels.  The
[arg list] should contain an alternating list of labels and values.
This uses [cmd ::html::checkbox].


[call [cmd ::html::checkValue] [arg name] [opt [arg value]]]

Generate the "name=[arg name] value=[arg value] for a 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 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 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:

[nl]
[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 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., H1) 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 H1 tag.  See [cmd ::html::h].

[call [cmd ::html::h2] [arg string] [opt [arg param]]]

Generate an H2 tag.  See [cmd ::html::h].

[call [cmd ::html::h3] [arg string] [opt [arg param]]]

Generate an H3 tag.  See [cmd ::html::h].

[call [cmd ::html::h4] [arg string] [opt [arg param]]]

Generate an H4 tag.  See [cmd ::html::h].

[call [cmd ::html::h5] [arg string] [opt [arg param]]]

Generate an H5 tag.  See [cmd ::html::h].

[call [cmd ::html::h6] [arg string] [opt [arg param]]]

Generate an H6 tag.  See [cmd ::html::h].


[call [cmd ::html::hdrRow] [arg args]]

Generate a table row, including TR and 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 HEAD section that includes the page 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 HEAD section.
This leaves an open HTML tag pushed on the stack with
[cmd ::html::openTag].


[call [cmd ::html::headTag] [arg string]]

Save a tag for inclusion in the HEAD section generated by

[cmd ::html::head].  The [arg string] is everything in the tag except
the enclosing angle brackets, < >.


[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::keywords] [arg args]]

[emph {Side effect only}].  Call this before [cmd ::html::head] to
define a keyword META tag for the page.  The 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 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
META tag.  The META tag is included in the result of

[cmd ::html::head].


[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::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::openTag] [arg {tag args}]]

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.


[call [cmd ::html::passwordInput] [opt [arg name]]]

Generate an INPUT tag of type 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 INPUT tag of type
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 INPUT tags of type 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 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 META tag. Call this before [cmd ::html::head] and the
HEAD section will contain a 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::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 BODY tag.


[call [cmd ::html::row] [arg args]]

Generate a table row, including TR and TD tags.  Each value in

[arg args] is place into its own table cell. This uses

[cmd ::html::cell].


[call [cmd ::html::paramRow] [arg list] [opt [arg rparam]] [opt [arg cparam]]]

Generate a table row, including TR and 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 TR tag. The value of [arg cparam] is passed to [cmd ::html::cell]
as parameter for the TD tags.


[call [cmd ::html::select] [arg {name param choices}] [opt [arg current]]]

Generate a SELECT form element and nested OPTION tags. The [arg name]
and [arg param] are used to generate the 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 OPTION tags.  The label and the value for each
OPTION are the same.

[call [cmd ::html::submit] [arg label] [opt [arg name]]]

Generate an INPUT tag of type SUBMIT. [arg name] defaults to "submit".


[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::tableFromArray] [arg arrname] [opt [arg param]] [opt [arg pat]]]

Generate a TABLE and nested rows to display a Tcl array. The

[arg param] are for the TABLE tag. The [arg pat] is a

[cmd {string match}] pattern used to select array elements. It
defaults to "*".


[call [cmd ::html::tableFromList] [arg querylist] [opt [arg param]]]

Generate a TABLE and nested rows to display [arg querylist], which is
a Tcl-style name, value list.  The [arg param] are for the TABLE tag.


[call [cmd ::html::textarea] [arg name] [opt [arg param]] [opt [arg current]]]

Generate a TEXTAREA tag wrapped around its current values.


[call [cmd ::html::textInput] [arg {name value args}]]

Generate an INPUT form tag with type TEXT.  This uses

[cmd ::html::formValue].  The args is any additional tag attributes
you want to put into the INPUT tag.


[call [cmd ::html::textInputRow] [arg {label name value args}]]

Generate an INPUT form tag with type TEXT formatted into a table row
with an associated label.  The args is any additional tag attributes
you want to put into the INPUT tag.


[call [cmd ::html::title] [arg title]]

[emph {Side effect only}].  Call this before [cmd ::html::head] to
define the 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.

[list_end]

[see_also ncgi htmlparse]
[keywords html form table checkbox radiobutton checkbutton]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/html/html.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
'\"
'\" Generated from html.man by mpexpand with fmt.nroff
'\"
.so man.macros
.TH "html" n 1.2.1 html "HTML Generation"
.BS
.SH NAME
html \- Procedures to generate HTML structures
'\" -*- tcl -*- doctools manpage
.SH "SYNOPSIS"
package require \fBTcl 8.2\fR
.sp
package require \fBhtml ?1.2.1?\fR
.sp
\fB::html::author\fR \fIauthor\fR\fR
.sp
\fB::html::bodyTag\fR \fIargs\fR\fR
.sp
\fB::html::cell\fR \fIparam value\fR ?\fItag\fR?\fR
.sp
\fB::html::checkbox\fR \fIname value\fR\fR
.sp
\fB::html::checkSet\fR \fIkey sep list\fR\fR
.sp
\fB::html::checkValue\fR \fIname\fR ?\fIvalue\fR?\fR
.sp
\fB::html::closeTag\fR \fR
.sp
\fB::html::default\fR \fIkey\fR ?\fIparam\fR?\fR
.sp
\fB::html::description\fR \fIdescription\fR\fR
.sp
\fB::html::end\fR \fR
.sp
\fB::html::eval\fR \fIarg\fR ?\fIargs\fR?\fR
.sp
\fB::html::extractParam\fR \fIparam key\fR ?\fIvarName\fR?\fR
.sp
\fB::html::font\fR \fIargs\fR\fR
.sp
\fB::html::for\fR \fIstart test next body\fR\fR
.sp
\fB::html::foreach\fR \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR\fR
.sp
\fB::html::formValue\fR \fIname\fR ?\fIdefvalue\fR?\fR
.sp
\fB::html::getFormInfo\fR \fIargs\fR\fR
.sp
\fB::html::getTitle\fR \fR
.sp
\fB::html::h\fR \fIlevel string\fR ?\fIparam\fR?\fR
.sp
\fB::html::h1\fR \fIstring\fR ?\fIparam\fR?\fR
.sp
\fB::html::h2\fR \fIstring\fR ?\fIparam\fR?\fR
.sp
\fB::html::h3\fR \fIstring\fR ?\fIparam\fR?\fR
.sp
\fB::html::h4\fR \fIstring\fR ?\fIparam\fR?\fR
.sp
\fB::html::h5\fR \fIstring\fR ?\fIparam\fR?\fR
.sp
\fB::html::h6\fR \fIstring\fR ?\fIparam\fR?\fR
.sp
\fB::html::hdrRow\fR \fIargs\fR\fR
.sp
\fB::html::head\fR \fItitle\fR\fR
.sp
\fB::html::headTag\fR \fIstring\fR\fR
.sp
\fB::html::if\fR \fIexpr1 body1\fR ?\fBelseif\fR \fIexpr2 body2 ...\fR? ?\fBelse\fR \fIbodyN\fR?\fR
.sp
\fB::html::keywords\fR \fIargs\fR\fR
.sp
\fB::html::mailto\fR \fIemail\fR ?\fIsubject\fR?\fR
.sp
\fB::html::meta\fR \fIargs\fR\fR
.sp
\fB::html::minorMenu\fR \fIlist\fR ?\fIsep\fR?\fR
.sp
\fB::html::minorList\fR \fIlist\fR ?\fIordered\fR?\fR
.sp
\fB::html::openTag\fR \fItag args\fR\fR
.sp
\fB::html::passwordInput\fR ?\fIname\fR?\fR
.sp
\fB::html::passwordInputRow\fR \fIlabel\fR ?\fIname\fR?\fR
.sp
\fB::html::quoteFormValue\fR \fIvalue\fR\fR
.sp
\fB::html::radioSet\fR \fIkey sep list\fR\fR
.sp
\fB::html::radioValue\fR \fIname value\fR\fR
.sp
\fB::html::refresh\fR \fIseconds url\fR\fR
.sp
\fB::html::init\fR ?\fIlist\fR?\fR
.sp
\fB::html::row\fR \fIargs\fR\fR
.sp
\fB::html::paramRow\fR \fIlist\fR ?\fIrparam\fR? ?\fIcparam\fR?\fR
.sp
\fB::html::select\fR \fIname param choices\fR ?\fIcurrent\fR?\fR
.sp
\fB::html::selectPlain\fR \fIname param choices\fR ?\fIcurrent\fR?\fR
.sp
\fB::html::submit\fR \fIlabel\fR ?\fIname\fR?\fR
.sp
\fB::html::set\fR \fIvar val\fR\fR
.sp
\fB::html::tableFromArray\fR \fIarrname\fR ?\fIparam\fR? ?\fIpat\fR?\fR
.sp
\fB::html::tableFromList\fR \fIquerylist\fR ?\fIparam\fR?\fR
.sp
\fB::html::textarea\fR \fIname\fR ?\fIparam\fR? ?\fIcurrent\fR?\fR
.sp
\fB::html::textInput\fR \fIname value args\fR\fR
.sp
\fB::html::textInputRow\fR \fIlabel name value args\fR\fR
.sp
\fB::html::title\fR \fItitle\fR\fR
.sp
\fB::html::varEmpty\fR \fIname\fR\fR
.sp
\fB::html::while\fR \fItest body\fR\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
The package \fBhtml\fR provides commands that generate HTML.
These commands typically return an HTML string as their result. In
particular, they do not output their result to \fBstdout\fR.
.PP
The command \fB::html::init\fR should be called early to initialize
the module.  You can also use this procedure to define default values
for HTML tag parameters.
.TP
\fB::html::author\fR \fIauthor\fR\fR
\fBSide effect only\fR.  Call this before \fB::html::head\fR to
define an author for the page.  The author is noted in a comment in
the HEAD section.
.TP
\fB::html::bodyTag\fR \fIargs\fR\fR
Generate a BODY tag.  The tag parameters are taken from \fIargs\fR or
from the body.* attributes define with \fB::html::init\fR.
.TP
\fB::html::cell\fR \fIparam value\fR ?\fItag\fR?\fR
Generate a TD (or TH) tag, a value, and a closing TD (or TH) tag. The
tag parameters come from \fIparam\fR or TD.* attributes defined with
\fB::html::init\fR.  This uses \fB::html::font\fR to insert a standard
FONT tag into the table cell. The \fItag\fR argument defaults to "td".
.TP
\fB::html::checkbox\fR \fIname value\fR\fR
Generate a CHECKBOX form element with the specified name and value.
This uses \fB::html::checkValue\fR.
.TP
\fB::html::checkSet\fR \fIkey sep list\fR\fR
Generate a set of CHECKBOX form elements and associated labels.  The
\fIlist\fR should contain an alternating list of labels and values.
This uses \fB::html::checkbox\fR.
.TP
\fB::html::checkValue\fR \fIname\fR ?\fIvalue\fR?\fR
Generate the "name=\fIname\fR value=\fIvalue\fR for a CHECKBOX form
element.  If the CGI variable \fIname\fR has the value \fIvalue\fR,
then SELECTED is added to the return value. \fIvalue\fR defaults to
"1".
.TP
\fB::html::closeTag\fR \fR
Pop a tag off the stack created by \fB::html::openTag\fR and generate
the corresponding close tag (e.g., /BODY).
.TP
\fB::html::default\fR \fIkey\fR ?\fIparam\fR?\fR
This procedure is used by \fB::html::tagParam\fR to generate the name,
value list of parameters for a tag.  The \fB::html::default\fR
procedure is used to generate default values for those items not
already in \fIparam\fR.  If the value identified by \fIkey\fR matches
a value in \fIparam\fR then this procedure returns the empty string.
Otherwise, it returns a "parameter=value" string for a form element
identified by \fIkey\fR.  The \fIkey\fR has the form "tag.parameter"
(e.g., body.bgcolor).  Use \fB::html::init\fR to register default
values. \fIparam\fR defaults to the empty string.
.TP
\fB::html::description\fR \fIdescription\fR\fR
\fBSide effect only\fR.  Call this before \fB::html::head\fR to
define a description META tag for the page.  This tag is generated
later in the call to \fB::html::head\fR.
.TP
\fB::html::end\fR \fR
Pop all open tags from the stack and generate the corresponding close
HTML tags, (e.g., </body></html>).
.TP
\fB::html::eval\fR \fIarg\fR ?\fIargs\fR?\fR
This procedure is similar to the built-in Tcl \fBeval\fR command.  The
only difference is that it returns "" so it can be called from an HTML
template file without appending unwanted results.
.TP
\fB::html::extractParam\fR \fIparam key\fR ?\fIvarName\fR?\fR
This is a parsing procedure that extracts the value of \fIkey\fR from
\fIparam\fR, which is a HTML-style "name=quotedvalue" list.
\fIvarName\fR 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 \fIparam\fR, otherwise it returns 0.  If the
\fIvarName\fR is not specified, then \fIkey\fR is used as the variable
name.
.TP
\fB::html::font\fR \fIargs\fR\fR
Generate a standard FONT tag.  The parameters to the tag are taken
from \fIargs\fR and the HTML defaults defined with \fB::html::init\fR.
.TP
\fB::html::for\fR \fIstart test next body\fR\fR
This procedure is similar to the built-in Tcl \fBfor\fR control
structure.  Rather than evaluating the body, it returns the subst'ed
\fIbody\fR. Each iteration of the loop causes another string to be
concatenated to the result value.
.TP
\fB::html::foreach\fR \fIvarlist1 list1\fR ?\fIvarlist2 list2 ...\fR? \fIbody\fR\fR
This procedure is similar to the built-in Tcl \fBforeach\fR control
structure.  Rather than evaluating the body, it returns the subst'ed
\fIbody\fR.  Each iteration of the loop causes another string to be
concatenated to the result value.
.TP
\fB::html::formValue\fR \fIname\fR ?\fIdefvalue\fR?\fR
Return a name and value pair, where the value is initialized from
existing CGI data, if any.  The result has this form:
.sp
.nf
  name="fred" value="freds value"
.fi
.TP
\fB::html::getFormInfo\fR \fIargs\fR\fR
Generate hidden fields to capture form values.  If \fIargs\fR is
empty, then hidden fields are generated for all CGI values.  Otherwise
args is a list of string match patterns for form element names.
.TP
\fB::html::getTitle\fR \fR
Return the title string, with out the surrounding TITLE tag, set with
a previous call to \fB::html::title\fR.
.TP
\fB::html::h\fR \fIlevel string\fR ?\fIparam\fR?\fR
Generate a heading (e.g., H1) tag.  The \fIstring\fR is nested in the
heading, and \fIparam\fR is used for the tag parameters.
.TP
\fB::html::h1\fR \fIstring\fR ?\fIparam\fR?\fR
Generate an H1 tag.  See \fB::html::h\fR.
.TP
\fB::html::h2\fR \fIstring\fR ?\fIparam\fR?\fR
Generate an H2 tag.  See \fB::html::h\fR.
.TP
\fB::html::h3\fR \fIstring\fR ?\fIparam\fR?\fR
Generate an H3 tag.  See \fB::html::h\fR.
.TP
\fB::html::h4\fR \fIstring\fR ?\fIparam\fR?\fR
Generate an H4 tag.  See \fB::html::h\fR.
.TP
\fB::html::h5\fR \fIstring\fR ?\fIparam\fR?\fR
Generate an H5 tag.  See \fB::html::h\fR.
.TP
\fB::html::h6\fR \fIstring\fR ?\fIparam\fR?\fR
Generate an H6 tag.  See \fB::html::h\fR.
.TP
\fB::html::hdrRow\fR \fIargs\fR\fR
Generate a table row, including TR and TH tags.
Each value in \fIargs\fR is place into its own table cell.
This uses \fB::html::cell\fR.
.TP
\fB::html::head\fR \fItitle\fR\fR
Generate the HEAD section that includes the page TITLE.
If previous calls have been made to
\fB::html::author\fR,
\fB::html::keywords\fR,
\fB::html::description\fR,
or
\fB::html::meta\fR
then additional tags are inserted into the HEAD section.
This leaves an open HTML tag pushed on the stack with
\fB::html::openTag\fR.
.TP
\fB::html::headTag\fR \fIstring\fR\fR
Save a tag for inclusion in the HEAD section generated by
\fB::html::head\fR.  The \fIstring\fR is everything in the tag except
the enclosing angle brackets, < >.
.TP
\fB::html::if\fR \fIexpr1 body1\fR ?\fBelseif\fR \fIexpr2 body2 ...\fR? ?\fBelse\fR \fIbodyN\fR?\fR
This procedure is similar to the built-in Tcl \fBif\fR control
structure.  Rather than evaluating the body of the branch that is
taken, it returns the subst'ed \fIbody\fR.  Note that the syntax is
slightly more restrictive than that of the built-in Tcl \fBif\fR
control structure.
.TP
\fB::html::keywords\fR \fIargs\fR\fR
\fBSide effect only\fR.  Call this before \fB::html::head\fR to
define a keyword META tag for the page.  The META tag is included in
the result of \fB::html::head\fR.
.TP
\fB::html::mailto\fR \fIemail\fR ?\fIsubject\fR?\fR
Generate a hypertext link to a mailto: URL.
.TP
\fB::html::meta\fR \fIargs\fR\fR
\fBSide effect only\fR.  Call this before \fB::html::head\fR to
define a META tag for the page.  The \fIargs\fR is a Tcl-style name,
value list that is used for the name= and value= parameters for the
META tag.  The META tag is included in the result of
\fB::html::head\fR.
.TP
\fB::html::minorMenu\fR \fIlist\fR ?\fIsep\fR?\fR
Generate a series of hypertext links.  The \fIlist\fR is a Tcl-style
name, value list of labels and urls for the links.  The \fIsep\fR is
the text to put between each link. It defaults to " | ".
.TP
\fB::html::minorList\fR \fIlist\fR ?\fIordered\fR?\fR
Generate an ordered or unordered list of links.  The \fIlist\fR is a
Tcl-style name, value list of labels and urls for the links.
\fIordered\fR is a boolean used to choose between an ordered or
unordered list. It defaults to \fBfalse\fR.
.TP
\fB::html::openTag\fR \fItag args\fR\fR
Push \fItag\fR onto a stack and generate the opening tag for
\fItag\fR.  Use \fB::html::closeTag\fR to pop the tag from the stack.
.TP
\fB::html::passwordInput\fR ?\fIname\fR?\fR
Generate an INPUT tag of type PASSWORD. The \fIname\fR defaults to
"password".
.TP
\fB::html::passwordInputRow\fR \fIlabel\fR ?\fIname\fR?\fR
Format a table row containing a label and an INPUT tag of type
PASSWORD. The \fIname\fR defaults to "password".
.TP
\fB::html::quoteFormValue\fR \fIvalue\fR\fR
Quote special characters in \fIvalue\fR by replacing them with HTML
entities for quotes, ampersand, and angle brackets.
.TP
\fB::html::radioSet\fR \fIkey sep list\fR\fR
Generate a set of INPUT tags of type RADIO and an associated text
label.  All the radio buttons share the same \fIkey\fR for their name.
The \fIsep\fR is text used to separate the elements.  The \fIlist\fR
is a Tcl-style label, value list.
.TP
\fB::html::radioValue\fR \fIname value\fR\fR
Generate the "name=\fIname\fR value=\fIvalue\fR for a RADIO form
element.  If the CGI variable \fIname\fR has the value \fIvalue\fR,
then SELECTED is added to the return value.
.TP
\fB::html::refresh\fR \fIseconds url\fR\fR
Set up a refresh META tag. Call this before \fB::html::head\fR and the
HEAD section will contain a META tag that causes the document to
refresh in \fIseconds\fR seconds.  The \fIurl\fR is optional.  If
specified, it specifies a new page to load after the refresh interval.
.TP
\fB::html::init\fR ?\fIlist\fR?\fR
\fB::html::init\fR 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 BODY tag.
.TP
\fB::html::row\fR \fIargs\fR\fR
Generate a table row, including TR and TD tags.  Each value in
\fIargs\fR is place into its own table cell. This uses
\fB::html::cell\fR.
.TP
\fB::html::paramRow\fR \fIlist\fR ?\fIrparam\fR? ?\fIcparam\fR?\fR
Generate a table row, including TR and TD tags. Each value in
\fIlist\fR is placed into its own table cell. This uses
\fB::html::cell\fR. The value of \fIrparam\fR is used as parameter for
the TR tag. The value of \fIcparam\fR is passed to \fB::html::cell\fR
as parameter for the TD tags.
.TP
\fB::html::select\fR \fIname param choices\fR ?\fIcurrent\fR?\fR
Generate a SELECT form element and nested OPTION tags. The \fIname\fR
and \fIparam\fR are used to generate the SELECT tag. The \fIchoices\fR
list is a Tcl-style name, value list.
.TP
\fB::html::selectPlain\fR \fIname param choices\fR ?\fIcurrent\fR?\fR
Like \fB::html::select\fR except that \fIchoices\fR is a Tcl list of
values used for the OPTION tags.  The label and the value for each
OPTION are the same.
.TP
\fB::html::submit\fR \fIlabel\fR ?\fIname\fR?\fR
Generate an INPUT tag of type SUBMIT. \fIname\fR defaults to "submit".
.TP
\fB::html::set\fR \fIvar val\fR\fR
This procedure is similar to the built-in Tcl \fBset\fR 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.
.TP
\fB::html::tableFromArray\fR \fIarrname\fR ?\fIparam\fR? ?\fIpat\fR?\fR
Generate a TABLE and nested rows to display a Tcl array. The
\fIparam\fR are for the TABLE tag. The \fIpat\fR is a
\fBstring match\fR pattern used to select array elements. It
defaults to "*".
.TP
\fB::html::tableFromList\fR \fIquerylist\fR ?\fIparam\fR?\fR
Generate a TABLE and nested rows to display \fIquerylist\fR, which is
a Tcl-style name, value list.  The \fIparam\fR are for the TABLE tag.
.TP
\fB::html::textarea\fR \fIname\fR ?\fIparam\fR? ?\fIcurrent\fR?\fR
Generate a TEXTAREA tag wrapped around its current values.
.TP
\fB::html::textInput\fR \fIname value args\fR\fR
Generate an INPUT form tag with type TEXT.  This uses
\fB::html::formValue\fR.  The args is any additional tag attributes
you want to put into the INPUT tag.
.TP
\fB::html::textInputRow\fR \fIlabel name value args\fR\fR
Generate an INPUT form tag with type TEXT formatted into a table row
with an associated label.  The args is any additional tag attributes
you want to put into the INPUT tag.
.TP
\fB::html::title\fR \fItitle\fR\fR
\fBSide effect only\fR.  Call this before \fB::html::head\fR to
define the TITLE for a page.
.TP
\fB::html::varEmpty\fR \fIname\fR\fR
This returns 1 if the named variable either does not exist or has the
empty string for its value.
.TP
\fB::html::while\fR \fItest body\fR\fR
This procedure is similar to the built-in Tcl \fBwhile\fR control
structure.  Rather than evaluating the body, it returns the subst'ed
\fIbody\fR.  Each iteration of the loop causes another string to be
concatenated to the result value.
.SH "SEE ALSO"
ncgi, htmlparse
.SH "KEYWORDS"
html, form, table, checkbox, radiobutton, checkbutton
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/html/html.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
# 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.
#
# 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.2.2

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 *
}

# ::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 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::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 $resultVar tmp
    ::set tmp ""
    uplevel $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 $resultVar tmp
    ::set tmp ""
    uplevel $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 $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 uplevel $args
    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"
	}
    }
    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\" value=\"[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 "\">\n"
    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} {
    variable defaults
    ::set html "<input type=\"text\" "
    append html [formValue $name $value]
    append html [default input.size]
    ::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} {
    variable defaults
    ::set html [row $label [::eval [list html::textInput $name $value] $args]]
    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}} {
    variable defaults
    ::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}} {
    variable page
    ::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 {}}} {
    variable page

    ::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 [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} {
    variable defaults

    # e.g., font.face, font.size, font.color
    ::set param [tagParam font [join $args]][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 { | }}} {
    global page
    ::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}} {
    global page
    ::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
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/html/html.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
# 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.
#
# 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.13 2002/12/02 04:11:28 gwlester Exp $

package require tcltest
namespace import -force ::tcltest::*

set myFile [file join [file dirname [info script]] html.tcl]
source $myFile
package require html 1.2

#source [file join [file dirname [info script]] ../ncgi/ncgi.tcl]
#package require ncgi

test html-1.1 {html::init} {
    html::init
    list [array exists html::defaults] \
	[array size html::defaults] \
	[info exists html::page]
} {1 0 0}

test html-1.2 {html::init} {
    html::init {
	font.face	arial
	body.bgcolor	white
	body.text	black
    }
    lsort [array names html::defaults]
} {body.bgcolor body.text font.face}

test html-1.3 {html::init} {
    catch {html::init wrong num args}
} 1

test html-1.4 {html::init} {
    catch {html::init {wrong num args}}
} 1

test html-2.1 {html::head} {
    catch {html::head}
} 1

test html-2.2 {html::head} {
    html::head "The Title"
} "<html><head>\n\t<title>The Title</title>\n</head>\n"

test html-2.3 {html::head} {
    html::description "The Description"
    html::keywords key word
    html::author "Cathy Coder"
    html::meta metakey metavalue
    html::head "The Title"
} {<html><head>
	<title>The Title</title>
	<!-- Cathy Coder -->
	<meta name="description" value="The Description">
	<meta name="keywords" value="key, word">
	<meta name="metakey" value="metavalue">
</head>
}

test html-3.1 {html::title} {
    catch html::title
} 1

test html-3.2 {html::title} {
    html::title "blah blah"
} "<title>blah blah</title>\n"

test html-4.1 {html::getTitle} {
    html::init
    html::getTitle
} ""

test html-4.2 {html::getTitle} {
    html::init
    html::title "blah blah"
    html::getTitle
} {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" value="two">}

test html-5.3 {html::meta} {
    html::init
    html::meta one {"one val"}
    lindex $html::page(meta) 0
} {<meta name="one" value="&#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" value="one, two">}

test html-6.3 {html::keywords} {
    html::init
    html::keywords one {"one val"} &
    lindex $html::page(meta) 0
} {<meta name="keywords" value="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" value="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" value="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-2.1 {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 protected]
    ncgi::parse
    html::textInput email
} {<input type="text" name="email" value="[email protected]">
}

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 [email protected]
} {<input type="text" name="email" value="[email protected]" size="30">
}

test html-13.5 {html::textInput} {
    html::init
    ncgi::reset [email protected]
    ncgi::parse
    html::textInput email [email protected]
} {<input type="text" name="email" value="[email protected]">
}

test html-13.6 {html::textInput} {
    html::init
    ncgi::reset 
    ncgi::parse
    html::textInput email [email protected] size=80
} {<input type="text" name="email" value="[email protected]" size=80>
}

test html-14.1 {html::textInputRow} {
    html::init
    ncgi::reset [email protected]
    ncgi::parse
    html::textInputRow Email email
} {<tr>
	<td>Email</td>
	<td><input type="text" name="email" value="[email protected]">
</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 protected]
    ncgi::parse
    html::checkbox item value
} {<input type="checkbox" name="item" value="value">
}

test html-16.2 {html::checkbox} {
    ncgi::reset [email protected]
    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-24.1 {html::submit} {
    catch {html::submit}
} {1}

test html-24.1 {html::submit} {
    catch {html::submit wrong num args}
} {1}

test html-24.1 {html::submit} {
    html::submit "Push Me"
} {<input type="submit" name="submit" value="Push Me">
}

test html-24.2 {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.3 {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.2 {html::refresh} {
    html::refresh 4
} {}
test html-26.3 {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.4 {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} {catch html::eval} 1
test html-32.5 {error: not enough arguments} {
    catch html::eval msg
    set msg
} {wrong # args: should be "uplevel ?level? command ?arg ...?"}
test html-32.6 {error in eval'ed command} {
    catch {html::eval {error "test error"}}
} 1
test html-32.7 {error in eval'ed command} {
    catch {html::eval {error "test error"}} msg
    set msg
} {test error}

tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/html/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 html 1.2.2 [list source [file join $dir html.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/htmlparse/ChangeLog.

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

	* htmlparse.tcl:
	* htmlparse.man:
	* pkgIndex.tcl:  Set version of the package to to 0.3.1.

2003-03-24  Andreas Kupries  <[email protected]>

	* htmlparse.test: Added htmlparse-3.4 to exercise the fix.
	* htmlparse.tcl (::htmlparse::parse): Fixed bug #640932, reported
	  by Scott Goodwin <[email protected]>. 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  <[email protected]>

	* htmlparse.tcl (::htmlparse::PrepareHtml): Use string map instead
	of regsub.

2003-02-07  Pat Thoyts  <[email protected]>

	* htmlparse.tcl (::htmlparse::mapEscapes): Fixed typo (strimg ->
	string) to pass test suite.

2003-02-05  David N. Welton  <[email protected]>

	* htmlparse.tcl (::htmlparse::mapEscapes): Use string match
	instead of regexp. Feature [ 676536 ].

2003-01-16  Andreas Kupries  <[email protected]>

	* htmlparse.man: More semantic markup, less visual one.

2002-08-08  Andreas Kupries  <[email protected]>

	* 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 <[email protected]> for the
	  report.

2002-06-03  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl:
	* htmlparse.tcl:
	* htmlparse.n:
	* htmlparse.man: Bumped to version 0.3.

2002-02-09  David N. Welton  <[email protected]>

	* htmlparse.n: Cleaned up some of the language in the man page.

2001-07-10  Andreas Kupries <[email protected]>

	* htmlparse.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* htmlparse.tcl: Fixed dubious code reported by frink.

2001-03-23  Andreas Kupries <[email protected]>

	* 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 <[email protected]>

	* New module 'htmlparse', a HTML parser based upon Steve Uhler's
	  venerable 'html_library' and some of my work in the book
	  scanning project.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































Deleted modules/htmlparse/htmlparse.man.

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

[nl]

All information beyond the HTML string itself is specified via
options, these are explained below.

[nl]

To help understand the options, some more background information about
the parser.

[nl]

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.

[nl]

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.

[nl]

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.

[nl]

[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.

[nl]
In both modes the parser will return an empty string to the caller.

[nl]
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.

[nl]
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]

[lst_item "[option -cmd] [arg cmd]"]

The command prefix to invoke for every tag in the HTML
string. Defaults to [arg ::htmlparse::debugCallback].

[lst_item "[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].

[lst_item "[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.

[lst_item "[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]
[nl]
[lst_item [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.

[nl]

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.

[nl]

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.

[nl]

The second argument, [arg tag], contains the name of the tag which is
currently processed by the parser.

[nl]

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).

[nl]

The fourth argument, [arg param], contains the un-interpreted list of
parameters to the tag.

[nl]

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.

[nl]

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.

[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]

[keywords html parsing]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































Deleted modules/htmlparse/htmlparse.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
'\"
'\" Copyright (c) 2001 by ActiveState Tool Corp.
'\" All rights reserved.
'\"
'\" RCS: @(#) $Id: htmlparse.n,v 1.5 2002/06/03 20:21:46 andreas_kupries Exp $
'\"
.so man.macros
.TH htmlparse n 0.3 Html "HTML Parser"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::htmlparse \- Procedures to parse HTML string
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require struct 1\fR
.sp
\fBpackage require cmdline 1.1\fR
.sp
\fBpackage require htmlparse ?0.3?\fR
.sp
\fB::htmlparse::parse\fR ?-cmd \fIcmd\fR? ?-vroot \fItag\fR? ?-split \fIn\fR? ?-incvar \fIvar\fR? ?-queue \fIq\fR? \fIhtml\fR
.sp
\fB::htmlparse::debugCallback\fR ?\fIclientdata\fR? \fItag slash param textBehindTheTag\fR
.sp
\fB::htmlparse::mapEscapes\fR \fIhtml\fR
.sp
\fB::htmlparse::2tree\fR \fIhtml tree\fR
.sp
\fB::htmlparse::removeVisualFluff\fR \fItree\fR
.sp
\fB::htmlparse::removeFormDefs\fR \fItree\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::htmlparse\fR package provides commands that allow libraries
and applications to parse HTML in a string into a representation of
their choice.
.PP
The following commands are available:
.TP
\fB::htmlparse::parse\fR ?-cmd \fIcmd\fR? ?-vroot \fItag\fR? ?-split \fIn\fR? ?-incvar \fIvar\fR? ?-queue \fIq\fR? \fIhtml\fR

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, \fB::htmlparse::mapEscapes\fR, to aid in
the handling of the latter. The parser \fBdoes\fR 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 understand the options, some more background information about
the parser.

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 \fI-incvar\fR 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.

Another feature of the parser are its two possible modes of
operation. The normal mode is activated if the option \fI-queue\fR 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.

\fBNote\fR: 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.

In both modes the parser will return an empty string to the caller.

The \fI-split\fR option may be given to a parse 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.

The option \fI-vroot\fR 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:
.RS
.TP
\fB-cmd cmd\fI
The command prefix to invoke for every tag in the HTML
string. Defaults to \fI::htmlparse::debugCallback\fR.
.TP
\fB-vroot tag\fR
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
\fIhmstart\fR.
.TP
\fB-split n\fR
The size of the groups produced by an incremental mode parser. Ignored
when in normal mode. Defaults to 10. Values <= 0 are not allowed.
.TP
\fB-incvar var\fR
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'.
.RE
.RS
.TP
\fBInterface to the command prefix\fR
In normal mode the parser will invoke the command prefix with four
arguments appended. See \fB::htmlparse::debugCallback\fR 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 is a placeholder
string (\fB\\win\\\fR) 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.
.RE
.TP
\fB::htmlparse::debugCallback\fR ?\fIclientdata\fR? \fItag slash param textBehindTheTag\fR
This command is the standard callback used by the parser in
\fB::htmlparse::parse\fR 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.

The first argument, \fIclientdata\fR, 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.

The second argument, \fItag\fR, contains the name of the tag which is
currently processed by the parser.

The third argument, \fIslash\fR, 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).

The fourth argument, \fIparam\fR, contains the un-interpreted list of
parameters to the tag.

The fifth and last argument, \fItextBehindTheTag\fR, contains the text
found by the parser behind the tag named in \fItag\fR.
.TP
\fB::htmlparse::mapEscapes\fR \fIhtml\fR
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.
.TP
\fB::htmlparse::2tree\fR \fIhtml tree\fR

This command is a wrapper around \fB::htmlparse::parse\fR which takes
an HTML string (in \fIhtml\fR) 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 (\fItree\fR). The command
does \fBnot\fR 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.

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.
.TP
\fB::htmlparse::removeVisualFluff\fR \fItree\fR
This command walks a tree as generated by \fB::htmlparse::2tree\fR 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.
.TP
\fB::htmlparse::removeFormDefs\fR \fItree\fR
Like \fB::htmlparse::removeVisualFluff\fR this command is here to cut
down on the size of the tree as generated by
\fB::htmlparse::2tree\fR. It removes all nodes representing forms and
form elements. Its only argument is the name of the tree to cut down.

.SH SEE ALSO
.SH KEYWORDS
html, parsing
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































Deleted modules/htmlparse/htmlparse.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
# 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 ([email protected])
#		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 1
package require cmdline 1.1
package provide htmlparse 0.3.1

namespace eval ::htmlparse {
    namespace export		\
	    parse		\
	    debugCallback	\
	    mapEscapes		\
	    2tree		\
	    removeVisualFluff	\
	    removeFormDefs

    # Table of escape characters. Maps from their names to the actual
    # character.

    variable escapes

    # I. Standard escapes. (ISO latin-1 esc's are in a different table)

    array set escapes {
	lt <   gt >   amp &   quot \"   copy \xa9
	reg \xae   ob \x7b   cb \x7d   nbsp \xa0
	bsl \\
    } ; # " make the emacs highlighting code happy.

    # II. ISO Latin-1 escape codes

    array set escapes {
	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
	hibar \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
    }

    # 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 option the command explect 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 {# Can't 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).

    if {[regexp -- {[^<]*(<[^>]*)$} [lindex "\{$html\}" end] -> trailer]} {
	if {$incvar == {}} {
	    return -code error "::htmlparse::parse : HTML is incomplete, option -incvar is missing"
	}

	#  upvar $incvar incomplete -- Already done, s.a.
	set incomplete $trailer
	set html       [string range $html 0 [expr {[string last "<" $html] - 1}]]
    } else {
	set incomplete ""
    }

    # Convert the HTML string into a script.

    set w " \t\r\n"	;# white space
    set exp <(/?)([CClass ^$w>]+)[CClass $w]*([CClass ^>]*)>
    set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
    regsub -all -- $exp $html $sub 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).

    set html [string map [list \r \n] $html]

    regsub -- "^.*<!DOCTYPE\[^>\]*>"       $html {}     html
    set html [string map [list "-->" "\001"] $html]
    regsub -all -- "<!--\[^\001\]*\001" $html {}     html

    # Protect characters special to tcl (braces, slashes) by
    # converting them to their escape sequences.

    return [string map [list "\{" "&ob;" "\}" "&cb;" "\\\\" "&bsl;"] $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 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;

    if { ! [string match "*&*" $html] } {
	# HTML not containing escape sequences is returned unchanged.
	return $html
    }

    regsub -all -- {([][$\\])} $html {\\\1} new
    regsub -all -- {&#([0-9][0-9]?[0-9]?);?} $new {[format %c [scan \1 %d tmp;set tmp]]} new
    regsub -all -- {&([a-zA-Z]+);?} $new {[DoMap \1]} new
    return [subst $new]
}

# htmlparse::CClass --
#
#	Internal helper command used by '::htmlparse::parse' while
#	transforming the HTML string. Makes it easier to declare
#	character classes in a ""-bounded string without traipsing
#	into quoting hell.
#
# Arguments:
#	x	A set of characters.
#
# Side Effects:
#	None.
#
# Results:
#	Returns a regular expression for the specified character
#	class.

proc ::htmlparse::CClass {x} {
    return "\[$x\]"
}

# htmlparse::DoMap --
#
#	Internal helper command. Takes a the body of a single escape
#	sequence (i.e. the string without the sourounding & and ;) and
#	returns the associated actual character. Used by
#	'::htmlparse::mapEscapes' to do the real work.
#
# Arguments:
#	text	The body of the escape sequence to convert.
#
#	unknown	Optional. Defaults to '?'. The string to return if the
#		escape sequence is not known to the command.
#
# Side Effects:
#	None.
#
# Results:
#	None.

proc ::htmlparse::DoMap {text {unknown ?}} {
    # Convert an HTML escape sequence into a character.

    variable escapes
    set result $unknown
    catch {set result $escapes($text)}
    return $result
}

# 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 -key 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 -command [list ::htmlparse::Reorder %t %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 -key 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 -key type]}
			#puts stderr "\tdesync at <$tag> ($tstring) => pop $level"
		    }
		} else {
		    #foreach n $nodes {lappend tstring [$tree get $n -key 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  -key type PCDATA
	    $tree set $pcd  -key 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 -key type $tag
	$tree set $node -key 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  -key type PCDATA
	    $tree set $pcd  -key 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 \
	    -command [list ::htmlparse::RemoveVisualFluff %t %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 \
	    -command {::htmlparse::RemoveFormDefs %t %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 -key 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 -key 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 -key type]] {
	h1 - h2 - h3 - h4 - h5 - h6 - p - li {
	    # Look for right siblings until the next node with the
	    # same type (or end of level) and move these below this
	    # node.

	    while {1} {
		set sibling [$tree next $node]
		if {
		    $sibling == {} ||
		    (![string compare $tp [$tree get $sibling -key type]])
		} {
		    break
		}
		$tree move $node end $sibling
	    }
	}
	default {
	    # Ignore tag
	}
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/htmlparse/htmlparse.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

package require htmlparse
puts "htmlparse [package present 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}

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 entities} {
    ::htmlparse::mapEscapes "&gt;&lt;&amp;"
} {><&}


proc tlist {t n} {
    set tt [list]
    foreach c [$t children $n] {
	lappend tt [$t get $c -key synth]
    }
    $t set $n -key synth [list [$t get $n -key type] $tt]
}

test htmlparse-5.0 {conversion to tree} {
    struct::tree t
    ::htmlparse::2tree $html3 t

    set tx [list]
    t walk root -command {lappend tx [list [%t depth %n] [%t get %n -key type]]}
    t destroy
    set tx
} {{0 root} {1 hmstart} {2 html} {3 head} {4 title} {5 PCDATA} {4 meta} {3 body} {4 h2} {5 PCDATA} {5 p} {6 b} {7 PCDATA} {5 p} {6 form} {7 input}}

test htmlparse-5.1 {conversion to tree} {
    struct::tree t
    ::htmlparse::2tree $html3 t
    ::htmlparse::removeVisualFluff t

    set tx [list]
    t walk root -command {lappend tx [list [%t depth %n] [%t get %n -key type]]}
    t destroy
    set tx
} {{0 root} {1 head} {2 title} {3 PCDATA} {1 body} {2 h2} {3 PCDATA} {3 p} {4 PCDATA} {3 p} {4 form} {5 input}}

test htmlparse-5.2 {conversion to tree} {
    struct::tree t
    ::htmlparse::2tree $html3      t
    ::htmlparse::removeVisualFluff t
    ::htmlparse::removeFormDefs    t

    set tx [list]
    t walk root -command {lappend tx [list [%t depth %n] [%t get %n -key type]]}
    t destroy
    set tx
} {{0 root} {1 head} {2 title} {3 PCDATA} {1 body} {2 h2} {3 PCDATA} {3 p} {4 PCDATA} {3 p}}


# Take a look at the cache.
#parray ::htmlparse::splitdata
::tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































Deleted modules/htmlparse/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 htmlparse 0.3.1 [list source [file join $dir htmlparse.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/irc/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
2003-04-13  Andreas Kupries  <[email protected]>

	* irc.tcl: Accepted the patch in report [#718985] for a more
	  robust 'GetEvent' routine. Provided by Donal Fellows
	  <[email protected]>.

2003-04-11  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* irc.tcl: Added Tcl requirement to package itself.

2003-01-24  David N. Welton  <[email protected]>

	* 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  <[email protected]>

	* irc.man: More semantic markup, less visual one.

2003-01-08  David N. Welton  <[email protected]>

	* irc.tcl: Make sure 'api' commands return strings, not lists.
	  (DispatchServerEvent): Add a missing join, to keep

2002-12-16  David N. Welton  <[email protected]>

	* 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  <[email protected]>

	* irc.man: Added doctools manpage.

2002-02-14  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* irc.n:
	* irc.tcl: Applied patch #481477.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































Deleted modules/irc/irc.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin irc n 0.3]
[moddesc   {Low Level Tcl IRC Interface}]
[titledesc {Create IRC connection and interface.}]
[require Tcl]
[require irc [opt 0.3]]
[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::connection] [arg hostname]]

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.


[call [cmd ::irc::config] [arg key] [arg value]]

Sets configuration [arg key] to [arg value].  Currently, the only
config key defined is the boolean flag [const debug] which, when
turned on, makes [package irc] print more information about what is
going on.

[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 the IRC RFC: 1459.  In addition, there are
several other events defined. [const defaultcommand] 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.

[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 connect]]

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.


[call [arg net] [method user] [arg username] [arg localhostname] [arg userinfo]]

Sends USER command to server.  [arg username] is the username you want
to appear.  [arg localhostname] is the name of your server, and

[arg userinfo] is a short description of who you are.


[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]]

PING the IRC server.


[call [arg net] [method join] [arg channel]]

[arg channel] is the IRC channel to join.  IRC channels typically
begin with a hashmark ("#").

[call [arg net] [method part] [arg channel]]

Makes the client leave [arg channel].

[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 send] [arg text]]

Sends [arg text] to the IRC server.

[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] [opt [arg index]]]

Returns the target of a particular command, such as the channel or
user to whom a PRIVMSG is sent.  In the case of multiple targets, the
optional [arg index] argument may be used to specify which one to
return.  The default is 0.

[call [cmd msg]]

Returns the message portion of the command (the part after the :).

[list_end]

[see_also {rfc 1459}]
[keywords irc chat]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































Deleted modules/irc/irc.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
'\"
'\" Copyright (c) 2001 by David N. Welton <[email protected]>.
'\" All rights reserved.
'\"
'\" $Id: irc.n,v 1.5 2003/01/03 02:52:16 davidw Exp $
'\"
'\"	# CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
'\"	# CE - end code excerpt
.de CE
.fi
.RE
..

.TH irc n 0.2 IRC "Low Level Tcl IRC Interface"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::irc \- Create IRC connection and interface.
.SH SYNOPSIS
\fBpackage require Tcl\fR
.sp
\fBpackage require irc ?0.2?\fR
.sp
\fB::irc::connection \fIhostname\fR
.sp
.BE
.SH DESCRIPTION
.PP
This package provides low-level commands to deal with the IRC protocol
(Internet Relay Chat) for immediate and interactive multi-cast
communication.
.PP
The \fB::irc::connection\fR command creates a new object to deal with
an IRC connection.  Creating this IRC object does not automatically
create the network connection.  The \fB::irc::connection\fR command
returns a new irc namespace command which can be used to interact with
the new IRC connection.

.SH Per-connection Commands
.PP
In the following list of available connection methods \fInet\fR
represents a connection command as returned by \fB::irc::connection\fR.
.TP
\fInet \fBregisterevent\fR \fIevent\fR \fIscript\fR
Registers a callback handler for the specific event.  Events available
are those described in the IRC RFC: 1459.  In addition, there are
several other events defined. \fBdefaultcommand\fR adds a command that
is called if no other callback is present.  \fBEOF\fR is called if the
connection signals an End of File condition.  \fIscript\fR is executed
in the connection namespace, which can take advantage of several
commands (see \fBCallback Commands\fR below) to aid in the parsing of
data.
.TP
\fInet \fBconnect\fR
This causes the socket to be established.  \fB::irc::connection\fR
created the namespace and the commands to be used, but did not
actually open the socket. This is done here.
.TP
\fInet \fBuser\fR \fIusername\fR \fIlocalhostname\fR \fIuserinfo\fR
Sends USER command to server.  \fIusername\fR is the username you want to
appear.  \fIlocalhost name\fR is the name of your server, and \fIuserinfo\fR is a
short description of who you are.
.TP
\fInet \fBnick\fR \fInick\fR
NICK command.  \fInick\fR is the nickname you wish to use for the
particular connection.
.TP
\fInet \fBping\fR
PING the IRC server.
.TP
\fInet \fBjoin\fR \fIchannel\fR
\fIchannel\fR is the IRC channel to join.  IRC channels typically begin
with a #.
.TP
\fInet \fBpart\fR \fIchannel\fR
Makes the client leave \fIchannel\fR.
.TP
\fInet \fBprivmsg\fR \fItarget\fR \fImessage\fR
Sends \fImessage\fR to \fItarget\fR, which can be either a channel, or
another user, in which case their nick is used.
\fInet \fBsend\fR \fItext\fR
Sends \fItext\fR to the IRC server.

.SH Callback Commands
.PP
These commands are used within callbacks
.TP
\fBwho\fR \fI?address?\fR
Returns the nick of the user who performed a command.  The optional
\fIaddress\fR argument causes the command to return the
username@address of the user.
.TP
\fBaction\fR
Returns the action perfomed, such as KICK, PRIVMSG, MODE, etc...
Normally not useful, as callbacks are bound to a particular event.
.TP
\fBtarget\fR \fI?index?\fR
Returns the target of a particular command, such as the channel or
user to whom a PRIVMSG is sent.  In the case of multiple targets, the
optional \fIindex\fR argument may be used to specify which one to
return.  The default is 0.
.TP
\fBmsg\fR
Returns the message portion of the command (the part after the :).
.TP
\fBnetwork\fR
This command permits the use of the per-connection commands from
within callbacks.  For instance, it would be possible from within a
PRIVMSG callback to do the following:
.CS
$cn registerevent PRIVMSG {
    network privmsg [who] "Tcl IRC system at your service"
}
.CE

.SH Global Commands
.PP
.TP
\fB::irc::config\fR \fIkey\fR \fIvalue\fR
Sets configuration \fIkey\fR to \fIvalue\fR.  Currently, the only
config key defined is \fBdebug\fR which, when turned on, makes ::irc
print more information about what is going on.

.SH SEE ALSO
.PP
rfc 1459

.SH KEYWORDS
irc, chat
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































Deleted modules/irc/irc.tcl.

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

package provide irc 0.3
package require Tcl 8.3

package require logger

namespace eval ::irc {
    variable conn

    # configuration information
    set config(debug) 0
    set log [logger::init irc]

    # counter used to differentiate connections
    set conn 0
}

# ::irc::config --
#
# Set configuration options
#
# Arguments:
#
# key	name of the configuration option to change.
#
# value	value of the configuration option.

proc ::irc::config { key value } {
    variable config
    if { $key == "debug" } {
	if { $value > 0 } {
	    ${irc::log}::enable debug
	} else {
	    ${irc::log}::disable notice
	}
    }
    set config($key) $value
}

# ::irc::connection --

# Create an IRC connection namespace and associated commands.  Do not
# actually make the socket.

# Arguments:

# host	hostname to connect to

# port	port to use - usually 6667

proc ::irc::connection { host {port 6667} } {
    variable conn
    variable config

    # Create a unique namespace of the form irc$conn::$host

    set name [format "%s::irc%s::%s" [namespace current] $conn $host]

    namespace eval $name {}

    # FRINK: nocheck
    set ${name}::conn $conn
    # FRINK: nocheck
    set ${name}::port $port
    # FRINK: nocheck
    set ${name}::host $host

    namespace eval $name {
	set nick ""
	set state 0
	array set dispatch {}
	set sock {}
	array set linedata {}
	# ircsend --
	# send text to the IRC server

	proc ircsend { msg } {
	    variable sock
	    ${irc::log}::debug "ircsend: '$msg'"
	    if { [catch {puts $sock "$msg"} err] } {
		${irc::log}::error "Error in ircsend: $err"
	    }
	}

	# implemented user-side commands, meaning that these commands
	# cause the calling user to perform the given action.

	proc User { username hostname userinfo } {
	    ircsend "USER $username $hostname $username :$userinfo"
	}

	proc Nick { nk } {
	    variable nick
	    set nick $nk
	    ircsend "NICK $nk"
	}

	proc Ping { } {
	    ircsend "PING: [clock seconds]"
	}

	proc Join { chan } {
	    ircsend "JOIN $chan "
	}

	proc Part { chan } {
	    ircsend "PART $chan"
	}

	proc Privmsg { target msg } {
	    ircsend "PRIVMSG $target :$msg"
	}

	# Connect --
	# Create the actual connection.

	proc Connect { } {
	    variable state
	    variable sock
	    variable host
	    variable conn
	    variable port
	    if { $state == 0 } {
		catch {
		    set sock [socket $host $port]
		}
		if { ! [info exists sock] } {
		    return -1
		}
		set state 1
		fconfigure $sock -translation crlf
		fconfigure $sock -buffering line
		fileevent $sock readable [format "::irc::irc%s::%s::GetEvent" $conn $host ]
	    }
	    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...

	proc action { } {
	    variable linedata
	    return "$linedata(action)"
	}

	# msg --

	# the rest of the line, even if there is more than one target.

	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
	# [email protected]

	proc who { {address 0} } {
	    variable linedata
	    set who $linedata(who)
	    if { $address == 0 } {
		return "[string range $who 0 [expr {[string first ! $who] - 1}]]"
	    } else {
		return "[string range $who [expr {[string last ! $who] + 1}] end]"
	    }
	}

	# target --

	# to whom was this action done.

	# index specifies which target number it is, if there are more
	# than one (MODE and KICK commands, for instance).

	proc target { {index 0} } {
	    variable linedata
	    return "[lindex $linedata(target) $index]"
	}

	# DispatchNumeric --
	# Dispatch a numeric event that arrives from the server

	proc DispatchNumeric { } {
	    variable dispatch
	    variable linedata
	    if { [info exists dispatch($linedata(action))] } {
		eval $dispatch($linedata(action))
	    } else {
		eval $dispatch(defaultnumeric)
	    }
	}

	# DispatchServerEvent --
	# Dispatch event from server

	proc DispatchServerEvent { line } {
	    variable dispatch
	    variable linedata
	    set splitline [split $line]
	    set linedata(who) [lindex $splitline 0]
	    set linedata(action) [lindex $splitline 1]
	    set linedata(target) {}
	    set linedata(msg) {}

	    set i 2
	    while { $i <= [llength $splitline] } {
		set tg [lindex $splitline $i]
		if { [string index $tg 0] == ":" } {
		    set linedata(msg) [string range [join [lrange $splitline $i end]] 1 end]
		    break
		}
		lappend linedata(target) $tg
		incr i
	    }

	    if { [string is integer $linedata(action)] } {
		return [DispatchNumeric]
	    }

	    if { [info exists dispatch($linedata(action))] } {
		return [eval $dispatch($linedata(action))]
	    } else {
		return [eval $dispatch(defaultevent)]
	    }
	}

	# DispatchServerCmd --

	# Dispatch command from server

	proc DispatchServerCmd { line } {
	    variable dispatch
	    variable linedata
	    set splt [string first : $line]
	    set linedata(action) [string range $line 0 [expr {$splt - 2}]]
	    set linedata(msg) [string range $line $splt end]
	    set linedata(target) ""
	    set linedata(who) ""

	    if { [info exists dispatch($linedata(action))] } {
		eval $dispatch($linedata(action))
	    } else {
		eval $dispatch(defaultcmd)
	    }
	}

	# GetEvent --

	# Get a line from the server and send it on to
	# DispatchServerCmd/Event

	proc GetEvent { } {
	    variable linedata
	    variable sock
	    array set linedata {}
	    if {[catch {
		gets $sock line
	    } err]} {
		close $sock
		${irc::log}::error \
			"Error receiving from network: $err"
		return
	    }
	    # Since we're using blocking sockets, testing the
	    # result of [gets] is sufficient to detect EOF
	    if {$err < 0} {
		if {[info exists dispatch(EOF)]} {
		    $dispatch(EOF)
		}
		close $sock
	    }
	    if {[string match :* $line]} {
		DispatchServerEvent [string range $line 1 end]
	    } else {
		# Should this command get an empty string on
		# end-of-file? If not, add a return after
		# the close above.
		DispatchServerCmd $line
	    }
	} 

	# 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 RegisterEvent { evnt cmd } {
	    variable dispatch
	    set dispatch($evnt) $cmd
	}

	# network --

	# Accepts user commands and dispatches them

	# Arguments:

	# cmd: command to invoke

	# args: arguments to the command

	proc network { cmd args } {
	    switch $cmd {
		connect { Connect }
		user { User [lindex $args 0] [lindex $args 1] [lindex $args 2] }
		nick { Nick [lindex $args 0] }
		join { Join [lindex $args 0] }
		privmsg { Privmsg [lindex $args 0] [lindex $args 1] }
		send { ircsend [lindex $args 0] }
		registerevent { RegisterEvent [lindex $args 0] [lindex $args 1] }
		default { }
	    }
	}
    }
    set returncommand [format "%s::irc%s::%s::network" [namespace current] $conn $host]
    incr conn
    return $returncommand
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































Deleted modules/irc/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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.3] } { return }
package ifneeded irc 0.3 [list source [file join $dir irc.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/javascript/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
2003-04-11  Andreas Kupries  <[email protected]>

	* javascript.tcl:
	* javascript.man:
	* pkgIndex.tcl: Fixed bug #614591. Set version of the package to
	  to 1.0.1.

2003-01-16  Andreas Kupries  <[email protected]>

	* javascript.man: More semantic markup, less visual one.

2002-04-12  Andreas Kupries  <[email protected]>

	* javascript.man: Added doctools manpage.

2000-11-01  Melissa Chawla  <[email protected]>

	* javascript.tcl: created this package.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































Deleted modules/javascript/javascript.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin javascript n 1.0.1]
[moddesc   {HTML and Java Script Generation}]
[titledesc {Procedures to generate HTML and Java Script structures.}]
[require Tcl 8]
[require javascript [opt 1.0.1]]
[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 it's 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 it's 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 it's 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]

[see_also html ncgi]
[keywords javascript html checkbox submitbutton selectionbox]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































Deleted modules/javascript/javascript.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
'\"
'\" 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.n,v 1.3 2001/08/02 16:38:06 andreas_kupries Exp $
'\" 
.so man.macros
.TH javascript n 1.0 JavaScript "HTML and Java Script Generation"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::javascript \- Procedures to generate HTML and Java Script structures.
.SH SYNOPSIS
.BS
.sp
\fBpackage require Tcl 8\fR
.sp
\fBpackage require ncgi 1\fR
.sp
\fBpackage require javascript ?1.0?\fR
.sp
\fBjavascript::makeSelectorWidget\fR \fIid leftLabel leftValueList rightLabel rightValueList rightNameList length {minWidth 32}\fR
.sp
\fBjavascript::makeSubmitButton\fR \fIname value\fR
.sp
\fBjavascript::makeProtectedSubmitButton\fR \fIname value msg\fR
.sp
\fBjavascript::makeMasterButton\fR \fImaster value slaves boolean\fR
.sp
\fBjavascript::makeParentCheckbox\fR \fIparentName childName\fR
.sp
\fBjavascript::makeChildCheckbox\fR \fIparentName childName\fR
.BE
.SH DESCRIPTION
.PP
The \fB::javascript\fR 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
\fBstdout\fR.
.PP
.TP
\fBjavascript::makeSelectorWidget\fR \fIid leftLabel leftValueList
rightLabel rightValueList rightNameList length {minWidth 32}\fR
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 id argument is the suffix of all HTML objects in this
megawidget.  The leftLabel argument is the text that appears above the
left selection box.  The leftValueList argument is the values of items
in the left selection box.  The leftNameList argument is the names to
appear in the left selection box.  The rightLabel argument is the text
that appears above the right selection box.  The rightValueList
argument is the values of items in the right selection box.  The
rightNameList argument is the names to appear in the right selection
box.  The length argument (optional) The number of elts to show before
adding a vertical scrollbar; it defaults to 8.  The minWidth argument
(optional) is the number of spaces to determine the minimum box width;
it defaults to 32.

.TP
\fBjavascript::\fR \fImakeSubmitButton\fR \fIname value\fR
Create an HTML submit button that resets a hidden field for each
registered multi-selection box.  The name argument is the name of the
HTML button object to create.  The value argument is the label of the
HTML button object to create.

.TP
\fBjavascript::makeProtectedSubmitButton\fR \fIname value msg\fR
Create an HTML submit button that prompts the user with a
continue/cancel shutdown warning before the form is submitted.  The
name argument is the name of the HTML button object to create.  The
value argument is the label of the HTML button object to create.  The
msg argument is the message to display when the button is pressed.

.TP
\fBjavascript::\fR \fImakeMasterButton\fR \fImaster value slavePattern
boolean\fR
Create an HTML button that sets it's slave checkboxs to the boolean
value.  The master argument is the name of the child's parent html
checkbox object.  The value argument is the value of the master.  The
slaves argument is the name of child html checkbox object to create.
The boolean argument is the java script boolean value that will be
given to all the slaves; it must be "true" or "false".

.TP
\fBjavascript::\fR \fImakeParentCheckbox\fR \fIparentName childName\fR
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.  The parentName argument is the name of parent html
checkbox object to create. The childName argument is the name of the
parent's child html checkbox object.

.TP
\fBjavascript::\fR \fImakeChildCheckbox\fR \fIparentName childName\fR
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.  The parentName argument is the name of the child's parent
html checkbox object.  The childName argument is the name of child
html checkbox object to create.

.SH SEE ALSO
html ncgi

.SH KEYWORDS
javascript, html, checkbox, submitbutton, selectionbox
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































Deleted modules/javascript/javascript.tcl.

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

package require Tcl 8
package require ncgi 1
package provide javascript 1.0.1


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
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/javascript/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
# 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]} {return}
if {[string match "" [package provide ncgi]]} {return}
if {![package vsatisfies [package provide ncgi] 1]} {return}
package ifneeded javascript 1.0.1 [list source [file join $dir javascript.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted modules/log/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
2003-04-21  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* logger.tcl: Require Tcl 8.2 - we use string map.

2003-01-30  David N. Welton  <[email protected]>

	* loggerperformance.test: Changed file name so as to avoid
	  problems with autoindexer.

2003-01-16  Andreas Kupries  <[email protected]>

	* logger.man: More semantic markup, less visual one.
	* log.man:

2002-12-16  David N. Welton  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* log.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-03-20  Andreas Kupries <[email protected]>

	* New module 'log', a logging facility.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































Deleted modules/log/log.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin log n 1.0.2]
[copyright {2001-2002 Andreas Kupries <[email protected]>}]
[moddesc   {Logging facility}]
[titledesc {Procedures to log messages of libraries and applications.}]
[require Tcl 8]
[require log [opt 1.0.2]]
[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::lvSupress 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::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 bullet]
[bullet]
emergency
[bullet]
alert
[bullet]
critical
[bullet]
error
[bullet]
warning
[bullet]
notice
[bullet]
info
[bullet]
debug
[list_end]

[keywords log {log level} {message level} message]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































Deleted modules/log/log.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
'\"
'\" Copyright (c) 2001 by ActiveState Tool Corp.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: log.n,v 1.5 2002/03/01 05:28:28 andreas_kupries Exp $
'\" 
.so man.macros
.TH log n 1.0.1 Log "Logging facility"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::log \- Procedures to log messages of libraries and applications.
.SH SYNOPSIS
\fBpackage require Tcl 8\fR
.sp
\fBpackage require log ?1.0.1?\fR
.sp
\fB::log::levels\fR
.sp
\fB::log::lv2longform\fR \fIlevel\fR
.sp
\fB::log::lv2color\fR \fIlevel\fR
.sp
\fB::log::lv2priority\fR \fIlevel\fR
.sp
\fB::log::lv2cmd\fR \fIlevel\fR
.sp
\fB::log::lv2channel\fR \fIlevel\fR
.sp
\fB::log::lvCompare\fR \fIlevel1 level2\fR
.sp
\fB::log::lvSuppress\fR \fIlevel {suppress 1}\fR
.sp
\fB::log::lvSuppressLE\fR \fIlevel {suppress 1}\fR
.sp
\fB::log::lvIsSuppressed\fR \fIlevel\fR
.sp
\fB::log::lvCmd\fR \fIlevel cmd\fR
.sp
\fB::log::lvCmdForall\fR \fIcmd\fR
.sp
\fB::log::lvChannel\fR \fIlevel chan\fR
.sp
\fB::log::lvChannelForall\fR \fIchan\fR
.sp
\fB::log::lvColor\fR \fIlevel color\fR
.sp
\fB::log::lvColorForall\fR \fIcolor\fR
.sp
\fB::log::log\fR \fIlevel text\fR
.sp
\fB::log::logMsg\fR \fItext\fR
.sp
\fB::log::logError\fR \fItext\fR
.sp
\fB::log::Puts\fR \fIlevel text\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::log\fR package provides commands that allow libraries and
applications to selectively log information about their internal
operation and state.
.PP
To use the package just execute
.PP
.CS
 package require log
 log::log notice "Some message"
.CE
.PP
As can be seen above, each message given to the log facility is
associated with a \fIlevel\fR 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 \fBdebug\fR is deactivated.
.PP
.CS
 package require log
 log::lvSupress debug
 log::log debug "Unseen message" ; # No output
.CE
.PP
By default all messages associated with an error-level
(\fBemergency\fR,\fBalert\fR, \fBcritical\fR, and \fBerror\fR) are
written to \fBstderr\fR. Messages with any other level are written to
\fBstdout\fR. In the following example the log module is reconfigured
to write \fBdebug\fR messages to \fBstderr\fR too.
.PP
.CS
 package require log
 log::lvChannel debug stderr
 log::log debug "Written to stderr"
.CE
.PP
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 \fB::log::Puts\fR to log any message. In the following example
all messages of level \fBnotice\fR are given to the non-standard
command \fBtoText\fR for logging. This disables the channel setting for such
messages, assuming that \fBtoText\fR does not use it by itself.
.PP
.CS
 package require log
 log::lvCmd notice toText
 log::log notice "Handled by \"toText\""
.CE
.PP
Another database maintained by this facility is a map from message
levels to colors. The information in this database has \fBno\fR
influence on the behaviour of the module. It is merely provided as a
convenience and in anticipation of the usage of this facility in
\fBtk\fR-based application which may want to colorize message logs.
.SH API
.PP
The following commands are available:
.TP
\fB::log::levels\fR
Returns the names of all known levels, in alphabetical order.
.TP
\fB::log::lv2longform\fR \fIlevel\fR
Converts any unique abbreviation of a level name to the full level
name.
.TP
\fB::log::lv2color\fR \fIlevel\fR
Converts any level name including unique abbreviations to the
corresponding color.
.TP
\fB::log::lv2priority\fR \fIlevel\fR
Converts any level name including unique abbreviations to the
corresponding priority.
.TP
\fB::log::lv2cmd\fR \fIlevel\fR
Converts any level name including unique abbreviations to the command
prefix used to write messages with that level.
.TP
\fB::log::lv2channel\fR \fIlevel\fR
Converts any level name including unique abbreviations to the channel
used by \fB::log::Puts\fR to write messages with that level.
.TP
\fB::log::lvCompare\fR \fIlevel1 level2\fR
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.
.TP
\fB::log::lvSuppress\fR \fIlevel {suppress 1}\fR
(Un)suppresses the output of messages having the specified
level. Unique abbreviations for the level are allowed here too.
.TP
\fB::log::lvSuppressLE\fR \fIlevel {suppress 1}\fR
(Un)suppresses the output of messages having the specified level or
one of lesser priority. Unique abbreviations for the level are allowed
here too.
.TP
\fB::log::lvIsSuppressed\fR \fIlevel\fR
Asks the package whether the specified level is currently
suppressed. Unique abbreviations of level names are allowed.
.TP
\fB::log::lvCmd\fR \fIlevel cmd\fR
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.
.TP
\fB::log::lvCmdForall\fR \fIcmd\fR
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.
.TP
\fB::log::lvChannel\fR \fIlevel chan\fR
Defines for the specified level into which channel \fB::log::Puts\fR
(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.
.TP
\fB::log::lvChannelForall\fR \fIchan\fR
Defines for all known levels with which which channel
\fB::log::Puts\fR (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.
.TP
\fB::log::lvColor\fR \fIlevel color\fR
Defines for the specified level the color to return for it in a call
to \fB::log::lv2color\fR. Unique abbreviations of level names are
allowed.
.TP
\fB::log::lvColorForall\fR \fIcolor\fR
Defines for all known levels the color to return for it in a call to
\fB::log::lv2color\fR. Unique abbreviations of level names are
allowed.
.TP
\fB::log::log\fR \fIlevel text\fR
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 \fB::log::Puts\fR 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 \fBnot\fR
caught, but propagated to the caller, as they may indicate
misconfigurations of the log facility or errors in the callers code
itself.
.TP
\fB::log::logMsg\fR \fItext\fR
Convenience wrapper around \fB::log::log\fR. Equivalent to
\fB::log::log info text\fR.
.TP
\fB::log::logError\fR \fItext\fR
Convenience wrapper around \fB::log::log\fR. Equivalent to
\fB::log::log error text\fR.
.TP
\fB::log::Puts\fR \fIlevel text\fR
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 \fBnot
allowed\fR.

.SH SEE ALSO
.SH KEYWORDS
log, log level, message level, message
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































Deleted modules/log/log.tcl.

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

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.

    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 "\"$level\" is no unique abbreviation of a level name"
}

# 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::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

    lappend cmd $level $text
    eval $cmd
    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"
    return
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/log/log.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [lsearch $auto_path [file dirname [info script]]] == -1 } {
    set auto_path [linsert $auto_path 0 [file dirname [info script]]]
}

package require log
puts "log [package present 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
} {"e" is no unique abbreviation of a level name}

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
} {"foo" is no unique abbreviation of a level name}

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
} {"foo" is no unique abbreviation of a level name}

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
} {"foo" is no unique abbreviation of a level name}

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
} {"foo" is no unique abbreviation of a level name}

foreach level {alert critical debug error emergency info notice warning} {
    test log-7.0.$level {query suppression state} {
	::log::lvIsSuppressed $level
    } 0
}

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
} {"foo" is no unique abbreviation of a level name}


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
} {"foo" is no unique abbreviation of a level name}

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
} {"foo" is no unique abbreviation of a level name}


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
} {"e" is no unique abbreviation of a level name}


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]]
	list [string match *__data__* $log] [string match *__NOT__* $log]
    } {1 0}
}
::log::lvChannelForall {}

::tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/log/logger.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
[comment {-*- tcl -*- doctools manpage}]
[comment {$Id: logger.man,v 1.2 2003/01/19 07:58:44 andreas_kupries Exp $}]
[manpage_begin logger n 0.1.0]
[moddesc {Object Oriented logging facility}]
[titledesc {System to control logging of events.}]
[require Tcl 8]
[require logger [opt 0.1.0]]
[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}::destroy
}]

[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 seperated with '::'.

When a logger service is initalized, 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 seperately configure [term bar].

[call [cmd logger::services]]

Returns a list of all the available services.

[call [cmd logger::enable] [arg level]]

Globally enables logging at or "above" the given level.  Levels are
[const debug], [const info], [const notice], [const warn], [const error],
[const critical].

[call [cmd logger::disable] [arg level]]

Globally disables logging at or "below" the given level.  Levels are
those listed above.

[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]]

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}::enable] [arg level]]

Enable logging, in the service referenced by [var \${log}], and its
children.

[call [cmd \${log}::disable] [arg level]]

Disable logging, in the service referenced by [var \${log}], and
its children.

[call [cmd \${log}::logproc] [arg level] [arg argname] [arg body]]

This is a command to define a command that 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 {
    ${log}::logproc notice txt {
	puts $netlog "Notice: $txt"
    }
}]

[call [cmd \${log}::services]]

Returns a list of all the registered logging services.

[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.

[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.

[keywords logger log service {log level}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































Deleted modules/log/logger.tcl.

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

namespace eval ::logger {
    namespace eval tree {}
    namespace export init enable disable services

    # The active services.
    set services {}

    # The log 'levels'.
    set levels [list debug info notice warn error critical]
}

# ::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 {
	namespace eval $c $code
	logger::walk $c $code
    }
}

proc ::logger::init {service} {
    variable levels
    variable services
    # 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} {}

    lappend services $service

    set tree::${service}::service $service
    set tree::${service}::levels $levels

    namespace eval tree::${service} {
	# Defaults to 'debug' level - show everything.  I don't
	# want people to wonder where there debug messages are
	# going.  They can turn it off themselves.
	variable enabled "debug"

	# 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\'"
	}

	# 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} {
	    variable levels
	    set lvnum [lsearch -exact $levels $lv]
	    if { $lvnum == -1 } {
		::error "Invalid level '$lv' - levels are $levels"
	    }

	    variable enabled $lv
	    while { $lvnum <  [llength $levels] } {
		interp alias {} [namespace current]::[lindex $levels $lvnum] \
		    {} [namespace current]::[lindex $levels $lvnum]cmd
		incr lvnum
	    }
	    logger::walk [namespace current] [list enable $lv]
	}

	# 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} {
	    variable levels
	    set lvnum [lsearch -exact $levels $lv]
	    if { $lvnum == -1 } {
		::error "Levels are $levels"
	    }

	    # this is the lowest level possible.
	    variable enabled $lv
	    while { $lvnum >= 0 } {
		interp alias {} [namespace current]::[lindex $levels $lvnum] {} \
		    [namespace current]::no-op
		incr lvnum -1
	    }
	    logger::walk [namespace current] [list disable $lv]
	}

	# logproc --
	#
	#	Command used to create a procedure that is what is
	#	executed to perform the logging.  This could write to
	#	disk, out to the network, or something else.
	#
	# Arguments:
	#	lv - the level to log, which must be one of $levels.
	#	arg - the arg the procedure takes, usually something
	#	like 'txt'.
	#	body - the body of the procedure.
	#
	# Side Effects:
	#	Creates a logging command to take care of the details
	#	of logging an event.
	#
	# Results:
	#	None.


	proc logproc {lv arg body} {
	    variable levels
	    set lvnum [lsearch -exact $levels $lv]
	    if { $lvnum == -1 } {
		::error "Invalid level '$lv' - levels are $levels"
	    }
	    proc ${lv}cmd $arg $body
	}

	# delete --
	#
	#	Delete the namespace and its children.

	proc delete {} {
	    namespace delete [namespace current]
	}

	# 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
	set parent [namespace parent]
	while { $parent != "::logger::tree" } {
	    # If the 'enabled' variable doesn't exist, create the
	    # whole thing.
	    if { ! [::info exists ${parent}::enabled] } {
		logger::init [string map {::logger::tree:: ""} $parent]
	    }
	    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.
	if { $parent != "::logger::tree" } {
	    interp alias {} [namespace current]::debugcmd {} ${parent}::debugcmd
	    interp alias {} [namespace current]::infocmd {} ${parent}::infocmd
	    interp alias {} [namespace current]::noticecmd {} ${parent}::noticecmd
	    interp alias {} [namespace current]::warncmd {} ${parent}::warncmd
	    interp alias {} [namespace current]::errorcmd {} ${parent}::errorcmd
	    interp alias {} [namespace current]::criticalcmd {} ${parent}::criticalcmd
	} else {
	    proc debugcmd {txt} {
		stdoutcmd debug $txt
	    }
	    proc infocmd {txt} {
		stdoutcmd info $txt
	    }
	    proc noticecmd {txt} {
		stdoutcmd notice $txt
	    }
	    proc warncmd {txt} {
		stderrcmd warn $txt
	    }
	    proc errorcmd {txt} {
		stderrcmd error $txt
	    }
	    proc criticalcmd {txt} {
		stderrcmd critical $txt
	    }
	}
    }
    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
    foreach sv $services {
	::logger::tree::${sv}::enable $lv
    }
}

proc ::logger::disable {lv} {
    variable services
    foreach sv $services {
	::logger::tree::${sv}::disable $lv
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































Deleted modules/log/logger.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

set auto_path "[file dirname [info script]] $auto_path"
package require 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
    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-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}

test logger-3.0 {log} {
    set log [logger::init global]
    ${log}::error "Danger Will Robinson!"
    ${log}::delete
} {}

test logger-3.1 {log} {
    set log [logger::init global]
    ${log}::warn "Danger Will Robinson!"
    ${log}::delete
} {}

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.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}

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!}


::tcltest::cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































Deleted modules/log/loggerperformance.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
# -*- tcl -*-
# loggerperformance.tcl

# $Id: loggerperformance,v 1.1 2003/04/21 20:16:54 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"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































Deleted modules/log/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
# 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]} {return}
package ifneeded log 1.0.2 [list source [file join $dir log.tcl]]
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded logger 0.1 [list source [file join $dir logger.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted modules/math/ChangeLog.

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

	* optimize.test: Corrected errors in loading the functionality
	  under test, and of accessing tcltest. Now functional.

2003-04-18  Joe English  <[email protected]

	* optimize.man: fix minor markup errors that doctools and tmml 
	  were complaining about. 

2003-04-16  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* combinatorics.man:
	* math.man:
	* math.tcl:
	* pkgIndex.tcl:  Set version of the package to to 1.2.2.

2003-01-16  Andreas Kupries  <[email protected]>

	* combinatorics.man: More semantic markup, less visual one.
	* calculus.man:

2002-06-03  Andreas Kupries  <[email protected]>

	* 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 <[email protected]>.

2002-05-08  Don Porter <[email protected]>

	* calculus.test: Corrected testing problems by namespace-ifying
	the file.

2002-04-15  Andreas Kupries  <[email protected]>

	* combinatorics.man: Added doctools manpage.
	* math.man: Added doctools manpage.

2002-03-25  Andreas Kupries  <[email protected]>

	* calculus.man: Fixed formatting errors in the doctools manpage.

2002-02-15  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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 <[email protected]>

	* 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  <[email protected]>

	* Bumped version to 1.2.

2002-01-18  Andreas Kupries <[email protected]>

	* Added calculus functionality and fuzzy FP comparison as provided
	  by Arjen Markus <[email protected]> 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  <[email protected]>

	* combinatorics.tcl: Removed incorrect 'package provide'.
	
2002-01-11  Kevin Kenny  <[email protected]>

	* 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 <[email protected]>

	* math.tcl: Fixed dubious code reported by frink.

2000-10-06  Eric Melski  <[email protected]>

	* math.test: 
	* math.n: 
	* math.tcl: Added ::math::fibonacci function, to compute numbers
	in the Fibonacci sequence.

2000-09-08  Eric Melski  <[email protected]>

	* math.test:
	* math.n:
	* math.tcl: Added ::math::random function.

	* pkgIndex.tcl: Bumped version number to 1.1.

2000-06-15  Eric Melski  <[email protected]>

	* math.n: 
	* math.test: 
	* math.tcl: Incorporated sigma, cov, stats, integrate functions
	(from Philip Ehrens <[email protected]>). [RFE: 5060]

2000-03-27  Eric Melski  <[email protected]>

	* math.n: 
	* math.test: 
	* math.tcl: Added sum, mean, and product functions (from Philip
	Ehrens <[email protected]>).

2000-03-09  Eric Melski  <[email protected]>

	* math.test: Adapted tests for use in/out of tcllib test framework.

2000-03-07  Eric Melski  <[email protected]>

	* pkgIndex.tcl:
	* math.tcl:
	* math.test:
	* math.n: Initial versions of files for math library.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































Deleted modules/math/calculus.CHANGES.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted modules/math/calculus.README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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://tcllib.sourceforge.net

Please contact Arjen Markus ([email protected]) for questions,
bug reports, enhancements and so on.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted modules/math/calculus.doc.

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














































































































































































































































































































































































































































































































































































































































Deleted modules/math/calculus.man.

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

[list_begin bullet]
[bullet]
The integration of a function over an interval

[bullet]
The numerical integration of a system of ordinary differential
equations.

[bullet]
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]
[lst_item [arg nosteps]]
Number of steps in which the interval is divided.

[lst_item [arg func]]
Function to be integrated. It should take one single argument.
[list_end]
[nl]

[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]
[lst_item [arg nosteps]]
Number of steps in which the interval is divided.

[lst_item [arg expression]]
Expression to be integrated. It should
use the variable "x" as the only variable (the "integrate")
[list_end]
[nl]

[call [cmd ::math::calculus::integral2D] [arg xinterval] [arg yinterval] [arg func]]
The command [cmd integral2D] 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.
[nl]
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.
[nl]
The function must take two arguments and return the function
value.


[call [cmd ::math::calculus::integral3D] [arg xinterval] [arg yinterval] [arg zinterval] [arg func]]
The command [cmd Integral3D] is the three-dimensional
equivalent of [cmd integral2D]. The function taking three
arguments is integrated over the block in 3D space given by three
intervals.


[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]
[lst_item [arg t]]
Value of the independent variable (typically time)
at the beginning of the step.

[lst_item [arg tstep]]
Step size for the independent variable.

[lst_item [arg xvec]]
List (vector) of dependent values

[lst_item [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]
[nl]


[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]
[lst_item [arg t]]
Value of the independent variable (typically time)
at the beginning of the step.

[lst_item [arg tstep]]
Step size for the independent variable.

[lst_item [arg xvec]]
List (vector) of dependent values

[lst_item [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]
[nl]


[call [cmd ::math::calculus::rungeKuttaStep] [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]
[lst_item [arg t]]
Value of the independent variable (typically time)
at the beginning of the step.

[lst_item [arg tstep]]
Step size for the independent variable.

[lst_item [arg xvec]]
List (vector) of dependent values

[lst_item [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]
[nl]


[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]
[lst_item [arg coeff_func]]
Procedure returning the three coefficients
(A, B, C) of the equation, taking as its one argument the x-coordinate.

[lst_item [arg force_func]]
Procedure returning the right-hand side
(D) as a function of the x-coordinate.

[lst_item [arg leftbnd]]
A list of two values: the x-coordinate of the
left boundary and the value at that boundary.

[lst_item [arg rightbnd]]
A list of two values: the x-coordinate of the
right boundary and the value at that boundary.

[lst_item [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]
[nl]


[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]
[lst_item [arg acoeff]]
List of values on the lower diagonal

[lst_item [arg bcoeff]]
List of values on the main diagonal

[lst_item [arg ccoeff]]
List of values on the upper diagonal

[lst_item [arg dvalue]]
List of values on the righthand-side
[list_end]
[nl]


[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]
[lst_item [arg func]]
Procedure that returns the value the function at x

[lst_item [arg deriv]]
Procedure that returns the derivative of the function at x

[lst_item [arg initval]]
Initial value for x
[list_end]
[nl]


[call [cmd ::math::calculus::newtonRaphsonParameters] [arg maxiter] [arg tolerance]]
Set the numerical parameters for the Newton-Raphson method:

[list_begin definitions]
[lst_item [arg maxiter]]
Maximum number of iteration steps (defaults to 20)

[lst_item [arg tolerance]]
Relative precision (defaults to 0.001)
[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 bullet]
[bullet]
Other types of boundary conditions (zero gradient, zero flux)
[bullet]
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]

[keywords math calculus integration "differential equations" roots]

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/calculus.tcl.

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

# math::calculus --
#    Namespace for the commands
#
namespace eval ::math::calculus {
   namespace export \
          integral integralExpr integral2D integral3D \
          eulerStep heunStep rungeKuttaStep           \
          boundaryValueSecondOrder solveTriDiagonal   \
          newtonRaphson newtonRaphsonParameters

   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 {$hydelta+double($j)*$ydelta}]
      for { set i 0 } { $i < $xnumber } { incr i } {
         set x           [expr {$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 {$hzdelta+double($k)*$zdelta}]
      for { set j 0 } { $j < $ynumber } { incr j } {
         set y [expr {$hydelta+double($j)*$ydelta}]
         for { set i 0 } { $i < $xnumber } { incr i } {
            set x           [expr {$hxdelta+double($i)*$xdelta}]
            set func_value  [uplevel 1 $func $x $y $z]
            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 $t     $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+$tstep2*$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 $acoeff $bcoeff $ccoeff $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 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 C2    [lindex $ccoeff $i]
      set D2    [lindex $dvalue $i]
      set ratab [expr {$A2/$B}]
      set B2    [expr {$B2-$ratab*$C}]
      set D2    [expr {$D2-$ratab*$D}]
      lappend bcoeff2 $B2
      lappend dvalue2 $D2
      set B     $B2
      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-2}] } { $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
   }
}

# Now we can announce our presence
package provide math::calculus 0.5
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/calculus.test.

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

namespace eval ::math::calculus::test {

namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
namespace import ::math::calculus::*

#
# 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

#
# Note:
# Test cases for integral3D are missing!
#

#
# 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} {
   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 [$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 [$method $t $tstep $xvec dampened_oscillator]
      puts "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 }

puts [boundaryValueSecondOrder coeffs forces {0.0 1.0} {100.0 0.0} 10]
puts [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.1" "Result should be nearly 0.56714" {
   set result [newtonRaphson func2 deriv2 -0.5]
   if { abs($result-0.56714) < 0.0001 } {
      set answer 1
   }
} 1

cleanupTests
}

namespace delete ::math::calculus::test
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































Deleted modules/math/calculus.testscript.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
# 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]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































Deleted modules/math/combinatorics.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin combinatorics n 4.2]
[moddesc   {Tcl Math Library}]
[titledesc {Combinatorial functions in the Tcl Math Library}]
[require Tcl 8.2]
[require math [opt 1.2.2]]
[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].

[nl]

The Gamma function is defined as the improper integral from zero to
positive infinity of

[example {
  t**(x-1)*exp(-t) dt
}]

[nl]

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].

[nl]

For integer [arg x], 0 <= [arg x] <= 12, an exact integer result is
returned.

[nl]

For integer [arg x], 13 <= [arg x] <= 21, an exact floating-point
result is returned on machines with IEEE floating point.

[nl]

For integer [arg x], 22 <= [arg x] <= 170, the result is exact to 1
ULP.

[nl]

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.

[nl]

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.

[nl]

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]

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































Deleted modules/math/combinatorics.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
'\" Copyright (c) 2002 by Kevin B. Kenny.  All rights reserved.
'\"
'\" RCS: #(@) $Id: combinatorics.n,v 1.2 2002/01/18 20:51:16 andreas_kupries Exp $
'\"
.so man.macros
.TH combinatorics n 1.2 math "Tcl Math Library"
.BS
'\" Note: do not modify the .SH NAME line immediately below
.SH NAME
combinatorics - Combinatorial functions in the Tcl Math Library
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require math 1.2\fR
.sp
\fB::math::ln_Gamma\fR \fIz\fR
.sp
\fB::math::factorial\fR \fIn\fR
.sp
\fB::math::choose\fR \fIn k\fR
.sp
\fB::math::Beta\fR \fIz w\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fBmath\fR package contains implementations of several functions
useful in combinatorial problems.
.SH COMMANDS
.TP
\fB::math::ln_Gamma\fR \fIz\fR
Returns the natural logarithm of the Gamma function for the argument \fIz\fR.
.PP
The Gamma function is defined as the improper integral from 
zero to positive infinity of
.CS
\fIt**(x-1)*exp(-t) dt\fR.
.CE
.PP
The approximation used in the Tcl Math Library is from Lanczos, \fISIAM
J. Numerical Analysis, series B,\fR volume 1, p. 86.  For \fIx>1\fR, the
absolute error of the result is claimed to be smaller than 5.5*10**-10
-- that is, the resulting value of Gamma when 
.CS
exp( ln_Gamma( x) ) 
.CE
is computed is expected to be precise to better than nine
significant figures.
.TP
\fB::math::factorial\fR \fIx\fR
Returns the factorial of the argument \fIx\fR.
.PP
For integer \fIx\fR, \fI0 <= x <= 12\fR, an exact integer result is returned.
.PP
For integer \fIx\fR, \fI13 <= x <= 21\fR, an exact floating-point
result is returned on machines with IEEE floating point.
.PP
For integer \fIx\fR, \fI22 <= x <= 170\fR, the result is exact to 1 ULP.
.PP
For real \fIx\fR, \fIx >= 0\fR, the result is approximated by computing
\fIGamma(x+1)\fR using the \fB::math::ln_Gamma\fR function, and the result is
expected to be precise to better than nine significant figures.
.PP
It is an error to present \fIx <= -1\fR or \fIx > 170\fR, or a value
of \fIx\fR that is not numeric.
.TP
\fB::math::choose\fR \fIn k\fR
Returns the binomial coefficient \fIC(n, k)\fR
.CS
\fIC(n,k) = n! / k! (n-k)!
.CE
If both parameters are integers and the result fits in 32 bits, 
the result is rounded to an integer.
.PP
Integer results are exact up to at least \fIn = 34\fR.
Floating point results are precise to better than nine significant 
figures.
.TP
\fB::math::Beta\fR \fIz w\fR
Returns the Beta function of the parameters \fIz\fR and \fIw\fR.
.CS
\fIBeta(z,w) = Beta(w,z) = Gamma(z) * Gamma(w) / Gamma(z+w)
.CE
Results are returned as a floating point number precise to better than
nine significant digits provided that \fIw\fR and \fIz\fR are both at
least 1.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































Deleted modules/math/combinatorics.tcl.

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

    # Error case: not a number

    if { ![string is double $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 $n]
	 && $n >= 0 && $n < 34
	 && [string is integer $k]
	 && $k >= 0 && $k <= $n } {

	set i [expr { ( ( $n * ($n + 1) ) / 2 ) + $k }]

	return [lindex $pascal $i]

    }

    # Test bogus arguments

    if { ![string is double $n] } {
	return -code error [expectDouble $n]
    }
    if { ![string is double $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 $k] && [string is integer $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 $n]
	       && [string is integer $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 $z] } {
	return -code error [expectDouble $z]
    }
    if { ![string is double $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
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/combinatorics.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] math.tcl]
source [file join [file dirname [info script]] combinatorics.tcl]

package require 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]
    }
}

# Service procedure to develop the error message for "wrong # args"

proc wrongNumArgs {name arglist count} {
    set ver [info patchlevel]
    # strip "a1", etc. designations
    regsub {(a|b)[1-9]$} $ver {} ver
    if {[package vcompare $ver 8.4] < 0} {
	set arg [lindex $arglist $count]
	set msg "no value given for parameter \"$arg\" to \"$name\""
    } else {
	set msg "wrong # args: should be \"$name $arglist\""
    }
    return $msg
}

test combinatorics-1.1 { math::ln_Gamma, wrong num args } {
    catch { math::ln_Gamma } msg
    set msg
} [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
} [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 } {
    catch { math::factorial 172 } msg
    list $msg $::errorCode
} {{floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}

test combinatorics-3.1 { math::choose, wrong num args } {
    catch { math::choose } msg
    set msg
} [wrongNumArgs math::choose {n k} 0]

test combinatorics-3.2 { math::choose, wrong num args } {
    catch { math::choose 1 } msg
    set msg
} [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 } {
    catch { math::choose 1500 750 } msg
    list $msg $::errorCode
} {{floating-point value too large to represent} {ARITH OVERFLOW {floating-point value too large to represent}}}

test combinatorics-4.1 { math::Beta, wrong num args } {
    catch { math::Beta } msg
    set msg
} [wrongNumArgs math::Beta {z w} 0]

test combinatorics-4.2 { math::Beta, wrong num args } {
    catch { math::Beta 1 } msg
    set msg
} [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
} {}

    
::tcltest::cleanupTests

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































Deleted modules/math/fuzzy.eps.f90.

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




















































































































































































































































































































































Deleted modules/math/fuzzy.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
[manpage_begin math::fuzzy n 1.0]
[moddesc {Math}]
[titledesc {Fuzzy comparison of floating-point numbers}]
[description]
[para]
The package Fuzzy is meant to solve common problems with floating-point
numbers in a systematic way:

[list_begin bullet]
[bullet]
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.

[bullet]
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 bullet]
[bullet]
Several test case use the ordinary comparisons, and they
fail invariably to produce understandable results

[bullet]
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.

[keywords math floating-point rounding]

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































Deleted modules/math/fuzzy.tcl.

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

package provide math::fuzzy 0.2

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 } {
   if { [tgt $first $second] } {
      return 1
   } else {
      return [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
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































Deleted modules/math/fuzzy.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require  math::fuzzy
puts "math::fuzzy [package present 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-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 INTENTIONALLY - missing braces} {
    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

	#
	# 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]
} {2000 0 2000 0 2000 0}

test math-fuzzy-ManyCompares-1.2 {Compare fails INTENTIONALLY - 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]
} {2000 0 2000 0 2000 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 - fails INTENTIONALLY} {
    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]
} {2001 2001}

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!
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































Deleted modules/math/fuzzy.testscript.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
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)}])"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted modules/math/geometry.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
# geometry.tcl --
#
#	Collection of geometry functions.
#
# Copyright (c) 2001 by Ideogramic ApS and other parties.
#
# 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.5 2002/02/15 05:35:30 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.
#
###



# ::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::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]
    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} {
    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]
    
    # Is one of the lines vertical?
    if {$l1x1==$l1x2 || $l2x1==$l2x2} {
	# One of the lines is vertical
	if {$l1x1==$l1x2 && $l2x1==$l2x2} {
	    # both lines are vertical
	    if {$l1x1==$l2x1} {
		return "coincident"
	    } else {
		return "none"
	    }
	}

	# make sure line1 is a vertical line
	if {$l1x1!=$l1x2} {
	    # interchange line 1 and 2
	    set l1x1 [lindex $line2 0]
	    set l1y1 [lindex $line2 1]
	    set l1x2 [lindex $line2 2]
	    set l1y2 [lindex $line2 3]
	    set l2x1 [lindex $line1 0]
	    set l2y1 [lindex $line1 1]
	    set l2x2 [lindex $line1 2]
	    set l2y2 [lindex $line1 3]
	}

	# get equation of line 2 (y=a*x+b)
	set a [expr {1.0*($l2y2-$l2y1)/($l2x2-$l2x1)}]
	set b [expr {$l2y1-$a*$l2x1}]

	# Calculate intersection
	set y [expr {$a*$l1x1+$b}]
	return [list $l1x1 $y]
    } else {
	# None of the lines are vertical
	# - get equation of line 1 (y=a1*x+b1)
	set a1 [expr {(1.0*$l1y2-$l1y1)/($l1x2-$l1x1)}]
	set b1 [expr {$l1y1-$a1*$l1x1}]
	# - get equation of line 2 (y=a2*x+b2)
	set a2 [expr {(1.0*$l2y2-$l2y1)/($l2x2-$l2x1)}]
	set b2 [expr {$l2y1-$a2*$l2x1}]
	
	if {abs($a2-$a1) > 0.0001} {
	    # the lines are not parallel
	    set x [expr {($b2-$b1)/($a1-$a2)}]
	    set y [expr {$a1*$x+$b1}]
	    return [list $x $y]
	} else {
	    # the lines are parallel
	    if {abs($b1-$b2) < 0.00001} {
		return "coincident"
	    } else {
		return "none"
	    }
	}
    }
}


# ::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::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 [concat $polygon [lrange $polygon 0 1]]
    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]-1}] [expr {[lindex $polygonBbox 1]-1}]]
    set infinityLine [concat $pointFarAway $P]
    # calculate number of intersections
    set noOfIntersections 0
    #   1. count intersections between the line and the polygon's sides
    set closedPolygon [concat $polygon [lrange $polygon 0 1]]
    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} $polygon {
	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 [concat $polygon [lrange $polygon 0 1]]
    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]
}


package provide math::geometry 1.0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/geometry.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] geometry.tcl]
package require 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} {
    ::math::geometry::findLineIntersection {7 8 7 28} {3 14 17 21}
} {7 16.0}
test geometry-9.2 {geometry::findLineIntersection, second line vertical} {
    ::math::geometry::findLineIntersection {3 14 17 21} {7 8 7 28}
} {7 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} {
    ::math::geometry::findLineIntersection {2 3 10 3} {4 5 7 2}
} {6.0 3.0}
test geometry-9.6 {geometry::findLineIntersection, second line horizontal} {
    ::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} {
    ::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"


###
# 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} {
    ::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



###
# 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




::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/liststat.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
# 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 0 $varname _x_
    set result {}
    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 0 $varname _x_
    set result {}
    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 0 $varname _x_
    set result {}
    foreach data $list {
	set number 0
	foreach _x_ $data {
	    # FRINK: nocheck
	    if $expression {
		incr number
	    }
	}
	lappend result $number
    }
    return $result
}

# End of list procedures
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































Deleted modules/math/math.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
[manpage_begin math n 4.2]
[comment {-*- tcl -*- doctools manpage}]
[moddesc   {Tcl Math Library}]
[titledesc {Tcl Math Library}]
[require Tcl 8.2]
[require math [opt 1.2.2]]
[description]
[para]

The [package math] package provides utility math functions.

[section 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::prod] [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]

[keywords math statistics]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































Deleted modules/math/math.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
'\"
'\" Copyright (c) 1998-2000 by Scriptics Corporation.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: math.n,v 1.8 2002/01/18 20:51:16 andreas_kupries Exp $
'\" 
.so man.macros
.TH math n 1.0 math "Tcl Math Library"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
math \- Tcl math library
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require math ?1.2?\fR
.sp
\fB::math::cov\fR \fIvalue\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::fibonacci\fR \fIn\fR
.sp
\fB::math::max\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::mean\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::min\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::prod\fR \fIvalue\fR ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::random\fR ?\fIvalue\fR? ?\fIvalue\fR?
.sp
\fB::math::sigma\fR \fIvalue\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::stats\fR \fIvalue\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::sum\fR \fIvalue\fR ?\fIvalue\fR \fI...\fR?
.sp
\fB::math::dot\fR \fIvalues\fR \fIrows\fR \fIcols\fR
.sp
\fB::math::cross\fR \fIvalues\fR \fIrows\fR \fIcols\fR
.sp
\fB::math::det\fR \fIvalues\fR \fIrows\fR \fIcols\fR
.sp
\fB::math::integrate\fR \fIlist of xy value pairs\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fBmath\fR package provides utility math functions.
.SH COMMANDS
.TP
.TP
\fB::math::cov\fR \fIvalue\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
Return the coefficient of variation expressed as percent of two or more numeric values.
.TP
\fB::math::integrate\fR \fIlist of xy value pairs\fR
Return the area under a "curve" defined by a set of x,y pairs and the error bound as a list.
\fB::math::fibonacci \fIn\fR
Return the n'th Fibonacci number.
\fB::math::max\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
Return the maximum of one or more numeric values.
.TP
\fB::math::mean\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
Return the mean, or "average" of one or more numeric values.
.TP
\fB::math::min\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
Return the minimum of one or more numeric values.
.TP
\fB::math::prod\fR \fIvalue\fR ?\fIvalue\fR \fI...\fR?
Return the product of one or more numeric values.
.TP
\fB::math::random\fR ?\fIvalue1\fR? ?\fIvalue2\fR?
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 \fIvalue1\fR.  If two
arguments are given, the number is an integer value between
\fIvalue1\fR and \fIvalue2\fR.
.TP
\fB::math::sigma\fR \fIvalue\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
Return the population standard deviation of two or more numeric values.
.TP
\fB::math::stats\fR \fIvalue\fR \fIvalue\fR ?\fIvalue\fR? ?\fIvalue\fR \fI...\fR?
Return the mean, standard deviation, and coefficient of variation as percent as a list.
.TP
\fB::math::sum\fR \fIvalue\fR ?\fIvalue\fR \fI...\fR?
Return the sum of one or more numeric values.
.SH KEYWORDS
math statistics
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































Deleted modules/math/math.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
# 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.
# 
# RCS: @(#) $Id: math.tcl,v 1.15 2003/04/11 19:59:42 andreas_kupries Exp $

package require Tcl 8.2		;# uses [lindex $l end-$integer]

namespace eval ::math {

    variable version 1.2.2

    # misc.tcl

    namespace export	cov		fibonacci	integrate
    namespace export	max		mean		min
    namespace export	product		random		sigma
    namespace export	stats		sum
    namespace export	expectDouble

    # combinatorics.tcl

    namespace export	ln_Gamma	factorial	choose
    namespace export	Beta

    # Set up for auto-loading

    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]] $version
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted modules/math/math.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] math.tcl]
package require math

proc wrongNumArgs {name arglist count} {
    set ver [info patchlevel]
    # strip "a1", etc. designations
    regsub {(a|b)[1-9]$} $ver {} ver
    if {[package vcompare $ver 8.4] < 0} {
	set arg [lindex $arglist $count]
	set msg "no value given for parameter \"$arg\" to \"$name\""
    } else {
	set msg "wrong # args: should be \"$name $arglist\""
    }
    return $msg
}

test math-1.1 {math::min, wrong num args} {
    catch {math::min} msg
    set msg
} [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
} [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
} [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} {
    math::mean 2 1 0 -10 10.5
} 0.7

test math-4.1 {math::sum, wrong num args} {
    catch {math::sum} msg
    set msg
} [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} {
    math::sum 0.1 0.2 0.3 1
} 1.6
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
} [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
} [wrongNumArgs math::sigma {val1 val2 args} 0]
test math-6.2 {simple math::sigma} {
    catch {math::sigma 1} msg
    set msg
} [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
} [wrongNumArgs math::cov {val1 val2 args} 0]
test math-7.2 {simple math::cov} {
    catch {math::cov 1} msg
    set msg
} [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} {
    catch { math::cov 0 2 1 0 } msg
    set msg
} "divide by zero"
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-8.1 {math::stats, wrong num of args} {
     catch { math::stats } msg
     set msg
} [wrongNumArgs math::stats {val1 val2 args} 0]
test math-8.2 {math::stats, wrong num of args} {
     catch { math::stats 100 } msg
     set msg
} [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]

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































Deleted modules/math/misc.tcl.

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

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/optimize.man.

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

[list_begin bullet]
[bullet]
Minimize or maximize a function over a given interval

[bullet]
Solve a linear program (maximize a linear function subject to linear
constraints)

[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.
[para]
[emph Note:] The linear programming algorithm is described but not yet
operational.

[section "PROCEDURES"]
[para]
This package defines the following public procedures:
[list_begin definitions]

[call [cmd ::math::optimize::minimize] [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 2/3 length
that includes the minimum. No guarantee is made that the [emph global]
minimum is found.
[nl]
The procedure returns the "x" value for which the function is minimal.
[nl]
[arg begin] - Start of the interval
[nl]
[arg end] - End of the interval
[nl]
[arg func] - Name of the function to be minimized (a procedure taking
one argument).
[nl]
[arg maxerr] - Maximum relative error (defaults to 1.0e-4)

[call [cmd ::math::optimize::maximize] [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.
[nl]
The procedure returns the "x" value for which the function is maximal.
[nl]
[arg begin] - Start of the interval
[nl]
[arg end] - End of the interval
[nl]
[arg func] - Name of the function to be maximized (a procedure taking
one argument).
[nl]
[arg maxerr] - Maximum relative error (defaults to 1.0e-4)

[call [cmd ::math::optimize::solveLinearProgram] [arg constraints] [arg objective]]
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).
[nl]
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")
[nl]
[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.
[nl]
[arg objective] - The M coefficients of the objective function
[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_begin]
    namespace eval ::mySpace {
       namespace export calcfunc
       proc calcfunc { x } { return $x }
    }
    #
    # Use a fully-qualified name
    #
    namespace eval ::myCalc {
       puts [lb]minimum ::myCalc::calcfunc $begin $end[rb]
    }
    #
    # Import the name
    #
    namespace eval ::myCalc {
       namespace import ::mySpace::calcfunc
       puts [lb]minimum calcfunc $begin $end[rb]
    }
[example_end]

[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_begin]
proc efunc { x } { expr {[lb]$x*$x*$x * exp(-3.0*$x)[rb]} }
puts "Maximum at: [lb]::math::optimize::maximum 0.0 10.0 efunc[rb]"
[example_end]
[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_begin]
   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
[example_end]
[para]
This problem can be solved as follows:
[example_begin]

   set solution [lb]::math::optimize::solveLinearProgram \
      { { 1.0   1.0   1.0 }
        { 2.0   5.0  10.0 } } \
        { 3.0   2.0 }[rb]
[example_end]
[para]
Note, that a constraint like:
[example_begin]
   x + y >= 1
[example_end]
can be turned into standard form using:
[example_begin]
   -x  -y <= -1
[example_end]

[para]
The theory of linear programming is the subject of many a text book and
the Simplex algorithm that is implemented here is the most well-known
method to solve this type of problems.

[keywords math optimization minimum maximum "linear program"]

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































Deleted modules/math/optimize.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
# optimize.tcl --
#    Package to implement optimization of a function or expression
#
# Author: Arjen Markus ([email protected])
#

# math::optimize --
#    Namespace for the commands
#
namespace eval ::math::optimize {
   namespace export minimum  maximum solveLinearProgram

   # 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)
#
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)
#
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
}

# Now we can announce our presence
package provide math::optimize 0.1

#
# Some simple tests
#
if {[file tail $::argv0] == [info script]} {
   namespace import ::math::optimize::*
   proc f1 { x } { expr {$x*$x} }
   proc f2 { x } { expr {cos($x)} }
   proc f3 { x } { expr {sin($x)} }
   proc f4 { x } { expr {$x*(1.0-$x)} }

   puts "Minimize f(x) = x*x:"
   puts "Between 0 and 1:  [minimum 0.0 1.0  f1] (expected: 0)"
   puts "Between -1 and 3: [minimum -1.0 3.0 f1] (expected: 0)"
   puts "Between  1 and 3: [minimum 1.0 3.0  f1] (expected: 1)"

   puts "Minimize f(x) = cos(x):"
   puts "Between 0 and 1:  [minimum 0.0 1.0  f2] (expected: 1)"
   puts "Between -1 and 3: [minimum -1.0 3.0 f2] (expected: 3)"
   puts "Between  1 and 6: [minimum 1.0 6.0  f2] (expected: pi)"

   puts "Minimize f(x) = sin(x):"
   puts "Between 0 and 1:   [minimum  0.0 1.0  f3 ] (expected: 0)"
   puts "Between -1 and 3:  [minimum -1.0 3.0  f3 ] (expected: -1)"
   puts "Between  1 and 6:  [minimum  1.0 6.0  f3 ] (expected: 1.5pi)"
   puts "Between  0 and 60: [minimum  0.0 60.0 f3 ] (expected: ???)"
   puts "Between  0 and 6:  [minimum  0.0 6.0  f3 1.0e-7] (expected: 1.5pi)"

   puts "Maximize f(x) = x*(1-x):"
   puts "Between 0 and 1:  [maximum 0.0 1.0  f4 ] (expected: 0.5)"
   puts "Between -1 and 3: [maximum -1.0 3.0 f4 ] (expected: 0.5)"
   puts "Between  1 and 3: [maximum 1.0 3.0  f4 ] (expected: 1)"

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































Deleted modules/math/optimize.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] optimize.tcl]

namespace eval optimizetest {

#package require math::optimize
namespace import ::math::optimize::*

#
# 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 "Minimum-1.0" "Minimum of constant function" {
   set result [minimum -1.0 1.0 ::optimizetest::const_func]
   within_range $result -1.0 1.0
} 1

#
# To do: find out why this case fails
#
test "Minimum-2.0" "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 "Minimum-2.1" "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 "Minimum-2.2" "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 "Minimum-2.3" "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 "Maximum-1.0" "Maximum of constant function" {
   set result [maximum -1.0 1.0 ::optimizetest::const_func]
   within_range $result -1.0 1.0
} 1

test "Maximum-2.0" "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 "Maximum-2.1" "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 "Maximum-2.2" "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

#
# Test the solveLinearProgram procedure
# - not implemented yet
#
if { 0 } {
set symm_constraints {
       { 1.0   2.0  1.0 }
       { 2.0   1.0  1.0 } }

test "LinearProg-1.0" "Symmetric constraints, case 1" {
   set result [solveLinearProgram $::symm_constraints {1.0 1.0}]
   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
} 1

test "LinearProg-1.1" "Symmetric constraints, case 2" {
   set result [solveLinearProgram $::symm_constraints {1.0 0.0}]
   set ok 1
   if { ! [within_range [lindex $result 0]  0.999900 1.000100] ||
        ! [within_range [lindex $result 1] -0.000100 0.000100] } {
         set ok 0
   }
   set ok
} 1

test "LinearProg-1.2" "Symmetric constraints, case 3" {
   set result [solveLinearProgram $::symm_constraints {0.0 1.0}]
   set ok 1
   if { ! [within_range [lindex $result 1]  0.999900 1.000100] ||
        ! [within_range [lindex $result 0] -0.000100 0.000100] } {
         set ok 0
   }
   set ok
} 1

test "LinearProg-1.3" "Symmetric constraints, case 4" {
   set result [solveLinearProgram $::symm_constraints {3.0 4.0}]
   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
} 1

test "LinearProg-2.1" "Unbounded program" {
   set result [solveLinearProgram {{1.0 -2.0 1.0} {-2.0 1.0 1.0}} {3.0 4.0}]
} "unbounded"

test "LinearProg-2.2" "Infeasible program" {
   set result [solveLinearProgram {{1.0  0.0 2.0} {1.0 1.0 1.0}} {1.0 1.0}]
} "infeasible"

test "LinearProg-3.1" "Simple 3D program" {
   set result [solveLinearProgram \
      {{1.0  1.0  2.0  1.0}
       {1.0  2.0  1.0  1.0}
       {2.0  1.0  1.0  1.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
} 1

test "LinearProg-3.2" "Redundant constraints" {
   set result [solveLinearProgram \
      {{1.0  0.0 10.0}
       {0.0  1.0 10.0}
       {-1.0 -2.0 -1.0}
       {-1.0 -1.0 -1.0}} {1.0 1.0}]
   set ok 1
   # Expected answer?
   #if { ! [within_range [lindex $result 0]  0.249900 0.250100] ||
   #     ! [within_range [lindex $result 1]  0.249900 0.250100] } {
   #      set ok 0
   #}
   set ok
} 1

} ;# End of if 0

} ;# End of optimizetest namespace
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































Deleted modules/math/pdf_stat.tcl.

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

# ::math::statistics --
#   Namespace holding the procedures and variables
#
namespace eval ::math::statistics {

    namespace export pdf-normal pdf-uniform \
	    pdf-exponential \
	    cdf-normal cdf-uniform \
	    cdf-exponential \
	    cdf-students-t \
	    random-normal random-uniform \
	    random-exponential \
	    histogram-uniform

    variable cdf_normal_prob     {}
    variable cdf_normal_x        {}
    variable cdf_toms322_cached  {}
}

# 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-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-$min)}]

    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 { $stdev <= 0.0 } {
	return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV
    }
    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/$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-$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-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)/($pmax-$min)}]

    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/$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

    # 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)/($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

    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
#
proc ::math::statistics::random-normal { mean stdev number } {

    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()}]]
    }

    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 } {
    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"
	"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]
}

# Initialisation --
#    Initialise some parameters
#
namespace eval ::math::statistics {
    Initialise-cdf-normal
}

#
# Simple numerical tests
#
if { [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
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/pkgIndex.tcl.

1
2
3
4
5
6
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded math             1.2.2 [list source [file join $dir math.tcl]]
package ifneeded math::geometry   1.0.1 [list source [file join $dir geometry.tcl]]
package ifneeded math::calculus   0.5   [list source [file join $dir calculus.tcl]]
package ifneeded math::fuzzy      0.2   [list source [file join $dir fuzzy.tcl]]
package ifneeded math::statistics 0.1   [list source [file join $dir statistics.tcl]]
<
<
<
<
<
<












Deleted modules/math/plotstat.tcl.

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
















































































































































































































































































































































































































































































































































































































































Deleted modules/math/statistics.man.

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

The [package math::statistics] package contains functions and procedures for
basic statistical data analysis, such as:

[list_begin bullet]
[bullet]
Descriptive statistical parameters (mean, minimum, maximum, standard
deviation)

[bullet]
Estimates of the distribution in the form of histograms and quantiles

[bullet]
Basic testing of hypotheses

[bullet]
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 [emph mean] value of the given list of data.
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::min] [arg data]]
Determine the [emph minimum] value of the given list of data.
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::max] [arg data]]
Determine the [emph maximum] value of the given list of data.
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::number] [arg data]]
Determine the [emph number] of non-missing data in the given list
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::stdev] [arg data]]
Determine the [emph "standard deviation"] of the data in the given list
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::var] [arg data]]
Determine the [emph variance] of the data in the given list
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::basic-stats] [arg data]]
Determine a list of all the descriptive parameters: mean, minimum,
maximum, number of data, standard deviation and variance.
[nl]
(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.)
[nl]
[arg data] - List of data
[nl]

[call [cmd ::math::statistics::histogram] [arg limits] [arg values]]
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.)
[nl]
[arg limits] - List of upper limits (in ascending order) for the
intervals of the histogram.
[nl]
[arg values] - List of data
[nl]

[call [cmd ::math::statistics::corr] [arg data1] [arg data2]]
Determine the correlation coefficient between two sets of data.
[nl]
[arg data1] - First list of data
[nl]
[arg data2] - Second list of data
[nl]

[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)
[nl]
[arg data] - List of raw data values (small sample)
[nl]
[arg confidence] - Confidence level (0.95 or 0.99 for instance)
[nl]

[call [cmd ::math::statistics::t-test-mean] [arg data] [arg est_mean] \
[arg est_stdev] [arg confidence]]
Test whether the mean value of a sample is in accordance with the
estimated normal distribution with a certain level of confidence.
Returns 1 if the test succeeds or 0 if the mean is unlikely to fit
the given distribution.
[nl]
[arg data] - List of raw data values (small sample)
[nl]
[arg est_mean] - Estimated mean of the distribution
[nl]
[arg est_stdev] - Estimated stdev of the distribution
[nl]
[arg confidence] - Confidence level (0.95 or 0.99 for instance)
[nl]

[call [cmd ::math::statistics::quantiles] [arg data] [arg confidence]]
Return the quantiles for a given set of data
[nl]
[arg data] - List of raw data values
[nl]
[arg confidence] - Confidence level (0.95 or 0.99 for instance)
[nl]

[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)
[nl]
[arg limits] - List of upper limits from histogram
[nl]
[arg counts] - List of counts for for each interval in histogram
[nl]
[arg confidence] -  Confidence level (0.95 or 0.99 for instance)
[nl]

[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)
[nl]
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
[nl]
[arg data] - Raw data for which the autocorrelation must be determined
[nl]

[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)
[nl]
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.
[nl]
[arg data1] - First list of data
[nl]
[arg data2] - Second list of data
[nl]

[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
[nl]
Convenience function - the result is suitable for the histogram function.
[nl]
[arg mean] - Mean of the data
[nl]
[arg stdev] - Standard deviation
[nl]
[arg number] - Number of limits to generate (defaults to 8)
[nl]

[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
[nl]
Convenience function - the result is suitable for the histogram function.
[nl]
[arg min] - Expected minimum
[nl]
[arg max] - Expected maximum
[nl]
[arg number] - Number of limits to generate (defaults to 8)
[nl]

[list_end]

[section "STATISTICAL DISTRIBUTIONS"]
In the literature a large number of probability distributions can be
found. The statistics package supports:
[list_begin bullet]
[bullet]
The normal or Gaussian distribution
[bullet]
The uniform distribution - equal probability for all data within a given
interval
[bullet]
The exponential distribution - useful as a model for certain
extreme-value distributions.
[bullet]
PM - binomial, Poisson, chi-squared, student's T, F.
[list_end]

In principle for each distribution one has procedures for:
[list_begin bullet]
[bullet]
The probability density (pdf-*)
[bullet]
The cumulative density (cdf-*)
[bullet]
Quantiles for the given distribution (quantiles-*)
[bullet]
Histograms for the given distribution (histogram-*)
[bullet]
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.
[nl]
[arg mean] - Mean value of the distribution
[nl]
[arg stdev] - Standard deviation of the distribution
[nl]
[arg value] - Value for which the probability is required
[nl]

[call [cmd ::math::statistics::pdf-exponential] [arg mean] [arg value]]
Return the probability of a given value for an exponential
distribution with given mean.
[nl]
[arg mean] - Mean value of the distribution
[nl]
[arg value] - Value for which the probability is required
[nl]

[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.
[nl]
[arg xmin] - Minimum value of the distribution
[nl]
[arg xmin] - Maximum value of the distribution
[nl]
[arg value] - Value for which the probability is required
[nl]

[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.
[nl]
[arg mean] - Mean value of the distribution
[nl]
[arg stdev] - Standard deviation of the distribution
[nl]
[arg value] - Value for which the probability is required
[nl]

[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.
[nl]
[arg mean] - Mean value of the distribution
[nl]
[arg value] - Value for which the probability is required
[nl]

[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.
[nl]
[arg xmin] - Minimum value of the distribution
[nl]
[arg xmin] - Maximum value of the distribution
[nl]
[arg value] - Value for which the probability is required
[nl]

[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.
[nl]
[arg degrees] - Number of degrees of freedom
[nl]
[arg value] - Value for which the probability is required
[nl]

[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.
[nl]
[arg mean] - Mean value of the distribution
[nl]
[arg stdev] - Standard deviation of the distribution
[nl]
[arg number] - Number of values to be returned
[nl]

[call [cmd ::math::statistics::random-exponential] [arg mean] [arg number]]
Return a list of "number" random values satisfying an exponential
distribution with given mean.
[nl]
[arg mean] - Mean value of the distribution
[nl]
[arg number] - Number of values to be returned
[nl]

[call [cmd ::math::statistics::random-uniform] [arg xmin] [arg xmax] [arg value]]
Return a list of "number" random values satisfying a uniform
distribution with given extremes.
[nl]
[arg xmin] - Minimum value of the distribution
[nl]
[arg xmin] - Maximum value of the distribution
[nl]
[arg number] - Number of values to be returned
[nl]

[call [cmd ::math::statistics::histogram-uniform] [arg xmin] [arg xmax] [arg limits] [arg number]]
Return the expected histogram for a uniform distribution.
[nl]
[arg xmin] - Minimum value of the distribution
[nl]
[arg xmax] - Maximum value of the distribution
[nl]
[arg limits] - Upper limits for the buckets in the histogram
[nl]
[arg number] - Total number of "observations" in the histogram
[nl]


[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]).
[nl]
[arg varname] - Name of the variable used in the expression
[nl]
[arg data] - List of data
[nl]
[arg expression] - Logical expression using the variable name
[nl]

[call [cmd ::math::statistics::map] [arg varname] [arg data] [arg expression]]
Return a list consisting of the data that are transformed via the
expression.
[nl]
[arg varname] - Name of the variable used in the expression
[nl]
[arg data] - List of data
[nl]
[arg expression] - Expression to be used to transform (map) the data
[nl]

[call [cmd ::math::statistics::samplescount] [arg varname] [arg list] [arg expression]]
Return a list consisting of the [emph counts] of all data in the
sublists of the "list" argument for which the expression is true.
[nl]
[arg varname] - Name of the variable used in the expression
[nl]
[arg data] - List of sublists, each containing the data
[nl]
[arg expression] - Logical expression to test the data (defaults to
"true").
[nl]

[call [cmd ::math::statistics::subdivide]]
Routine [emph PM] - not implemented yet

[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.
[nl]
[arg canvas] - Canvas widget to use
[nl]
[arg xmin] - Minimum x value
[nl]
[arg xmax] - Maximum x value
[nl]
[arg ymin] - Minimum y value
[nl]
[arg ymax] - Maximum y value
[nl]

[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.
[nl]
[arg canvas] - Canvas widget to use
[nl]
[arg xdata] - Series of independent data
[nl]
[arg ydata] - Series of dependent data
[nl]
[arg tag] - Tag to give to the plotted data (defaults to xyplot)
[nl]

[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.
[nl]
[arg canvas] - Canvas widget to use
[nl]
[arg xdata] - Series of independent data
[nl]
[arg ydata] - Series of dependent data
[nl]
[arg tag] - Tag to give to the plotted data (defaults to xyplot)
[nl]

[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.
[nl]
[arg canvas] - Canvas widget to use
[nl]
[arg tdata] - Series of dependent data
[nl]
[arg tag] - Tag to give to the plotted data (defaults to xyplot)
[nl]

[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.
[nl]
[arg canvas] - Canvas widget to use
[nl]
[arg tdata] - Series of dependent data
[nl]
[arg tag] - Tag to give to the plotted data (defaults to xyplot)
[nl]

[call [cmd ::math::statistics::plot-histogram] [arg canvas] \
[arg counts] [arg limits] [arg tag]]
Create a simple histogram in the given canvas
[nl]
[arg canvas] - Canvas widget to use
[nl]
[arg counts] - Series of bucket counts
[nl]
[arg limits] - Series of upper limits for the buckets
[nl]
[arg tag] - Tag to give to the plotted data (defaults to xyplot)
[nl]

[list_end]

[section {THINGS TO DO}]
The following procedures are yet to be implemented:
[list_begin bullet]
[bullet]
F-test-stdev
[bullet]
interval-mean-stdev
[bullet]
histogram-normal
[bullet]
histogram-exponential
[bullet]
test-histogram
[bullet]
linear-model
[bullet]
linear-residuals
[bullet]
test-corr
[bullet]
quantiles-*
[bullet]
fourier-coeffs
[bullet]
fourier-residuals
[bullet]
onepar-function-fit
[bullet]
onepar-function-residuals
[bullet]
plot-linear-model
[bullet]
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 bullet]
[bullet]
There is a strong correlation between two time series, as displayed by
the raw data and especially by the correlation functions.
[bullet]
Both time series show a significant periodic component
[bullet]
The histograms are not very useful in identifying the nature of the time
series - they do not show the periodic nature.
[list_end]

[keywords mathematics "data analysis" statistics]

[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/statistics.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
# statistics.tcl --
#
#    Package for basic statistical analysis
#
# version 0.1: initial implementation, january 2003

package provide math::statistics 0.1

# ::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 basic-stats corr \
	    histogram interval-mean-stdev test-mean quantiles \
	    autocorr crosscorr filter map samplescount
    #
    # 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))}]
}

# mean, min, max, number, var, stdev --
#    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} {
	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

    set min    {}
    set max    {}
    set mean   {}
    set stdev  {}
    set var    {}

    set sum    0.0
    set sumsq  0.0
    set number 0

    foreach value $values {
	if { $value == {} } {
	    continue
	}
	set value [expr {double($value)}]

	incr number
	set  sum    [expr {$sum+$value}]
	set  sumsq  [expr {$sumsq+$value*$value}]

	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*$sum)/double($number-1)}]
	set stdev  [expr {sqrt($var)}]
    }

    set all [list $mean $min $max $number $stdev $var]

    #
    # Return the appropriate value
    #
    if { [lsearch {all mean min max number stdev var} $type] >= 0 } {
	# FRINK: nocheck
	return [set $type]
    } else {
	return -code error \
		-errorcode ARG -errorinfo [list unknown type of statistic -- $type] \
		[list unknown type of statistic -- $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
#
# Results:
#    List of number of values in each bucket (length is one more than
#    the number of limits)
#
#
proc ::math::statistics::histogram { limits values } {

    if { [llength $limits] < 1 } {
	return -code error -errorcode ARG -errorinfo {No limits given} {No limits given}
    }

    set limits [lsort -real -increasing $limits]

    for { set index 0 } { $index <= [llength $limits] } { incr index } {
	set buckets($index) 0
    }
    set last [llength $limits]

    foreach value $values {
	if { $value == {} } {
	    continue
	}

	set index 0
	set found 0
	foreach limit $limits {
	    if { $value <= $limit } {
		set found 1
		incr buckets($index)
		break
	    }
	    incr index
	}

	if { $found == 0 } {
	    incr buckets($last)
	}
    }

    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
}

# test-normal --
#    Test whether the data are distributed according to the normal
#    distribution with a certain level of confidence
#
# Arguments:
#    data         List of raw data values
#    confidence   Confidence level (0.95 or 0.99 for instance)
#
# Result:
#    1 if the test shows a normal distribution, 0 otherwise
#
proc ::math::statistics::test-normal { data confidence } {
    ...
}

# t-test-mean --
#    Test whether the mean value of a sample is in accordance with the
#    estimated normal distribution with a certain level of confidence
#    (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
#    confidence   Confidence 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 confidence } {
    variable NEGSTDEV
    variable TOOFEWDATA

    if { $est_stdev <= 0.0 } {
	return -code error -errorcode ARG -errorinfo $NEGSTDEV $NEGSTDEV
    }

    set allstats        [BasicStats all $data]

    set conf2           [expr {(1.0+$confidence)/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<$conf2}]

    } 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
    variable student_t_table

    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 \
		[::math::interpolation::interpolate2d $student_t_table \
		$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
#
# Arguments:
#    xdata        Series of independent (X) data
#    ydata        Series of dependent (Y) data
#
# Result:
#    List of the following items:
#    PM
#
proc ::math::statistics::linear-model { xdata ydata } {
    variable TOOFEWDATA

    if { [llength $xdata] < 1 } {
	return -code error -errorcode ARG "$TOOFEWDATA: no independent data"
    }
    if { [llength $ydata] < 1 } {
	return -code error -errorcode ARG "$TOOFEWDATA: no dependent data"
    }

    # PM
}

# 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
#
# Result:
#    List of differences
#
proc ::math::statistics::linear-residuals { xdata ydata } {
    variable TOOFEWDATA

    if { [llength $xdata] < 1 } {
	return -code error -errorcode ARG "$TOOFEWDATA: no independent data"
    }
    if { [llength $ydata] < 1 } {
	return -code error -errorcode ARG "$TOOFEWDATA: no dependent data"
    }

    # PM
}

#
# 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]

#
# 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 { [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]

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/math/statistics.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest 2.1
    namespace import ::tcltest::*
} else {
    # Ensure that 2.1 or higher present.

    if {![package vsatisfies [package present tcltest] 2.1]} {
	puts "Aborting tests for math::statistics."
	puts "Requiring tcltest 2.1, have [package present tcltest]"
	return
    }
}

source [file join [file dirname [info script]] statistics.tcl]

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]

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]

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.3" "Basic statistics - linear data - min" -match tolerant  -body {
  set value [::math::statistics::min $::data_linear]
} -result 1.0

test "BasicStats-1.4" "Basic statistics - linear data - max" -match tolerant  -body {
  set value [::math::statistics::max $::data_linear]
} -result 10.0

test "BasicStats-1.5" "Basic statistics - linear data - number" -match tolerant  -body {
  set value [::math::statistics::number $::data_linear]
} -result 10

test "BasicStats-1.6" "Basic statistics - missing data - number" -match tolerant  -body {
  set value [::math::statistics::number $::data_missing2]
} -result 10

test "BasicStats-1.7" "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.8" "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

#
# 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}

#
# Quantiles
#
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}

  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}]

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.0" "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.1" "Pairs sublist" -match matchList -body {
   set data [::math::statistics::samplescount x $::data_pairs]
} -result {2 2 2 2 2}

test "Samplescount-1.2" "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}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































Deleted modules/math/tclIndex.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
# 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]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































Deleted modules/md4/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
2003-04-18  Pat Thoyts  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* md4.test: 
	* md4.tcl:
	* md4.man:
	* ChangeLog:  Initial versions.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































Deleted modules/md4/c_src/md4.c.

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

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































Deleted modules/md4/c_src/md4.h.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
/* 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.
 */

/* 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 long 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 *));

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































Deleted modules/md4/md4.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
[manpage_begin md4 n 1.0.0]
[moddesc   {md4}]
[copyright {2003, Pat Thoyts <[email protected]>}]
[titledesc {MD4 Message-Digest Algorithm}]
[require Tcl 8.2]
[require md4 [opt 1.0.0]]
[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).

[section {COMMANDS}]

[list_begin definitions]

[call [cmd "::md4::md4"] [opt "[arg -hex]"] [arg "string"]]

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.

[list_end]

[section {EXAMPLES}]

[example {
% md4::md4 -hex "Tcl does MD4"
858DA9B31F57648A032230447BD15F25
}]

[section {REFERENCES}]

[list_begin enum]

[enum]
       Rivest, R., "The MD4 Message Digest Algorithm", RFC 1320, MIT,
       April 1992.

[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.

[list_end]

[see_also md5 sha1]

[keywords md4 hashing message-digest security]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































Deleted modules/md4/md4.tcl.

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

package require Tcl 8.2;                # tcl minimum version
catch {package require md4c 1.0};       # tcllib critcl alternative

namespace eval ::md4 {
    variable version 1.0.0
    variable rcsid {$Id: md4.tcl,v 1.3 2003/04/18 22:28:24 patthoyts Exp $}

    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
    set token [namespace current]::[incr uid]
    upvar #0 $token tok

    # RFC1320:3.3 - Initialize MD4 state structure
    array set tok \
        [list \
             A [expr 0x67452301] \
             B [expr 0xefcdab89] \
             C [expr 0x98badcfe] \
             D [expr 0x10325476] \
             n 0 i "" ]
    return $token
}

proc ::md4::MD4Update {token data} {
    variable $token
    upvar 0 $token state

    if {[package provide md4c] != {}} {
        if {[info exists state(md4c)]} {
            set state(md4c) [md4c $data $state(md4c)]
        } else {
            set state(md4c) [md4c $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} {
    variable $token
    upvar 0 $token state

    if {[package provide md4c] != {}} {
        set r $state(md4c)
        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 [binary format i4 [list $state(A) $state(B) $state(C) $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.
    set [subst $tok](Ko) $Ko

    return $tok
}

proc ::md4::HMACUpdate {token data} {
    MD4Update $token $data
    return
}

proc ::md4::HMACFinal {token} {
    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.)
        set state(A) [expr {($A + $state(A)) & 0xFFFFFFFF}]
        set state(B) [expr {($B + $state(B)) & 0xFFFFFFFF}]
        set state(C) [expr {($C + $state(C)) & 0xFFFFFFFF}]
        set state(D) [expr {($D + $state(D)) & 0xFFFFFFFF}]
    }

    return
}

# 32bit rotate-left
proc ::md4::<<< {v n} {
    set v [expr {(($v << $n) | (($v >> (32 - $n)) & (0x7FFFFFFF >> (31 - $n))))}]
    return [expr {$v & 0xFFFFFFFF}]
}

# Convert our <<< pseuodo-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

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

if {[package provide Trf] != {}} {
    interp alias {} ::md4::Hex {} ::hex -mode encode
} else {
    proc ::md4::Hex {data} {
        set result {}
        binary scan $data c* r
        foreach c $r {
            append result [format "%02X" [expr {$c & 0xff}]]
        }
        return $result
    }
}

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

# 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}} {
    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] }
            --         { 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(-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]
        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 -key {}}
    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] }
            --         { 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 "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)]
        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
}

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

package provide md4 $::md4::version

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


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/md4/md4.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
# md4.test - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# $Id: md4.test,v 1.3 2003/04/18 22:28:24 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require md4
if {[package provide md4c] == {}} {
    puts "md4 [package provide md4] (pure Tcl)"
} else {
    puts "md4 [package provide md4] (using md4c)"
}

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

# The RFC 1320 test vectors
#
foreach {n msg hash} {
    1 {}    {31D6CFE0D16AE931B73C59D7E0C089C0}
    2 {a}   {BDE52CB31DE33E46245E05FBDBD6FB24}
    3 {abc} {A448017AAF21D8525FC10AE87AA6729D} 
    4 {message digest} {D9130A8164549FE818874806E1C7014B}
    5 {abcdefghijklmnopqrstuvwxyz} {D79E1C308AA5BBCDEEA8ED63DF412DA9}
    6 {ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789}
    {043F8582F241DB351CE627E153E7F0E4}
    7 {12345678901234567890123456789012345678901234567890123456789012345678901234567890}
    {E33B4DDC9C38F2199C3E7B164FCC0536}
} {
    test md4-1.$n {md4 RFC test strings} {
        ::md4::md4 -hex $msg
    } $hash
}

# Block length checks
#  these values are generated from the OpenSSL library implementation
#  by md4_check.c
#
foreach {n hash} {
    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
} {
    test md4-2.$n "md4 block size checks: length $n" {
        ::md4::md4 -hex [string repeat a $n]
    } $hash
}

::tcltest::cleanupTests

# -------------------------------------------------------------------------
# Local Variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































Deleted modules/md4/md4_check.c.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
/* md4_check.c Copyright (C) 2003 Pat Thoyts <[email protected]>
 *
 * 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.1 2003/04/17 23:29:13 patthoyts Exp $
 */

#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <openssl/md4.h>

static const char rcsid[] = 
"$Id: md4_check.c,v 1.1 2003/04/17 23:29:13 patthoyts 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:
 */
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































Deleted modules/md4/md4c.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
# md4c.tcl - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# 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 md4c 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.1 2003/04/18 22:28:24 patthoyts Exp $

package require critcl
package provide md4c 1.0.0

critcl::cheaders c_src/md4.h
critcl::csources c_src/md4.c

namespace eval ::md4 {

    critcl::ccode {
        #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;
        
        /* Tcl_RegisterObjType(&md4_type); */
        
        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 {
            obj = Tcl_NewObj();
            ctx = (MD4_CTX *)Tcl_Alloc(sizeof(MD4_CTX));
            MD4Init(ctx);
        
            if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL)
                obj->typePtr->freeIntRepProc(obj);
        
            obj->internalRep.otherValuePtr = ctx;
            obj->typePtr = &md4_type;
        }
    
        Tcl_SetObjResult(interp, obj);
        Tcl_IncrRefCount(obj); //!! huh?
        
        Tcl_InvalidateStringRep(obj);
        ctx = (MD4_CTX *)obj->internalRep.otherValuePtr;
    
        data = Tcl_GetByteArrayFromObj(objv[1], &size);
        MD4Update(ctx, data, size);
    
        return TCL_OK;
    }
}

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


























































































































































































































































Deleted modules/md4/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
# pkgIndex.tcl - 
#
# md4 package index file
#
# This package has been tested with tcl 8.2.3 and above.
#
# $Id: pkgIndex.tcl,v 1.1 2003/04/15 21:25:16 patthoyts Exp $

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded md4 1.0.0 [list source [file join $dir md4.tcl]]
<
<
<
<
<
<
<
<
<
<




















Changes to modules/md5/ChangeLog.

















1
2
3
4
5
6
7
















2003-04-11  Andreas Kupries  <[email protected]>

	* md5.tcl:
	* md5.man:
	* pkgIndex.tcl: Set version of the package to to 1.4.3.

2003-02-05  David N. Welton  <[email protected]>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
2003-05-13  Pat Thoyts  <[email protected]>

	* md5c.tcl:  Brought in the critcl implementation of MD5
	* md5.c:     originally by Jean-Claude Wippler <[email protected]>
	* 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-04-11  Andreas Kupries  <[email protected]>

	* md5.tcl:
	* md5.man:
	* pkgIndex.tcl: Set version of the package to to 1.4.3.

2003-02-05  David N. Welton  <[email protected]>

Added modules/md5/md5.c.











































































































































































































































































































































































































































































































































































































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

Added modules/md5/md5.h.













































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
#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 */
#ifdef __alpha
typedef unsigned int UINT4;
#else
typedef unsigned long int UINT4;
#endif

/* 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

Deleted modules/md5/md5.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
'\" 
'\" Copyright (c) 2001 ActiveState Tool Corp.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: md5.n,v 1.6 2002/02/08 06:05:20 andreas_kupries Exp $
'\" 
.so man.macros
.TH md5 n 1.4.2 Md5 "md5 hash"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
::md5::md5 \- Perform md5 hashing
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require md5 ?1.4.2?\fR
.sp
\fB::md5::md5\fR \fImsg\fR?
.sp
\fB::md5::hmac\fR \fIkey text\fR
.sp
.BE
.SH DESCRIPTION
.PP
This package provides commands to compute a MD5 digests of arbitrary
messages.
.SH COMMANDS
.TP
\fB::md5::md5\fR \fImsg\fR
The command takes a message and returns the MD5 digest of this message
as a hexadecimal string.
.TP
\fB::md5::hmac\fR \fIkey text\fR
The command takes a key string and a text and returns the hmac of the
text under the chosen key as a hexadecimal string.
.SH EXAMPLES
.PP
.CS
% md5::md5 "hello world"
5eb63bbbe01eeed093cb22bb8f5acdc3
.CE
.PP
.CS
% md5::hmac "our little secret" "hello world"
61a922114c8aaf5050098be6d3a7daf0
.CE
.SH KEYWORDS
md5, hashing, security
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































Changes to modules/md5/md5.test.

1
2
3
4
5
6
7
8
9
10
11
12



13
14
15
16
17



18














19
20
21
22
23
24

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
# -*- 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.4 2003/01/07 00:15:53 patthoyts Exp $




if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}




package require md5














if {[catch {package present Trf}] || [catch {::md5 -- test}]} {
    puts "md5 [package present md5] (pure Tcl)"
} else {
    puts "md5 [package present md5] (Trf based)"
}



test md5-1.0 {md5} {
    catch {::md5::md5} result
    set result
} [tcltest::getErrorMessage "::md5::md5" "msg" 0]

test md5-1.1 {md5} {
    catch {::md5::hmac} result
    set result
} [tcltest::getErrorMessage "::md5::hmac" "key text" 0]

test md5-1.2 {md5} {
    catch {::md5::hmac key} result
    set result
} [tcltest::getErrorMessage "::md5::hmac" "key text" 1]


foreach {n msg expected} {
    1    ""
    "d41d8cd98f00b204e9800998ecf8427e"
    2    "a"
    "0cc175b9c0f1b6a831c399e269772661"










|

>
>
>





>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|

|


>




|




|




|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
# -*- 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.4.2.2 2004/09/25 14:23:30 patthoyts Exp $

# -------------------------------------------------------------------------
# Initialize the test package
#
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget md5
catch {namespace delete ::md5}
if {[catch {source [file join [file dirname [info script]] md5.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

if {[catch {package present Trf}] || [catch {::md5 -- test}]} {
    puts "- md5 [package present md5] (pure Tcl)"
} else {
    puts "- md5 [package present md5] (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"

Added modules/md5/md5c.tcl.























































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
# md5c.tcl - 
#
# Wrapper for RSA's Message Digest in C
#
# Written by Jean-Claude Wippler <[email protected]>
#
# $Id: md5c.tcl,v 1.1.2.1 2003/07/24 23:00:53 patthoyts Exp $

package require critcl;                 # needs critcl
package provide md5c 0.11;              # 

critcl::cheaders md5.h;                 # The RSA header file
critcl::csources md5.c;                 # The RSA MD5 implementation.

namespace eval ::md5 {

    critcl::ccode {
        #include "md5.h"
        #include <malloc.h>
        #include <memory.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;
            free(mp);
        }
        
        static void
        md5_dup_rep(Tcl_Obj* obj, Tcl_Obj* dup)
        {
            MD5_CTX* mp = (MD5_CTX*) obj->internalRep.otherValuePtr;
            dup->internalRep.otherValuePtr = malloc(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;
        
        //Tcl_RegisterObjType(&md5_type);
        
        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 {
            obj = Tcl_NewObj();
            mp = (MD5_CTX*) malloc(sizeof *mp);
            MD5Init(mp);
            
            if (obj->typePtr != NULL && obj->typePtr->freeIntRepProc != NULL)
            obj->typePtr->freeIntRepProc(obj);
            
            obj->internalRep.otherValuePtr = mp;
            obj->typePtr = &md5_type;
        }
        
        Tcl_SetObjResult(ip, obj);
        Tcl_IncrRefCount(obj); //!! huh?
        
        Tcl_InvalidateStringRep(obj);
        mp = (MD5_CTX*) obj->internalRep.otherValuePtr;
        
        data = Tcl_GetByteArrayFromObj(objv[1], &size);
        MD5Update(mp, data, size);
        
        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
}

Added modules/md5/md5x.tcl.





































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































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

package require Tcl 8.2;                # tcl minimum version

# Try and load a compiled extension to help.
if {[catch {package require tcllibc}]} {
    if {[catch {package require md5c}]} {
        catch {
            package requre Trf
            package require Memchan
        }
    }
}

namespace eval ::md5 {
    variable version 2.0.0
    variable rcsid {$Id: md5x.tcl,v 1.1.2.2 2003/07/24 23:00:53 patthoyts Exp $}

    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 uid
    set token [namespace current]::[incr uid]
    upvar #0 $token tok

    # RFC1321:3.3 - Initialize MD5 state structure
    array set tok \
        [list \
             A [expr 0x67452301] \
             B [expr 0xefcdab89] \
             C [expr 0x98badcfe] \
             D [expr 0x10325476] \
             n 0 i "" ]
    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 $token
    upvar 0 $token state

    if {[info command ::md5::md5c] != {}} {
        if {[info exists state(md5c)]} {
            set state(md5c) [md5c $data $state(md5c)]
        } else {
            set state(md5c) [md5c $data]
        }
        return
    } elseif {[package provide Trf] != {} \
                  && [package provide Memchan] != {} \
                  && 0 } {
        # FIX ME - currently Trf usage is disabled by the above line.
        # We have Trf and Memchan so we can create a bucket with these.
        if {![info exists state(trf)]} {
            set state(trf) [::null]
            ::md5 -attach $state(trf) -mode write \
                -read-type variable \
                -read-destination [subst $token](trfread) \
                -write-type variable \
                -write-destination [subst $token](trfwrite)
            fconfigure $state(trf) -translation binary -buffering none
        }
        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} {
    variable $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(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.
    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} {
    variable $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} {
    set v [expr {(($v << $n) | (($v >> (32 - $n)) & (0x7FFFFFFF >> (31 - $n))))}]
    return [expr {$v & 0xFFFFFFFF}]
}

# Convert our <<< pseuodo-operator into a procedure call.
regsub -all -line \
    {\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \
    $::md5::MD5Hash_body \
    {[expr {\1 + [<<< [expr {\2}] \3]}]} \
    ::md5::MD5Hash_bodyX

# 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_bodyX \
    {( (\1 \& \2) | ((~\1) \& \3) )} \
    ::md5::MD5Hash_bodyX
    
# 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_bodyX \
    {(((\1 \& \3) | (\2 \& (~\3))))} \
    ::md5::MD5Hash_bodyX

# 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_bodyX \
    {(\1 ^ \2 ^ \3)} \
    ::md5::MD5Hash_bodyX

# 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_bodyX \
    {(\2 ^ (\1 | (~\3)))} \
    ::md5::MD5Hash_bodyX


# 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_bodyX [string map $map $::md5::MD5Hash_bodyX]
    unset map
}

# Define the MD5 hashing procedure with inline functions.
proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_bodyX

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

if {[package provide Trf] != {}} {
    interp alias {} ::md5::Hex {} ::hex -mode encode
} else {
    proc ::md5::Hex {data} {
        set result {}
        binary scan $data c* r
        foreach c $r {
            append result [format "%02X" [expr {$c & 0xff}]]
        }
        return $result
    }
}

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

# 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}} {
    variable $token
    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] }
            --         { 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(-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]
        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] }
            --         { 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 {![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)]
        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
}

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

package provide md5 $::md5::version

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


Added modules/md5/md5x.test.















































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
# -*- 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.1.2.2 2004/09/25 14:23:30 patthoyts Exp $

# -------------------------------------------------------------------------
# Initialize the test package
#
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget md5
catch {namespace delete ::md5}
if {[catch {source [file join [file dirname [info script]] md5x.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

# -------------------------------------------------------------------------
# Setup any constraints
#

# -------------------------------------------------------------------------
# Now the package specific tests....
# -------------------------------------------------------------------------

if {[info command ::md5::md5c] != {}} {
    puts "- md5 [package present md5] (critcl based)"
} elseif {[package provide Trf] != {} && ![catch {::md5 -- test}]} {
    puts "- md5 [package present md5] (Trf based)"
} else {
    puts "- md5 [package present md5] (pure Tcl)"
}

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

test md5-1.0 {md5} {
    catch {::md5::md5} result
    set result
} [tcltest::wrongNumArgs "md5" "?-hex? -filename file | string" 0]

test md5-1.1 {md5} {
    catch {::md5::hmac} result
    set result
} [tcltest::wrongNumArgs "hmac" "?-hex? -key key -filename file | string" 0]

test md5-1.2 {md5} {
    catch {::md5::hmac key} result
    set result
} [tcltest::wrongNumArgs "hmac" "?-hex? -key key -filename file | string" 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 -hex $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 -hex -key $key $text
    } $expected ; # {}
}

::tcltest::cleanupTests

Changes to modules/md5/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11

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 md5 1.4.3 [list source [file join $dir md5.tcl]]











>

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

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded md5 2.0.0 [list source [file join $dir md5x.tcl]]
package ifneeded md5 1.4.3 [list source [file join $dir md5.tcl]]

Deleted modules/mime/ChangeLog.

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

	* 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  <[email protected]>

	* mime.man: More semantic markup, less visual one.
	* smtp.man:

2003-01-06  Pat Thoyts  <[email protected]>

	* mime.tcl (md5): Fix for bug # 630381. Use tcllib md5 to handle
	  Trf transparency.

2002-10-01  Andreas Kupries  <[email protected]>

	* mime.man: Changed -parse to -part in description of
	  "::mime::initialize". Thanks to "Gerald W. Lester"
	  <[email protected]> for finding this.

2002-09-16  David N. Welton  <[email protected]>

	* smtp.man: Added example from http://mini.net/tcl/1256.

2002-09-14  Andreas Kupries  <[email protected]>

	* mime.test: Extended field_decode tests with the examples from
	  RFC 2047.

	* mime.tcl: Integrated new implementation of 'field_decode'
	  provided by Don Libes <[email protected]>. This rewrite correctly
	  decodes all seven examples of RFC 2047. The old version decoded
	  only one correctly.

2002-08-15  Andreas Kupries  <[email protected]>

	* mime.tcl: Accepted patch in SF FR #595240, provided by Marshall
	  T. Rose <[email protected]>. 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  <[email protected]>

	* smtp.tcl: Applied patch SF #557520/2 (== SF #558132) supplied by
	  Todd Coram <[email protected]>on behalf of Marshall
	  Rose <[email protected]>. 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
	  <[email protected]> on behalf of Marshall
	  Rose <[email protected]>. 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  <[email protected]>

	* mime.tcl: Fixed bug SF #548832. Report and patch by Michael
	  A. Cleverly <[email protected]>.

2002-05-29  Andreas Kupries  <[email protected]>

	* smtp.tcl (smtp::initialize): Fixed SF bug #561416. The reporter
	  is unknown and provided the fix too. Fix approved by Marshall
	  Rose <[email protected]>.

2002-05-08  Andreas Kupries  <[email protected]>

	* mime.tcl: Accepted patch for SF bug #553784, by Don Porter
	  <[email protected]>.

	* smtp.tcl: Applied patch for SF bug #539952, on behalf of
	  Marshall Rose <[email protected]>. 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  <[email protected]>

	* smtp.tcl: Applied patch for SF bug #547336 on behalf of Marshall
	  Rose <[email protected]>. Bug was reported by Don
	  Porter <[email protected]>. This removes the duplicate
	  [package require Trf] we had before.

2002-04-15  Andreas Kupries  <[email protected]>

	* mime.man: Added doctools manpage.
	* smtp.man: Added doctools manpage.

2002-04-04  Andreas Kupries  <[email protected]>

	* smtp.tcl: Accepted patch by Simon Scott
	  <[email protected]>, with slight modification. Fixes
	  bug #533025.

2002-02-27  Andreas Kupries  <[email protected]>

	* mime.tcl: Accepted patch for bug #519623 by Rolf Ade
	  <[email protected]>.

2002-02-01  Andreas Kupries  <[email protected]>

	* 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
	  <[email protected]> fixing a formatting problem.

2002-01-17  Andreas Kupries  <[email protected]>

	* Bumped version to 1.3.1

2002-01-17  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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
	  <[email protected]>.

2001-11-01  Andreas Kupries  <[email protected]>

	* 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
	  <[email protected]>.

2001-10-16  Andreas Kupries <[email protected]>

	* mime.n:
	* mime.tcl:
	* smtp.n:
	* smtp.tcl:
	* pkgIndex.tcl: Version up to 1.3

2001-09-12  Andreas Kupries <[email protected]>

	* Added manpages for smtp and mime packages.

2001-08-01  Jeff Hobbs  <[email protected]>

	* mime.tcl: made package require 8.3 and sped up qp_encode and
	qp_decode.

2001-07-10  Andreas Kupries <[email protected]>

	* smtp.tcl: 
	* mime.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* smtp.tcl:
	* mime.tcl: Fixed dubious code reported by frink and procheck.

2001-01-30  Eric Melski  <[email protected]>

	* 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  <[email protected]>

        * 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  <[email protected]>

        * 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  <[email protected]>
       
        * mime.tcl
        * mime.test: Integrated a patch from Laurent Riesterer 
        ([email protected]).  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  <[email protected]>

        * 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  <[email protected]>

	* README.xml: 
	* README.html: 
	* README.txtl: Clarified information about soft-dependancy on Trf.

2000-08-03  Dan Kuchler <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































Deleted modules/mime/README.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
<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;[email protected]>
    To: Andreas Kupries &lt;[email protected]>
    cc: [email protected] (Darren New)
    MIME-Version: 1.0
    Content-Type: text/plain; charset="us-ascii"
    Content-Description: a simple example
    Content-ID: &lt;[email protected]>
    
    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;[email protected]>"] \
      -header [list To "Andreas Kupries &lt;[email protected]>"] \
      -header [list cc "[email protected] (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:[email protected]">Freed, N.</a> and <a href="mailto:[email protected]">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:[email protected]">Freed, N.</a> and <a href="mailto:[email protected]">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:[email protected]">[email protected]</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:[email protected]">Darren New</a>'s
unpublished package of 1999.
</p>

<p>
This package makes use of 
<a href="mailto:[email protected]">Andreas Kupries</a>'s
excellent Trf package.
</p>
</font></body></html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/mime/README.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804


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 <[email protected]>
       To: Andreas Kupries <[email protected]>
       cc: [email protected] (Darren New)
       MIME-Version: 1.0
       Content-Type: text/plain; charset="us-ascii"
       Content-Description: a simple example
       Content-ID: <[email protected]>

       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 <[email protected]>"] \
         -header [list To "Andreas Kupries <[email protected]>"] \
         -header [list cc "[email protected] (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:[email protected]

   [7]  mailto:[email protected]


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: [email protected]


















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]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/mime/README.xml.

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

<t>This package makes use of 
<eref target="mailto:[email protected]">Andreas Kupries</eref>'s
excellent Trf package.</t>
</section>

</back>
</rfc>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/mime/mime.man.

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

This command creates a MIME part and returns a token representing it.

[list_begin bullet]

[bullet]

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 -part] option.

[nl]

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.

[nl]

Also, [option -encoding], if present, specifies the

[const Content-Transfer-Encoding] when copying the body.

[bullet]

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.

[nl]

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.

[nl]
The possible properties are:

[list_begin definitions]


[lst_item [const content]]

The type/subtype describing the content

[lst_item [const encoding]]

The "Content-Transfer-Encoding"

[lst_item [const params]]

A list of "Content-Type" parameters

[lst_item [const parts]]

A list of tokens for the part's subordinates.  This property is
present only if the MIME part has subordinates.

[lst_item [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.

[nl]

A header consists of zero or more key/value pairs. Each value is a
list containing one or more strings.

[nl]

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.

[nl]

The value for [option -mode] is one of:

[list_begin definitions]


[lst_item [const write]]

The [arg key]/[arg value] is either created or overwritten (the default).

[lst_item [const append]]

A new [arg value] is appended for the [arg key] (creating it as necessary).

[lst_item [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 -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.

[nl]

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]
}]

[nl]

(The [option -blocksize] option, if present, specifies the maximum
size of each fragment passed to the callback.)

[nl]

When the end of the body is reached, the callback is invoked as:

[example {
  uplevel #0 $callback "end"
}]

[nl]

Alternatively, if an error occurs, the callback is invoked as:

[example {
  uplevel #0 $callback [list "error" reason]
}]

[nl]

Regardless, the return value of the final invocation of the callback
is propagated upwards by mime::getbody.

[nl]

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.


[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.

[nl]

Each serialized array contains the properties below. Note that one or
more of these properties may be empty.

[list_begin definitions]


[lst_item [const address]]

local@domain

[lst_item [const comment]]

822-style comment

[lst_item [const domain]]

the domain part (rhs)

[lst_item [const error]]

non-empty on a parse error

[lst_item [const group]]

this address begins a group

[lst_item [const friendly]]

user-friendly rendering

[lst_item [const local]]

the local part (lhs)

[lst_item [const memberP]]

this address belongs to a group

[lst_item [const phrase]]

the phrase part

[lst_item [const proper]]

822-style address specification

[lst_item [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.

[nl]

The list of properties and their ranges are:

[list_begin definitions]


[lst_item [const hour]]

0 .. 23

[lst_item [const lmonth]]

January, February, ..., December

[lst_item [const lweekday]]

Sunday, Monday, ... Saturday

[lst_item [const mday]]

1 .. 31

[lst_item [const min]]

0 .. 59

[lst_item [const mon]]

1 .. 12

[lst_item [const month]]

Jan, Feb, ..., Dec

[lst_item [const proper]]

822-style date-time specification

[lst_item [const rclock]]

elapsed seconds between then and now

[lst_item [const sec]]

0 .. 59

[lst_item [const wday]]

0 .. 6 (Sun .. Mon)

[lst_item [const weekday]]

Sun, Mon, ..., Sat

[lst_item [const yday]]

1 .. 366

[lst_item [const year]]

1900 ...

[lst_item [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]

[see_also smtp pop3 ftp http]
[keywords mail email smtp mime rfc821 rfc822 internet net]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/mime/mime.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
'\"
'\" Copyright (c) 2000 Andreas Kupries
'\" All right reserved
'\"
'\" CVS: $Id: mime.n,v 1.5 2002/02/01 17:44:53 andreas_kupries Exp $ mime.n
'\"
.so man.macros
.TH "mime" n 1.3.2 tcllib "mime"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
mime \- Manipulation of MIME body parts
.SH "SYNOPSIS"
package require \fBTcl\fR
.sp
package require \fBmime ?1.3.2?\fR
.sp
\fBmime::initialize\fR ?-canonical \fItype/subtype\fR ?-param {\fIkey value\fR}...? ?-encoding \fIvalue\fR? ?-header {\fIkey value\fR}...?? (-file \fIname\fR | -string \fIvalue\fR | -parse {\fItoken1\fR ... \fItokenN\fR} )\fR
.sp
\fBmime::finalize\fR \fItoken\fR ?-subordinates \fBall\fR | \fBdynamic\fR | \fBnone\fR?\fR
.sp
\fBmime::getproperty\fR \fItoken\fR ?\fIproperty\fR | -names?\fR
.sp
\fBmime::getheader\fR \fItoken\fR ?\fIkey\fR | -names?\fR
.sp
\fBmime::setheader\fR \fItoken\fR \fIkey\fR \fIvalue\fR ?-mode \fBwrite\fR | \fBappend\fR | \fBdelete\fR?\fR
.sp
\fBmime::getbody\fR \fItoken\fR ?-command \fIcallback\fR ?-blocksize \fIoctets\fR??\fR
.sp
\fBmime::copymessage\fR \fItoken\fR \fIchannel\fR\fR
.sp
\fBmime::buildmessage\fR \fItoken\fR\fR
.sp
\fBmime::parseaddress\fR \fIstring\fR\fR
.sp
\fBmime::parsedatetime\fR (\fIstring\fR | -now) \fIproperty\fR\fR
.sp
\fBmime::mapencoding\fR \fIencoding_name\fR\fR
.sp
\fBmime::reversemapencoding\fR \fIcharset_type\fR\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
The mime library package provides the commands to create and
manipulate MIME body parts.
.TP
\fBmime::initialize\fR ?-canonical \fItype/subtype\fR ?-param {\fIkey value\fR}...? ?-encoding \fIvalue\fR? ?-header {\fIkey value\fR}...?? (-file \fIname\fR | -string \fIvalue\fR | -parse {\fItoken1\fR ... \fItokenN\fR} )\fR
This command creates a MIME part and returns a token representing it.
.RS
.TP
*
If the \fI-canonical\fR option is present, then the body is in
canonical (raw) form and is found by consulting either the \fI-file\fR,
\fI-string\fR, or \fI-part\fR option.
.sp
In addition, both the \fI-param\fR and \fI-header\fR options may occur zero
or more times to specify \fBContent-Type\fR parameters (e.g.,
\fIcharset\fR) and header keyword/values (e.g.,
\fIContent-Disposition\fR), respectively.
.sp
Also, \fI-encoding\fR, if present, specifies the
\fBContent-Transfer-Encoding\fR when copying the body.
.TP
*
If the \fI-canonical\fR option is not present, then the MIME part
contained in either the \fI-file\fR or the \fI-string\fR option is parsed,
dynamically generating subordinates as appropriate.
.RE
.TP
\fBmime::finalize\fR \fItoken\fR ?-subordinates \fBall\fR | \fBdynamic\fR | \fBnone\fR?\fR
This command destroys the MIME part represented by \fItoken\fR. It
returns an empty string.
.sp
If the \fI-subordinates\fR option is present, it specifies which
subordinates should also be destroyed. The default value is
\fBdynamic\fR, destroying all subordinates which were created by
\fBmime::initialize\fR together with the containing body part.
.TP
\fBmime::getproperty\fR \fItoken\fR ?\fIproperty\fR | -names?\fR
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 \fI-names\fR is specified, a list of all properties is
returned; otherwise, a serialized array of properties and values is
returned.
.sp The possible properties are:
.RS
.TP
\fBcontent\fR
The type/subtype describing the content
.TP
\fBencoding\fR
The "Content-Transfer-Encoding"
.TP
\fBparams\fR
A list of "Content-Type" parameters
.TP
\fBparts\fR
A list of tokens for the part's subordinates.  This property is
present only if the MIME part has subordinates.
.TP
\fBsize\fR
The approximate size of the content (unencoded)
.RE
.TP
\fBmime::getheader\fR \fItoken\fR ?\fIkey\fR | -names?\fR
This command returns the header of a MIME part, as a list of strings.
.sp
A header consists of zero or more key/value pairs. Each value is a
list containing one or more strings.
.sp
If this command is invoked with the name of a specific \fIkey\fR, 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.
.TP
\fBmime::setheader\fR \fItoken\fR \fIkey\fR \fIvalue\fR ?-mode \fBwrite\fR | \fBappend\fR | \fBdelete\fR?\fR
This command writes, appends to, or deletes the \fIvalue\fR associated
with a \fIkey\fR in the header. It returns a list of strings
containing the previous value associated with the key.
.sp
The value for \fI-mode\fR is one of:
.RS
.TP
\fBwrite\fR
The \fIkey\fR/\fIvalue\fR is either created or overwritten (the default).
.TP
\fBappend\fR
A new \fIvalue\fR is appended for the \fIkey\fR (creating it as necessary).
.TP
\fBdelete\fR
All values associated with the key are removed (the \fIvalue\fR
parameter is ignored).
.RE
.TP
\fBmime::getbody\fR \fItoken\fR ?-command \fIcallback\fR ?-blocksize \fIoctets\fR??\fR
This command returns a string containing the body of the leaf MIME
part represented by \fItoken\fR in canonical form.
.sp
If the \fI-command\fR option is present, then it is repeatedly
invoked with a fragment of the body as this:
\fBuplevel #0 $callback [list "data" $fragment] \fR
.sp
(The \fI-blocksize\fR option, if present, specifies the maximum size
of each fragment passed to the callback.)
.sp
When the end of the body is reached, the callback is invoked as:
\fBuplevel #0 $callback "end"\fR
.sp
Alternatively, if an error occurs, the callback is invoked as:
\fBuplevel #0 $callback [list "error" reason]\fR
.sp
Regardless, the return value of the final invocation of the callback
is propagated upwards by mime::getbody.
.sp
If the \fI-command\fR option is absent, then the return value of
\fBmime::getbody\fR is a string containing the MIME part's entire
body.
.TP
\fBmime::copymessage\fR \fItoken\fR \fIchannel\fR\fR
This command copies the MIME represented by \fItoken\fR part to the
specified \fIchannel\fR. The command operates synchronously, and uses
fileevent to allow asynchronous operations to proceed
independently. It returns an empty string.
.TP
\fBmime::buildmessage\fR \fItoken\fR\fR
This command returns the MIME part represented by \fItoken\fR as a
string.  It is similar to \fBmime::copymessage\fR, only it returns the
data as a return string instead of writing to a channel.
.TP
\fBmime::parseaddress\fR \fIstring\fR\fR
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.
.sp
Each serialized array contains the properties below. Note that one or
more of these properties may be empty.
.RS
.TP
\fBaddress\fR
local@domain
.TP
\fBcomment\fR
822-style comment
.TP
\fBdomain\fR
the domain part (rhs)
.TP
\fBerror\fR
non-empty on a parse error
.TP
\fBgroup\fR
this address begins a group
.TP
\fBfriendly\fR
user-friendly rendering
.TP
\fBlocal\fR
the local part (lhs)
.TP
\fBmemberP\fR
this address belongs to a group
.TP
\fBphrase\fR
the phrase part
.TP
\fBproper\fR
822-style address specification
.TP
\fBroute\fR
822-style route specification (obsolete)
.RE
.TP
\fBmime::parsedatetime\fR (\fIstring\fR | -now) \fIproperty\fR\fR
This command takes a string containing an 822-style date-time
specification and returns the specified property as a serialized array.
.sp
The list of properties and their ranges are:
.RS
.TP
\fBhour\fR
0 .. 23
.TP
\fBlmonth\fR
January, February, ..., December
.TP
\fBlweekday\fR
Sunday, Monday, ... Saturday
.TP
\fBmday\fR
1 .. 31
.TP
\fBmin\fR
0 .. 59
.TP
\fBmon\fR
1 .. 12
.TP
\fBmonth\fR
Jan, Feb, ..., Dec
.TP
\fBproper\fR
822-style date-time specification
.TP
\fBrclock\fR
elapsed seconds between then and now
.TP
\fBsec\fR
0 .. 59
.TP
\fBwday\fR
0 .. 6 (Sun .. Mon)
.TP
\fBweekday\fR
Sun, Mon, ..., Sat
.TP
\fByday\fR
1 .. 366
.TP
\fByear\fR
1900 ...
.TP
\fBzone\fR
-720 .. 720 (minutes east of GMT)
.RE
.TP
\fBmime::mapencoding\fR \fIencoding_name\fR\fR
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.
.TP
\fBmime::reversemapencoding\fR \fIcharset_type\fR\fR
This command maps MIME charset types onto tcl encoding names.  Those
that are unknown return "".
.SH "SEE ALSO"
smtp, pop3, ftp, http
.SH "KEYWORDS"
mail, email, smtp, mime, rfc821, rfc822, internet, net


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































Deleted modules/mime/mime.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
# mime.tcl - MIME body parts
#
# (c) 1999-2000 Marshall T. Rose
#
# 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.3

package provide mime 1.3.3

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
    package require md5 1.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]
        }
        proc md5 {-- string} {
	    return [md5::md5 $string]
        }
        proc unstack {channel} {
	    # do nothing
	    return
        }
    }
}        

#
# 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 }

# 822 lexemes
    variable addrtokenL  [list ";"          ","         \
                               "<"          ">"         \
                               ":"          "."         \
                               "("          ")"         \
                               "@"          "\""        \
                               "\["         "\]"        \
                               "\\"]
    variable addrlexemeL [list 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]

# 2045 lexemes
    variable typetokenL  [list ";"          ","         \
                               "<"          ">"         \
                               ":"          "?"         \
                               "("          ")"         \
                               "@"          "\""        \
                               "\["         "\]"        \
                               "="          "/"         \
                               "\\"]
    variable typelexemeL [list 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]

    set encList [list \
            ascii US-ASCII \
            big5 Big5 \
            cp1250 "" \
            cp1251 "" \
            cp1252 "" \
            cp1253 "" \
            cp1254 "" \
            cp1255 "" \
            cp1256 "" \
            cp1257 "" \
            cp1258 "" \
            cp437 "" \
            cp737 "" \
            cp775 "" \
            cp850 "" \
            cp852 "" \
            cp855 "" \
            cp857 "" \
            cp860 "" \
            cp861 "" \
            cp862 "" \
            cp863 "" \
            cp864 "" \
            cp865 "" \
            cp866 "" \
            cp869 "" \
            cp874 "" \
            cp932 "" \
            cp936 "" \
            cp949 "" \
            cp950 "" \
            dingbats "" \
            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-15 ISO-8859-15 \
            jis0201  "" \
            jis0208 "" \
            jis0212 "" \
            koi8-r KOI8-R \
            ksc5601 "" \
            macCentEuro "" \
            macCroatian "" \
            macCyrillic "" \
            macDingbats "" \
            macGreek "" \
            macIceland "" \
            macJapan "" \
            macRoman "" \
            macRomania "" \
            macThai "" \
            macTurkish "" \
            macUkraine "" \
            shiftjis Shift_JIS \
            symbol "" \
            unicode "" \
            utf-8 ""]

    variable encodings
    array set encodings $encList
    variable reversemap
    foreach {enc mimeType} $encList {
        if {$mimeType != ""} {
            set reversemap([string tolower $mimeType]) $enc
        }
    } 

    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 -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.
#
#       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 {[set code [catch { eval [list mime::initializeaux $token] $args } \
                         result]]} {
        set ecode $errorCode
        set einfo $errorInfo

        catch { mime::finalize $token -subordinates dynamic }

        return -code $code -errorinfo $einfo -errorcode $ecode $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 {![string compare $lower content-type]} {
                    error "use -canonical instead of -header $value"
                }
                if {![string compare $lower content-transfer-encoding]} {
                    error "use -encoding instead of -header $value"
                }
                if {(![string compare $lower content-md5]) \
                        || (![string compare $lower mime-version])} {
                    error "don't go there..."
                }
                if {[lsearch -exact $state(lowerL) $lower] < 0} {
                    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 [list 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 {[string compare $state(encoding) ""]} {
                            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 {[string compare $state(params) ""]} {
        error "-param requires -canonical"
    }
    if {[string compare $state(encoding) ""]} {
        error "-encoding requires -canonical"
    }
    if {[string compare $state(header) ""]} {
        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] == [expr {$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 {![string compare $vline ""]} {
            if {$blankP} {
                break
            }

            set vline $line
            continue
        }

        if {([set x [string first ":" $vline]] <= 0) \
                || (![string compare \
                             [set mixed \
                                  [string trimright \
                                          [string range \
                                                  $vline 0 [expr {$x-1}]]]] \
                            ""])} {
            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 {([string compare $state(encoding) ""]) \
                        && ([string compare $state(encoding) \
                                    [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 {
		mime::initializeaux $child \
		    -lineslist [lrange $state(lines) \
				    $state(lines.current) end] 
            }
        }

        return
    } 

    set state(value) parts

    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
            break
        }
    }
    if {![string compare $boundary ""]} {
        error "boundary parameter is missing in $state(content)"
    }
    if {![string compare [string trim $boundary] ""]} {
        error "boundary parameter is empty in $state(content)"
    }

    if {$fileP} {
        set pos [tell $state(fd)]
    }

    set inP 0
    set moreP 1
    while {$moreP} {
        if {$fileP} {
            if {$pos > $last} {
        #        error "termination string missing in $state(content)"
                 set line "--$boundary--"
            } 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] == [expr {$x-1}]} {
            set line [string range $line 0 [expr {$x-2}]]
        }

        if {[string first "--$boundary" $line] != 0} {
             if {$inP && !$fileP} {
 		lappend start $line
             }

             continue
        }

        if {!$inP} {
            if {![string compare $line "--$boundary"]} {
                set inP 1
                if {$fileP} {
                    set start $pos
                } else {
		    set start [list]
                }
            }

            continue
        }

        if {([set moreP [string compare $line "--$boundary--"]]) \
                && ([string compare $line "--$boundary"])} {
            if {$inP && !$fileP} {
		lappend start $line
            }
            continue
        }
	# FRINK: nocheck
        variable [set child $token-[incr state(cid)]]

        lappend state(parts) $child

        if {$fileP} {
            if {[set count [expr {$pos-($start+$x+3)}]] < 0} {
                set count 0
            }

            mime::initializeaux $child \
                -file $state(file) -root $state(root) \
                -offset $start -count $count

            seek $state(fd) [set start $pos] start
        } else {
	    mime::initializeaux $child -lineslist $start
            set start ""
        }
    }
}

# ::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 {[string compare [parselexeme $token] LX_ATOM]} {
        error [format "expecting type (found %s)" $state(buffer)]
    }
    set type [string tolower $state(buffer)]

    switch -- [parselexeme $token] {
        LX_SOLIDUS {
        }

        LX_END {
            if {[string compare $type message]} {
                error "expecting type/subtype (found $type)"
            }

            return [list message/rfc822 ""]
        }

        default {
            error [format "expecting \"/\" (found %s)" $state(buffer)]
        }
    }

    if {[string compare [parselexeme $token] 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 {[string compare [parselexeme $token] 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 {
            if {![string compare $state(value) parts]} {
                foreach part $state(parts) {
                    eval [list mime::finalize $part] $args
                }
            }
        }

        dynamic {
            for {set cid $state(cid)} {$cid > 0} {incr cid -1} {
                eval [list mime::finalize $token-$cid] $args
            }
        }

        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 {![string compare $state(encoding) 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} {
        if {![string compare $options(-mode) 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:
#                  ?-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

    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    

    return -code $code -errorinfo $einfo -errorcode $ecode $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 {[string compare $state(version) ""]} {
        puts $channel "MIME-Version: $state(version)"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            puts $channel "$mixed: $value"
        }
    }
    if {(!$state(canonicalP)) \
            && ([string compare [set encoding $state(encoding)] ""])} {
        puts $channel "Content-Transfer-Encoding: $encoding"
    }

    puts -nonewline $channel "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        puts -nonewline $channel ";\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        puts $channel ""

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [encoding $token]
            }
            if {[string compare $encoding ""]} {
                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)]) \
                    && (![string compare $boundary ""])} {
# 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 {[string compare $converter ""]} {
		    puts $channel [$converter -mode encode -- $X]
		} else {
		    puts $channel $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 {
                    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}]

            puts $channel ""

            if {[string compare $converter ""]} {
                puts $channel [$converter -mode encode -- $state(string)]
            } else {
		puts $channel $state(string)
	    }
        }
	default {
	    error "Unknown value \"$state(value)\""
	}
    }

    flush $channel

    if {[string compare $converter ""]} {
        unstack $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]
    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 {[string compare $state(version) ""]} {
        append result "MIME-Version: $state(version)\n"
    }
    foreach lower $state(lowerL) mixed $state(mixedL) {
        foreach value $header($lower) {
            append result "$mixed: $value\n"
        }
    }
    if {(!$state(canonicalP)) \
            && ([string compare [set encoding $state(encoding)] ""])} {
        append result "Content-Transfer-Encoding: $encoding\n"
    }

    append result "Content-Type: $state(content)"
    set boundary ""
    foreach {k v} $state(params) {
        if {![string compare $k boundary]} {
            set boundary $v
        }

        append result ";\n              $k=\"$v\""
    }

    set converter ""
    set encoding ""
    if {[string compare $state(value) parts]} {
        append result \n

        if {$state(canonicalP)} {
            if {![string compare [set encoding $state(encoding)] ""]} {
                set encoding [encoding $token]
            }
            if {[string compare $encoding ""]} {
                append result "Content-Transfer-Encoding: $encoding\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)]) \
                    && (![string compare $boundary ""])} {
# 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 ";\n              boundary=\"$boundary\"\n"
    } else {
        append result "\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 "\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 {[string compare $converter ""]} {
		    append result "[$converter -mode encode -- $X]\n"
		} else {
		    append result "$X\n"
		}
	    }

            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 "\n"
                    foreach part $state(parts) {
                        append result [buildmessage $part]
                        break
                    }
                }

                default {
                    foreach part $state(parts) {
                        append result "\n--$boundary\n"
                        append result [buildmessage $part]
                    }
                    append result "\n--$boundary--\n"
                }
            }

            if {[info exists state(fd)]} {
                catch { close $state(fd) }
                unset state(fd)
            }
        }

        string {

            append result "\n"

	    if {[string compare $converter ""]} {
		append result "[$converter -mode encode -- $state(string)]\n"
	    } else {
		append result "$state(string)\n"
	    }
        }
	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} {
                foreach {k v} $state(params) {
                    if {![string compare $k charset]} {
                        set v [string tolower $v]
                        if {([string compare $v 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 == [expr {[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) \
            || ([string compare $line [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 {[string compare $error ""]} {
        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 -novariable $string]

    # soft/hard newlines and other
    # Funky cases for SMTP compatibility
    set mapChars [list " \n" "=20\n" "\t\n" "=09\n" \
	    "\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==" "} {
	set result [string replace $result end end "=20"]
    } elseif {$lastChar=="\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.

    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 -novar -nocommand $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 {[string compare [set tail $state(domain)] ""]} {
            set tail @$state(domain)
        } else {
            set tail @[info hostname]
        }
        if {[string compare [set address $state(local)] ""]} {
            append address $tail
        }

        if {[string compare $state(phrase) ""]} {
            set state(phrase) [string trim $state(phrase) "\""]
            foreach t $state(tokenL) {
                if {[string first $t $state(phrase)] >= 0} {
                    set state(phrase) \"$state(phrase)\"
                    break
                }
            }

            set proper "$state(phrase) <$address>"
        } else {
            set proper $address
        }

        if {![string compare [set friendly $state(phrase)] ""]} {
            if {[string compare [set note $state(comment)] ""]} {
                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 {(![string compare $friendly ""]) \
                    && ([string compare [set mbox $state(local)] ""])} {
                set mbox [string trim $mbox "\""]

                if {[string first "/" $mbox] != 0} {
                    set friendly $mbox
                } elseif {[string compare \
                                  [set friendly [addr_x400 $mbox PN]] \
                                  ""]} {
                } elseif {([string compare \
                                   [set friendly [addr_x400 $mbox S]] \
                                   ""]) \
                            && ([string compare \
                                        [set g [addr_x400 $mbox G]] \
                                        ""])} {
                    set friendly "$g $friendly"
                }

                if {![string compare $friendly ""]} {
                    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

    foreach prop {comment domain error group local memberP phrase route} {
        catch { unset state($prop) }
    }

    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 {(![string compare $state(lastC) LX_SEMICOLON]) \
                    && ([incr state(glevel) -1] < 0)} {
                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 {![string compare [parselexeme $token] LX_ATSIGN]} {
        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) && ([string compare $state(lastC) 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
#       ========     =====
#       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'.

proc ::mime::parsedatetime {value property} {
    if {![string compare $value -now]} {
        set clock [clock seconds]
    } else {
        set clock [clock scan $value]
    }

    switch -- $property {
        hour {
            set value [clock format $clock -format %H]
        }

        lmonth {
            return [clock format $clock -format %B]
        }

        lweekday {
            return [clock format $clock -format %A]
        }

        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 {
            return [clock format $clock -format %b]
        }

        proper {
            set gmt [clock format $clock -format "%d %b %Y %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}]]

            return [clock format $clock \
                          -format "%a, %d %b %Y %H:%M:%S $zone"]
        }

        rclock {
            if {![string compare $value -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 {
            return [clock format $clock -format %a]
        }

        yday {
            set value [clock format $clock -format %j]
        }

        year {
            set value [clock format $clock -format %Y]
        }

        zone {
            regsub -all -- "\t" $value " " value
            set value [string trim $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 {![string compare $s +]} {
                        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 {![string compare [set value [string trimleft $value 0]] ""]} {
        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 {![string compare $state(input) ""]} {
        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 {![string compare $c "("]} {
        set noteP 0
        set quoteP 0

        while {1} {
            append state(buffer) $c

            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 {![string compare [set c [string index $state(input) 0]] ""]} {
                set state(buffer) "end-of-input during comment"
                return [set state(lastC) LX_ERR]
            }
            set state(input) [string range $state(input) 1 end]
        }
    }

    if {![string compare $c "\""]} {
        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 {![string compare [set c [string index $state(input) 0]] ""]} {
                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 {![string compare $c "\["]} {
        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 {![string compare [set c [string index $state(input) 0]] ""]} {
                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.
#
# Results:
#	Returns a word encoded string.

proc ::mime::word_encode {charset method string} {

    variable encodings

    if {![info exists encodings($charset)]} {
	error "unknown charset '$charset'"
    }

    if {$encodings($charset) == ""} {
	error "invalid charset '$charset'"
    }

    if {$method != "base64" && $method != "quoted-printable"} {
	error "unknown method '$method', must be base64 or quoted-printable"
    }

    set result "=?$encodings($charset)?"
    switch -exact -- $method {
	base64 {
	    append result "B?[string trimright [base64 -mode encode -- $string] \n]?="
	}
	quoted-printable {
	    append result "Q?[qp_encode $string 1]?="
	}
	"" {
	    # 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 {[string equal "" $enc]} {
	error "unknown charset '$charset'"
    }

    switch -exact -- $method {
	B {
            set method base64
        }
	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 UTF to the original encoding/charset.
#
# Arguments:
#       field     The string to decode
#
# Results:
#	Returns the decoded string in its original encoding/charset..

proc ::mime::field_decode {field} {
    # ::mime::field_decode is broken.  Here's a new version.
    # This code is in the public domain.  Don Libes <[email protected]>

    # 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
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/mime/mime.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] mime.tcl]
namespace import mime::*

puts "mime [package present 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
Content-ID: [^\n]+
Content-Type: text/plain

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
    regexp {MIME-Version: 1.0
Content-Description: Test Multipart
Content-ID: [^\n]+
Content-Type: multipart/mytype;
              boundary="bndry";
              myparam="foo"

--bndry
MIME-Version: 1.0
Content-ID: [^\n]+
Content-Type: text/plain

jack and jill

--bndry
MIME-Version: 1.0
Content-ID: [^\n]+
Content-Type: text/plain

james

--bndry--
} $msg
} 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
Content-Type: text/plain

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
Content-Type: text/plain

foo
}}

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 caract�res accentu�s : � � � � et quelques contr�les \"\[|\]()\""
    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-5.1 {Test word_encode with quoted-printable method} {
    mime::word_encode iso8859-1 quoted-printable "Test de contr�le 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 contr�le 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 contr�le effectu�"]
    mime::word_decode $enc
} {iso8859-1 quoted-printable {Test de contr�le effectu�}}

test mime-5.4 {Test encode+decode with base64 method} {
    set enc [mime::word_encode iso8859-1 base64 "Test de contr�le effectu�"]
    mime::word_decode $enc
} {iso8859-1 base64 {Test de contr�le effectu�}}


test mime-6.1 {Test field_decode (from RFC 2047, part 8)} {
    mime::field_decode {=?US-ASCII?Q?Keith_Moore?= <[email protected]>}
} {Keith Moore <[email protected]>}

test mime-6.2 {Test field_decode (from RFC 2047, part 8)} {
    mime::field_decode {=?ISO-8859-1?Q?Patrik_F=E4ltstr=F6m?= <[email protected]>}
} {Patrik F�ltstr�m <[email protected]>}

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 ; # {}
}


::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































Deleted modules/mime/performance.tcl.

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

#package require mime
source ./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
}

proc small_test size {
    set item [construct_item_with_attachment $size]
    #puts $item
    set length [string length $item]
    set result [time {mime::finalize [mime::initialize \
                       -string $item]} 1]

    puts "$size ($length):  $result"
}

small_test 800000
small_test 1000000
small_test 1500000
small_test 2500000
small_test 5000000


small_test 1000
small_test 10000
small_test 50000
small_test 100000
small_test 200000
small_test 400000


exit
foreach func [profiler::sortFunctions totalRuntime] {
    if { [lindex $func 1] > 0 } {
	puts [profiler::print [lindex $func 0]]
    }
}
exit

set fp [open /tmp/msgdump r]
set message [read $fp]
close $fp

set curpos 0
set next_EOL -1
set msg_EOF 0
set msg_size [string length $message]

proc doforeach {} {
    global message

    set cnt 0
    foreach line [split $message "\n"] {
	incr cnt
    }
    puts "doforeach $cnt lines"    

}

proc dolindex {} {
    global message 
    set cnt 0
    set lmsg [split $message "\n"]
    set len [llength $lmsg]
    for {set cnt 0} { $cnt < $len } {incr cnt} {
	set line [lindex $lmsg $cnt]
    }

    puts "dolindex $cnt lines"    
    
}

proc getnextline {} {
    global message
    global curpos
    global next_EOL
    global msg_EOF
    global msg_size

   if { $msg_EOF } {
	error "End-Of-Message reached"
    }

    set next_EOL [string first "\n" $message $curpos]

    if { $next_EOL == -1 } {
	set next_EOL $msg_size	
    }

    set msg_EOF [expr $next_EOL == $msg_size]

    set line [string range $message $sp $next_EOL] 
    set curpos [incr next_EOL]

}

proc dogetnext {} {
    global message
    global curpos
    global next_EOL
    global msg_EOF
    global msg_size

    set curpos 0
    set next_EOL -1
    set msg_EOF 0
    set msg_size [string length $message]

    set cnt 0
    while { !$msg_EOF } {
	getnextline
	incr cnt
    }

    puts "dogetnext $cnt lines"    
}

set res [time doforeach 10]
puts $res
set time1 [lindex $res 0]

set res [time dolindex 10]
puts $res
set time2 [lindex $res 0]
puts [expr $time2.0 / $time1.0 ]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































Deleted modules/mime/pkgIndex.tcl.

1
2
3
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded mime 1.3.3 [list source [file join $dir mime.tcl]]
package ifneeded smtp 1.3.3 [list source [file join $dir smtp.tcl]]
<
<
<






Deleted modules/mime/rfc2629.dtd.

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


































































































































































































































































































































































































































Deleted modules/mime/smtp.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin smtp n 1.3.3]
[copyright {1999-2000 Marshall T. Rose}]
[moddesc   {smtp client}]
[titledesc {Client-side tcl implementation of the smtp protocol}]
[require Tcl]
[require mime [opt 1.3.3]]
[require smtp [opt 1.3.3]]
[description]
[para]

The [package smtp] library package provides the client side of the
smtp protocol.

[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]

[lst_item [option -servers]]

A list of SMTP servers. The default is [const localhost].

[lst_item [option -ports]]

A list of SMTP ports. The default is [const 25].

[lst_item [option -queue]]

Indicates that the SMTP server should be asked to queue the message
for later processing. A boolean value.

[lst_item [option -atleastone]]

Indicates that the SMTP server must find at least one recipient
acceptable for the message to be sent. A boolean value.

[lst_item [option -originator]]

A string containing an 822-style address specification. If present the
header isn't examined for an originator address.

[lst_item [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.

[lst_item [option -header]]

A list of keywords and their values (may occur zero or more times).

[list_end]
[nl]

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.

[nl]

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 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 [email protected] localhost \\
    "This is the subject." "This is the message."
}]

[see_also mime pop3 ftp http]
[keywords mail mail email smtp mime rfc821 rfc822 internet net]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































Deleted modules/mime/smtp.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
'\"
'\" Copyright (c) 2000 Andreas Kupries
'\" All right reserved
'\"
'\" CVS: $Id: smtp.n,v 1.5 2002/02/01 17:44:53 andreas_kupries Exp $ smtp.n
'\"
.so man.macros
.TH "smtp" n 1.3.2 tcllib "smtp client"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
smtp \- Client-side tcl implementation of the smtp protocol
.SH "SYNOPSIS"
package require \fBTcl\fR
.sp
package require \fBmime ?1.3.2?\fR
.sp
package require \fBsmtp ?1.3.2?\fR
.sp
\fBsmtp::sendmessage\fR \fItoken\fR \fIoptions\fR\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
The smtp library package provides the client side of the smtp protocol.
.TP
\fBsmtp::sendmessage\fR \fItoken\fR \fIoptions\fR\fR
This command sends the MIME part represented by \fItoken\fR to an SMTP
server. \fIoptions\fR is a list of options and their associated values.
The recognized options are:
.RS
.TP
\fB-servers\fR
A list of SMTP servers. The default is \fIlocalhost\fR.
.TP
\fB-ports\fR
A list of SMTP ports. The default is \fI25\fR.
.TP
\fB-queue\fR
Indicates that the SMTP server should be asked to queue the message
for later processing. A boolean value.
.TP
\fB-atleastone\fR
Indicates that the SMTP server must find at least one recipient
acceptable for the message to be sent. A boolean value.
.TP
\fB-originator\fR
A string containing an 822-style address specification. If present the
header isn't examined for an originator address.
.TP
\fB-recipients\fR
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.
.TP
\fB-header\fR
A list of keywords and their values (may occur zero or more times).
.RE
.sp
If the \fI-originator\fR option is not present, the originator
address is taken from \fBFrom\fR (or \fBResent-From\fR);
similarly, if the \fI-recipients\fR option is not present, recipient
addresses are taken from \fBTo\fR, \fBcc\fR, and \fBBcc\fR
(or \fBResent-To\fR, and so on). Note that the header key/values
supplied by the \fI-header\fR 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.
.sp
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 \fI-atleastone\fR option and the
intended recipients, a non-empty list may still indicate that the
message was accepted by the server.
.SH "SEE ALSO"
mime, pop3, ftp, http
.SH "KEYWORDS"
mail, email, smtp, mime, rfc821, rfc822, internet, net


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































Deleted modules/mime/smtp.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
# smtp.tcl - SMTP client
#
# (c) 1999-2000 Marshall T. Rose
#
# 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.3.3
package provide smtp 1.3.3

#
# 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
#             -maxsecs     Maximum number of seconds to allow the SMTP server
#                          to accept the message. If not specified, the default
#                          is 120 seconds.
#
# 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 ports [list 25]

    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]}
	    -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
            }

            -ports {
                set ports $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 [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 [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 $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 $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 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 \
                                -multiple $bccP -queue $queueP \
                                -servers $servers -ports $ports]

    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 $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).
#
# 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]
    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
            }
        }
        
        # 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.

            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}
            }

            return $token
        } else {
            # Bad response; close the connection and hope the next server
            # is happier.
            catch {close $state(sd)}
        }
        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
}

# ::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.
#       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 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"
    }

    array set response \
          [set result [talk $token 600 \
                                  "$mode FROM:<$originator>"]]
    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
    variable trf
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    flush $state(sd)
    fileevent $state(sd) readable ""
    transform -attach $state(sd) -command [list ::smtp::wdata $token]
    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

            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 ""
    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/read
	    -
        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]
        }

	default {
	    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} {
            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"
        }
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ncgi/ChangeLog.

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

	* 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  <[email protected]>

	* ncgi.tcl: Use string match instead of regexp.

2002-08-30  Andreas Kupries  <[email protected]>

	* ncgi.tcl: Updated 'info exist' to 'info exists'.

2002-08-15  David N. Welton  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* ncgi.man: Added doctools manpage.

2002-01-15  Andreas Kupries  <[email protected]>

	* Bumped version to 1.2.1

2001-10-20  Andreas Kupries  <[email protected]>

	* ncgi.tcl (ncgi::redirect): Fixed bug #464560 reported by Ed
	  Rolfe <[email protected]>. 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  <[email protected]>

	* ncgi.n:
	* ncgi.test:
	* ncgi.tcl:
	* pkgIndex.tcl: Version up to 1.2

2001-09-05  Andreas Kupries  <[email protected]>

	* ncgi.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-09-05  Andreas Kupries  <[email protected]>

	* ncgi.tcl: Added missing [global env]. Bug [458023].

2001-08-01  Jeff Hobbs  <[email protected]>

	* ncgi.tcl: made require Tcl 8.1+, sped up encode and decode.

2001-07-10  Andreas Kupries <[email protected]>

	* ncgi.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* ncgi.tcl: Fixed dubious code reported by frink.

2001-06-15  Melissa Chawla <[email protected]>

	* ncgi.tcl: Applied George Wu's patch ([email protected]) 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 <[email protected]>

	* ncgi.tcl:  Added ncgi::setValue, ncgi::setValueList,
	ncgi::setDefaultValue, ncgi::setDefaultValueList to push values
	back into the CGI environment.

2000-05-26  Melissa Chawla  <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* ncgi.tcl, ncgi.test: changed names to get capitalization
	right: setCookie, valueList, importAll, urlStub

2000-04-17  Brent Welch  <[email protected]>

	* ncgi.tcl: Fixed ncgi::reset with no query data.  Fixed
	ncgi::multipart because it usually gets \r\n data.

2000-04-14  Brent Welch <[email protected]>
	
	* 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  <[email protected]>

	* 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 <[email protected]>

	* 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  <[email protected]>

	* 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.


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































Deleted modules/ncgi/formdata.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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_naame"; 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--

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































Deleted modules/ncgi/ncgi.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
[manpage_begin ncgi n 1.2.2]
[comment {-*- tcl -*- doctools manpage}]
[moddesc   {CGI Support}]
[titledesc {Procedures to manipulate CGI values.}]
[require Tcl 8.2]
[require ncgi [opt 1.2.2]]
[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::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 vale is imported.  Otherwise each CGI variable
listed in [arg args] is imported.


[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.

[nl]

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::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]

[lst_item "[option -name] [arg name]"]
[lst_item "[option -value] [arg value]"]
[lst_item "[option -expires] [arg date]"]
[lst_item "[option -path] [arg {path restriction}]"]
[lst_item "[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.

[nl]

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]


[see_also html]
[keywords CGI form html cookie]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































Deleted modules/ncgi/ncgi.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: ncgi.n,v 1.9 2002/01/18 20:51:16 andreas_kupries Exp $
'\" 
.so man.macros
.TH ncgi n 1.2.1 Ncgi "CGI Support"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::ncgi \- Procedures to manipulate CGI values.
.SH SYNOPSIS
.BS
.sp
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require ncgi ?1.2.1?\fR
.sp
\fBncgi::cookie\fR \fIcookie\fR
.sp
\fBncgi::decode\fR \fIstr\fR
.sp
\fBncgi::empty\fR \fIname\fR
.sp
\fBncgi::encode\fR \fIstring\fR
.sp
\fBncgi::header\fR \fI{type text/html} args\fR
.sp
\fBncgi::import\fR \fIcginame {tclname {}}\fR
.sp
\fBncgi::importAll\fR \fIargs\fR
.sp
\fBncgi::input\fR \fI{fakeinput {}} {fakecookie {}}\fR
.sp
\fBncgi::multipart\fR \fItype query\fR
.sp
\fBncgi::nvlist\fR \fI\fR
.sp
\fBncgi::parse\fR \fI\fR
.sp
\fBncgi::parseMimeValue\fR \fIvalue\fR
.sp
\fBncgi::query\fR \fI\fR
.sp
\fBncgi::redirect\fR \fIurl\fR
.sp
\fBncgi::reset\fR \fIargs\fR
.sp
\fBncgi::setCookie\fR \fIargs\fR
.sp
\fBncgi::setDefaultValue\fR \fIkey defvalue\fR
.sp
\fBncgi::setDefaultValueList\fR \fIkey defvaluelist\fR
.sp
\fBncgi::setValue\fR \fIkey value\fR
.sp
\fBncgi::setValueList\fR \fIkey valuelist\fR
.sp
\fBncgi::type\fR \fI\fR
.sp
\fBncgi::urlStub\fR \fI{url {}}\fR
.sp
\fBncgi::value\fR \fIkey {default {}}\fR
.sp
\fBncgi::valueList\fR \fIkey {default {}}\fR
.BE
.SH DESCRIPTION
.PP
The \fB::ncgi\fR 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 \fB::ncgi\fP package to query these values,
set and get cookies, and encode and decode www-url-encoded values.

.PP
In the simplest case, a CGI script first calls
\fBncgi::parse\fP and then calls \fBncgi::value\fP to get different
form values.  If a CGI value is repeated, you should use
\fBncgi::valueList\fP to get back the complete list of values.

.PP
An alternative to \fBncgi::parse\fP is \fBncgi::input\fP,
which has semantics similar to Don Libes' \fBcgi_input\fP procedure.
\fBncgi::input\fP restricts repeated CGI values to have names
that end with "List".  In this case, \fBncgi::value\fP will return
the complete list of values, and \fBncgi::input\fP will raise
errors if it find repeated form elements without the right name.

.PP
The \fBncgi::reset\fP 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.

.PP
The complete set of procedures is described below.

.TP
\fBncgi::cookie\fR \fIcookie\fR
Return a list of values for \fIcookie\fP, if any.
It is possible that more than one cookie with the same name can
be present, so this procedure returns a list.

.TP
\fBncgi::decode\fR \fIstr\fR
Decode strings in www-url-encoding, which represents special
characters with a %xx sequence, where xx is the character code in hex.

.TP
\fBncgi::empty\fR \fIname\fR
Returns 1 if the CGI variable \fIname\fP is not present or has
the empty string as its value.

.TP
\fBncgi::encode\fR \fIstring\fR
Encode \fBstring\fR into www-url-encoded format.

.TP
\fBncgi::header\fR \fI{type text/html} args\fR
Output the CGI header to standard output.
This emits a Content-Type: header and additional headers based
on \fIargs\fP, which is a list of
header names and header values.

.TP
\fBncgi::import\fR \fIcginame {tclname {}}\fR
This creates a variable in the current scope with the
value of the CGI variable \fIcginame\fP.
The name of the variable is \fItclname\fP, or
\fIcginame\fP if \fItclname\fP is empty.

.TP
\fBncgi::importAll\fR \fIargs\fR
This imports several CGI variables as Tcl variables.
If \fIargs\fP is empty, then every CGI vale is imported.
Otherwise each CGI variable listed in \fIargs\fP is imported.

.TP
\fBncgi::input\fR \fI{fakeinput {}} {fakecookie {}}\fR
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 \fBncgi::value\fP procedure.

.TP
\fBncgi::multipart\fR \fItype query\fR
This procedure parses a multipart/form-data \fIquery\fP.
This is used by \fBncgi::nvlist\fP 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
\fBncgi::value\fP you just get the form value.
If you use \fBncgi::valueList\fP you get the structured value
with meta data and the value.

The \fItype\fP is the whole Content-Type, including the
parameters like \fBboundary\fP.  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.

.TP
\fBncgi::nvlist\fR \fI\fR
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 \fBncgi::multipart\fP.

.TP
\fBncgi::parse\fR \fI\fR
This reads and decodes the CGI values from the environment.
The CGI values are obtained later with
the \fBncgi::value\fP procedure.
IF a CGI value is repeated, then you should use
\fBncgi::valueList\fP to get the complete list of values.

.TP
\fBncgi::parseMimeValue\fR \fIvalue\fR
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.

.TP
\fBncgi::query\fR \fI\fR
This returns the raw query data.

.TP
\fBncgi::redirect\fR \fIurl\fR
Generate a response that causes a 302 redirect by the Web server.
The \fIurl\fP 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.

.TP
\fBncgi::reset\fR \fIquery type\fR
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 \fIquery\fP or \fItype\fP are specified, then 
the \fBncgi\fP module will look
in the standard CGI environment for its data.

.TP
\fBncgi::setCookie\fR \fIargs\fR
Set a cookie value that will be returned as part of the reply.
This must be done before \fBncgi::header\fP or
\fBncgi::redirect\fP is called in order for the cookie to
be returned properly.
The \fIargs\fP are a set of flags and values:

.DS
-name \fIname\fP
-value \fIvalue\fP
-expires \fIdate\fP
-path \fIpath restriction\fP
-domain \fIdomain restriction\fP
.DE

.TP
\fBncgi::setDefaultValue\fR \fIkey defvalue\fR
Set a CGI value if it does not already exists.
This affects future calls to \fBncgi::value\fR (but not future
calls to \fBncgi::nvlist\fR).
If the CGI value already is present, then this procedure has
no side effects.
.TP
\fBncgi::setDefaultValueList\fR \fIkey defvaluelist\fR
Like \fBncgi::setDefaultValue\fR except that the value already
has list structure to represent multiple checkboxes or a multi-selection.
.TP
\fBncgi::setValue\fR \fIkey value\fR
Set a CGI value, overriding whatever was present in the CGI environment already.
This affects future calls to \fBncgi::value\fR (but not future
calls to \fBncgi::nvlist\fR).
.TP
\fBncgi::setValueList\fR \fIkey valuelist\fR
Like \fBncgi::setValue\fR except that the value already
has list structure to represent multiple checkboxes or a multi-selection.

.TP
\fBncgi::type\fR \fI\fR
Returns the Content-Type of the current CGI values.

.TP
\fBncgi::urlStub\fR \fI{url {}}\fR
Returns the current URL, but without the protocol, server, and port.
If \fIurl\fP is specified, then it defines the URL for the
current session.  That value will be returned by future calls to
\fBncgi::urlStub\fR

.TP
\fBncgi::value\fR \fIkey {default {}}\fR
Return the CGI value identified by \fIkey\fP.
If the CGI value is not present, then the \fIdefault\fP value
is returned instead.
If the form value \fIkey\fP is repeated, then there are
two cases:  if \fBncgi::parse\fP was called, then 
\fBncgi::value\fR only returns the first value associated with \fIkey\fP.
If \fBncgi::input\fP was called, then \fBncgi::value\fR returns a
Tcl list value and \fIkey\fP 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 \fBncgi::valueList\fP.

.TP
\fBncgi::valueList\fR \fIkey {default {}}\fR
Like \fBncgi::value\fP, 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.


.SH SEE ALSO
html

.SH KEYWORDS
CGI, form, html, cookie
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































Deleted modules/ncgi/ncgi.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
# ncgi.tcl
#
# Basic support for CGI programs
#
# Copyright (c) 2000 Ajuba Solutions.
#
# 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.2

package provide ncgi 1.2.2

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
    }
 
    # 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
    namespace export setValue setValueList setDefaultValue setDefaultValueList
    namespace export empty import importAll 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 query
    variable contenttype
    variable cookieOutput

    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} {
		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

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 -- {%([A-Fa-f0-9][A-Fa-f0-9])} $str {\\u00\1} str

    # process \u unicode mapped chars
    return [subst -novar -nocommand $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::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 {
	"" -
	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.
		if {![regexp -- (.*)=(.*) $x dummy varname val]} {
		    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::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
	} 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::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
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ncgi/ncgi.test.

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

package require tcltest
namespace import -force ::tcltest::*

set ncgiFile [file join [file dirname [info script]] ncgi.tcl]
source $ncgiFile
package require ncgi 1.2.1

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 {
	source %s
	ncgi::query
	puts $ncgi::query
    } $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    puts $f "name=value"
    flush $f
    gets $f line
    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-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.4 {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 {
	if {[catch {
	source %s
	ncgi::redirect %s
	} err]} {
	    puts $err
	}
    } $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "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 {
	if {[catch {
	source %s
	ncgi::setCookie -name CookieName -value 12345
	ncgi::redirect %s
	} err]} {
	    puts $err
	}
    } $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "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 {
	if {[catch {
	source %s
	ncgi::redirect %s
	} err]} {
	    puts $err
	}
    } $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "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 {
	if {[catch {
	source %s
	ncgi::redirect %s
	} err]} {
	    puts $err
	}
    } $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "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 {
	if {[catch {
	source %s
	ncgi::redirect %s
	} err]} {
	    puts $err
	}
    } $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "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 {
	if {[catch {
	source %s
	ncgi::redirect %s
	} err]} {
	    puts $err
	}
    } $ncgiFile $URL] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "Content-Type: text/html\nLocation: $URL2\n\nPlease go to <a href=\"$URL2\">$URL2</a>\n"

test ncgi-12.1 {ncgi::header} {
    makeFile [format {
	if {[catch {
	source %s
	ncgi::header
	} err]} {
	    puts $err
	}
    } $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "Content-Type: text/html\n\n"

test ncgi-12.2 {ncgi::header} {
    makeFile [format {
	if {[catch {
	source %s
	ncgi::header text/plain
	} err]} {
	    puts $err
	}
    } $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "Content-Type: text/plain\n\n"

test ncgi-12.3 {ncgi::header} {
    makeFile [format {
	if {[catch {
	source %s
	ncgi::header text/html X-Comment "This is a test"
	} err]} {
	    puts $err
	}
    } $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "Content-Type: text/html\nX-Comment: This is a test\n\n"

test ncgi-12.4 {ncgi::header} {
    makeFile [format {
	if {[catch {
	source %s
	ncgi::setCookie -name Name -value {The+Value}
	ncgi::header
	} err]} {
	    puts $err
	}
    } $ncgiFile] test1
    set f [open "|[list $::tcltest::tcltest test1]" r+]
    read $f
} "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_naame {{content-disposition form-data name the_file_naame 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_naame]
} {value {another value} {
<center><h1>
                  Netscape Address Book Sync for Palm Pilot
                                         User Guide
</h1></center>


}}

test ncgi-14.5 {ncgi::multipart--check binary file} {
    set in [open [file join [file dirname [info script]] formdata.txt]]

    # Read the file in as though it were binary.
    fconfigure $in -translation binary
    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
    set content [ncgi::value the_file_naame]
    list [ncgi::value field1] [ncgi::value field2] $content
} "value {another value} {\r
<center><h1>\r
                  Netscape Address Book Sync for Palm Pilot\r
                                         User Guide\r
</h1></center>\r
\r
\r
}"

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_naame]
} {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}}

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ncgi/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 ncgi 1.2.2 [list source [file join $dir ncgi.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/nntp/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
2003-04-11  Andreas Kupries  <[email protected]>

	* nntp.man:
	* nntp.tcl:
	* pkgIndex.tcl:  Set version of the package to to 0.2.1

2003-02-24  David N. Welton  <[email protected]>

	* nntp.tcl (::nntp::squirt): Use if, string match instead of
	regsub.

2003-02-06  David N. Welton  <[email protected]>

	* 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  <[email protected]>

	* nntp.man: More semantic markup, less visual one.

2002-08-19  Andreas Kupries <[email protected]>

	* nntp.man: Added example, updated reference from rfc 850 to rfc
	  1036. See Tcllib SF #597102, by Jussi Kuosa
	  <[email protected]>.
	* nntp.n: Out of date. Deprecated.

2002-03-25  Andreas Kupries <[email protected]>

	* nntp.man: New file, doctools manpage.

2002-01-16  Andreas Kupries <[email protected]>

	* Bumped version to 0.2

2002-01-16  Andreas Kupries <[email protected]>

	* nntp.tcl: Fixed bug #502250 reported by Andreas Otto
	  <[email protected]> which caused the package to wrap each
	  message into braces, causing nntp servers to reject the data.

2001-07-10  Andreas Kupries <[email protected]>

	* nntp.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* nntp.tcl: Fixed dubious code reported by frink.

2000-06-20  Dan Kuchler  <[email protected]>

        * Code cleanup and bug fixes

2000-06-18  Dan Kuchler  <[email protected]>

        * Fixed documentation bug in man page for xpat

2000-06-16  Dan Kuchler  <[email protected]>

        * rfc977.txt: RFC for NNTP

        * pkgIndex.tcl 
        * nntp.tcl: Initial implementation of a nntp client package.

        * nntp.n: Initial documentation for the package.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































Deleted modules/nntp/nntp.man.

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

[nl]

Some of the commands supported by this package are not part of the
nntp rfc (rfc 977) and will not be available (or implemented) on all
nntp servers.

[nl]

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 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').
[nl]
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 (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]

[lst_item [const {""}]]

The current message is queried.

[lst_item [arg msgid1]-[arg msgid2]]

All messages between [arg msgid1] and [arg msgid2]
(including [arg msgid1] and [arg msgid2]) are queried.

[lst_item "[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]


[lst_item [const {""}]]

The current message is queried.

[lst_item [arg msgid1]-[arg msgid2]]

All messages between [arg msgid1] and [arg msgid2]
(including [arg msgid1] and [arg msgid2]) are queried.

[lst_item "[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]

[lst_item [arg msgid]]

The message specified by [arg msgid] is queried.

[lst_item [arg msgid1]-[arg msgid2]]

All messages between [arg msgid1] and [arg msgid2]
(including [arg msgid1] and [arg msgid2]) are queried.

[lst_item "[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: [email protected] (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" 
}]

[keywords news nntp nntpclient rfc1030 rfc977]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































Deleted modules/nntp/nntp.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
'\"
'\" Copyright (c) 2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: nntp.n,v 1.6 2002/01/18 20:51:16 andreas_kupries Exp $
'\" 
.so man.macros
.TH nntp n 0.2 nntp "Tcl NNTP Client Library"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
nntp \- Tcl client for the NNTP protocol
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require nntp ?0.2?\fR
.sp
\fB::nntp::nntp\fR \fR?\fIhost\fR? \fR?\fIport\fR? \fR?\fInntpName\fR? 
.sp

.BE
.SH DESCRIPTION
.PP
The \fBnntp\fR package 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 \fBcatch\fR command.  The \fB::nntp::nntp\fR
command creates a new nntp object with an associated Tcl command whose name
is returned by the \fB::nntp::nntp\fR command (\fBnntpName\fR).  This command
may be used to access the various NNTP protocol commands.  Some of the
commands supported by this package are not part of the nntp rfc (rfc 977)
and will not be available (or implemented) on all nntp servers.  The commands
have the following general form:
.CS
\fBnntpName\fR \fIoption \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.

.SH COMMANDS
.TP
\fB::nntp::nntp\fR \fR?\fIhost\fR? \fR?\fIport\fR? \fR?\fInntpName\fR?
Open a socket connection to a NNTP server.  The command returns the name
of the global command that can be used to access the nntp connection
subsequently.  The default port number is \fB119\fR and the default server is
\fBnews\fR which can be overridden with the environment variables NNTPPORT and
NNTPHOST respectively.
.TP
\fBnntpName article\fR \fR?\fImsgid\fR?\fR
Query the server for article \fImsgid\fR 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.
.TP
\fBnntpName authinfo\fR \fR?\fIuser\fR?\fR \fR?\fIpass\fR?\fR
Send authentication information (username and password) to the server.
.TP
\fBnntpName body\fR \fR?\fImsgid\fR?\fR
Query the server for the body of the article \fImsgid\fR 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.
.TP
\fBnntpName date\fR
Query the server for the servers current date.  The date is returned in the
format YYYYMMDDHHMMSS
.TP
\fBnntpName group\fR \fR?\fIgroup\fR?\fR
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.
.TP
\fBnntpName head\fR \fR?\fImsgid\fR?\fR
Query the server for the headers of the article \fImsgid\fR 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.
.TP
\fBnntpName help\fR
Retrieves a list of the commands that are supported by the news server that
is currently attached to.
.TP
\fBnntpName last\fR
Sets the current article pointer to point to the previous message (if there is
one) and returns the msgid of that message.
.TP
\fBnntpName list\fR
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:
.sp
      group last first p
.sp
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').
.sp
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.
.TP
\fBnntpName listgroup\fR \fI?\fIgroup\fR?\fR
Query the server for a list of all the messages (message numbers) in the
group specified by the argument \fIgroup\fR or by the current group if
the \fIgroup\fR argument was not passed.
.TP
\fBnntpName mode_reader\fR
Query the server for its nntp 'MODE READER' response string.
.TP
\fBnntpName newgroups\fR \fIsince\fR
Query the server for a list of all the new newsgroups created since the time
specified by the argument \fIsince\fR.  The argument \fIsince\fR can be any
time string that is understood by \fBclock scan\fR. The tcl list of newsgroups
is returned in a similar form to the list of groups returned by the \fBnntpName list\fR command.  Each element of the list has the form:
.sp
      group last first p
.sp
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').
.TP
\fBnntpName newnews\fR
Query the server for a list of new articles posted to the current group in the
last day.
.TP
\fBnntpName newnews\fR \fIsince\fR
Query the server for a list of new articles posted to the current group since
the time specified by the argument \fIsince\fR.  The argument \fIsince\fR can
be any time string that is understood by \fBclock scan\fR.
.TP
\fBnntpName newnews\fR \fIgroup\fR \fR?\fIsince\fR?\fR
Query the server for a list of new articles posted to the group specified by
the argument \fIgroup\fR since the time specified by the argument \fIsince\fR
(or in the past day if no \fIsince\fR argument is passed.  The argument
\fIsince\fR can be any time string that is understood by \fBclock scan\fR.
.TP
\fBnntpName next\fR
Sets the current article pointer to point to the next message (if there is
one) and returns the msgid of that message.
.TP
\fBnntpName post\fR \fIarticle\fR
Posts an article of the form specified in RFC 850 to the current news group.
.TP
\fBnntpName slave\fR
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.
.TP
\fBnntpName stat\fR \fI?\fImsgid\fR?\fR
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"
.TP
\fBnntpName quit\fR
Gracefully close the connection after sending a NNTP QUIT command down
the socket.
.TP
\fBnntpName xgtitle\fR \fI?\fIgroup_pattern\fR?\fR
Returns a tcl list where each element is of the form:
.sp
newsgroup description
.sp
If a \fIgroup_pattern\fR is specified then only newsgroups that match
the pattern will have their name and description returned.
.TP
\fBnntpName xhdr\fR \fIfield\fR \fI?\fIrange\fR?\fR
Returns the specified header field value for the current message or for a
list of messages from the current group.  \fIfield\fR is the title of a
field in the header such as from, subject, date, etc.  If \fIrange\fR 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:
.sp
msgid value
.sp
Where msgid is the number of the message and value is the value set for the
queried field.  The \fIrange\fR argument can be in any of the following forms:
.RS
.TP
\fB""\fR
The current message is queried.
.TP
\fBmsgid1-msgid2\fR 
All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried.
.TP
\fBmsgid1 msgid2\fR 
All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried.
.RE
.TP
\fBnntpName xover\fR \fI?\fIrange\fR?\fR
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:
.sp
msgid subject from date idstring bodysize headersize xref
.sp
If \fIrange\fR is not specified or is "" then the current message is queried.
The \fIrange\fR argument can be in any of the following forms:
.RS
.TP
\fB""\fR
The current message is queried.
.TP
\fBmsgid1-msgid2\fR 
All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried.
.TP
\fBmsgid1 msgid2\fR 
All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried.
.RE
.TP
\fBnntpName xpat\fR \fIfield\fR \fIrange\fR \fI?\fIpattern_list\fR?\fR
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.  \fIfield\fR 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:
.sp
msgid value
.sp
Where msgid is the number of the message and value is the value set for the
queried field.  The \fIrange\fR argument can be in any of the following forms:
.RS
.TP
\fBmsgid\fR
The message specified by msgid is queried.
.TP
\fBmsgid1-msgid2\fR 
All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried.
.TP
\fBmsgid1 msgid2\fR 
All messages between msgid1 and msgid2 (including msgid1 and msgid2) are queried.
.RE
.TP
.SH KEYWORDS
news, nntp, nntpclient




<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































Deleted modules/nntp/nntp.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
# nntp.tcl --
#
#       nntp implementation for Tcl.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
# 
# RCS: @(#) $Id: nntp.tcl,v 1.10 2003/04/11 20:04:39 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 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 [list ::nntp::_$cmd $name] $args]
}

# ::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
#

# ::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 [list ::nntp::cmd $name] $args]
    
    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)

    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
	}
    }
    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

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/nntp/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/nntp/rfc977.txt.

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


Network Working Group                      Brian Kantor (U.C. San Diego)
Request for Comments: 977                   Phil Lapsley (U.C. Berkeley)
                                                           February 1986

                     Network News Transfer Protocol
                                    
                A Proposed Standard for the Stream-Based
                          Transmission of News

Status of This Memo

   NNTP specifies a protocol for the distribution, inquiry, retrieval,
   and posting of news articles using a reliable stream-based
   transmission of news among the ARPA-Internet community.  NNTP is
   designed so that news articles are stored in a central database
   allowing a subscriber to select only those items he wishes to read.
   Indexing, cross-referencing, and expiration of aged messages are also
   provided. This RFC suggests a proposed protocol for the ARPA-Internet
   community, and requests discussion and suggestions for improvements.
   Distribution of this memo is unlimited.

1.  Introduction

   For many years, the ARPA-Internet community has supported the
   distribution of bulletins, information, and data in a timely fashion
   to thousands of participants.  We collectively refer to such items of
   information as "news".  Such news provides for the rapid
   dissemination of items of interest such as software bug fixes, new
   product reviews, technical tips, and programming pointers, as well as
   rapid-fire discussions of matters of concern to the working computer
   professional. News is very popular among its readers.

   There are popularly two methods of distributing such news: the
   Internet method of direct mailing, and the USENET news system.

1.1.  Internet Mailing Lists

   The Internet community distributes news by the use of mailing lists.
   These are lists of subscriber's mailbox addresses and remailing
   sublists of all intended recipients.  These mailing lists operate by
   remailing a copy of the information to be distributed to each
   subscriber on the mailing list.  Such remailing is inefficient when a
   mailing list grows beyond a dozen or so people, since sending a
   separate copy to each of the subscribers occupies large quantities of
   network bandwidth, CPU resources, and significant amounts of disk
   storage at the destination host.  There is also a significant problem
   in maintenance of the list itself: as subscribers move from one job
   to another; as new subscribers join and old ones leave; and as hosts
   come in and out of service.




Kantor & Lapsley                                                [Page 1]



RFC 977                                                    February 1986
Network News Transfer Protocol


1.2.  The USENET News System

   Clearly, a worthwhile reduction of the amount of these resources used
   can be achieved if articles are stored in a central database on the
   receiving host instead of in each subscriber's mailbox. The USENET
   news system provides a method of doing just this.  There is a central
   repository of the news articles in one place (customarily a spool
   directory of some sort), and a set of programs that allow a
   subscriber to select those items he wishes to read.  Indexing,
   cross-referencing, and expiration of aged messages are also provided.

1.3.  Central Storage of News

   For clusters of hosts connected together by fast local area networks
   (such as Ethernet), it makes even more sense to consolidate news
   distribution onto one (or a very few) hosts, and to allow access to
   these news articles using a server and client model.  Subscribers may
   then request only the articles they wish to see, without having to
   wastefully duplicate the storage of a copy of each item on each host.

1.4.  A Central News Server

   A way to achieve these economies is to have a central computer system
   that can provide news service to the other systems on the local area
   network.  Such a server would manage the collection of news articles
   and index files, with each person who desires to read news bulletins
   doing so over the LAN.  For a large cluster of computer systems, the
   savings in total disk space is clearly worthwhile.  Also, this allows
   workstations with limited disk storage space to participate in the
   news without incoming items consuming oppressive amounts of the
   workstation's disk storage.

   We have heard rumors of somewhat successful attempts to provide
   centralized news service using IBIS and other shared or distributed
   file systems.  While it is possible that such a distributed file
   system implementation might work well with a group of similar
   computers running nearly identical operating systems, such a scheme
   is not general enough to offer service to a wide range of client
   systems, especially when many diverse operating systems may be in use
   among a group of clients.  There are few (if any) shared or networked
   file systems that can offer the generality of service that stream
   connections using Internet TCP provide, particularly when a wide
   range of host hardware and operating systems are considered.

   NNTP specifies a protocol for the distribution, inquiry, retrieval,
   and posting of news articles using a reliable stream (such as TCP)
   server-client model. NNTP is designed so that news articles need only


Kantor & Lapsley                                                [Page 2]



RFC 977                                                    February 1986
Network News Transfer Protocol


   be stored on one (presumably central) host, and subscribers on other
   hosts attached to the LAN may read news articles using stream
   connections to the news host.

   NNTP is modelled upon the news article specifications in RFC 850,
   which describes the USENET news system.  However, NNTP makes few
   demands upon the structure, content, or storage of news articles, and
   thus we believe it easily can be adapted to other non-USENET news
   systems.

   Typically, the NNTP server runs as a background process on one host,
   and would accept connections from other hosts on the LAN.  This works
   well when there are a number of small computer systems (such as
   workstations, with only one or at most a few users each), and a large
   central server.

1.5.  Intermediate News Servers

   For clusters of machines with many users (as might be the case in a
   university or large industrial environment), an intermediate server
   might be used.  This intermediate or "slave" server runs on each
   computer system, and is responsible for mediating news reading
   requests and performing local caching of recently-retrieved news
   articles.

   Typically, a client attempting to obtain news service would first
   attempt to connect to the news service port on the local machine.  If
   this attempt were unsuccessful, indicating a failed server, an
   installation might choose to either deny news access, or to permit
   connection to the central "master" news server.

   For workstations or other small systems, direct connection to the
   master server would probably be the normal manner of operation.

   This specification does not cover the operation of slave NNTP
   servers.  We merely suggest that slave servers are a logical addition
   to NNTP server usage which would enhance operation on large local
   area networks.

1.6.  News Distribution

   NNTP has commands which provide a straightforward method of
   exchanging articles between cooperating hosts. Hosts which are well
   connected on a local area or other fast network and who wish to
   actually obtain copies of news articles for local storage might well
   find NNTP to be a more efficient way to distribute news than more
   traditional transfer methods (such as UUCP).


Kantor & Lapsley                                                [Page 3]



RFC 977                                                    February 1986
Network News Transfer Protocol


   In the traditional method of distributing news articles, news is
   propagated from host to host by flooding - that is, each host will
   send all its new news articles on to each host that it feeds.  These
   hosts will then in turn send these new articles on to other hosts
   that they feed.  Clearly, sending articles that a host already has
   obtained a copy of from another feed (many hosts that receive news
   are redundantly fed) again is a waste of time and communications
   resources, but for transport mechanisms that are single-transaction
   based rather than interactive (such as UUCP in the UNIX-world <1>),
   distribution time is diminished by sending all articles and having
   the receiving host simply discard the duplicates.  This is an
   especially true when communications sessions are limited to once a
   day.

   Using NNTP, hosts exchanging news articles have an interactive
   mechanism for deciding which articles are to be transmitted.  A host
   desiring new news, or which has new news to send, will typically
   contact one or more of its neighbors using NNTP.  First it will
   inquire if any new news groups have been created on the serving host
   by means of the NEWGROUPS command.  If so, and those are appropriate
   or desired (as established by local site-dependent rules), those new
   newsgroups can be created.

   The client host will then inquire as to which new articles have
   arrived in all or some of the newsgroups that it desires to receive,
   using the NEWNEWS command.  It will receive a list of new articles
   from the server, and can request transmission of those articles that
   it desires and does not already have.

   Finally, the client can advise the server of those new articles which
   the client has recently received.  The server will indicate those
   articles that it has already obtained copies of, and which articles
   should be sent to add to its collection.

   In this manner, only those articles which are not duplicates and
   which are desired are transferred.













Kantor & Lapsley                                                [Page 4]



RFC 977                                                    February 1986
Network News Transfer Protocol


2.  The NNTP Specification

2.1.  Overview

   The news server specified by this document uses a stream connection
   (such as TCP) and SMTP-like commands and responses.  It is designed
   to accept connections from hosts, and to provide a simple interface
   to the news database.

   This server is only an interface between programs and the news
   databases. It does not perform any user interaction or presentation-
   level functions. These "user-friendly" functions are better left to
   the client programs, which have a better understanding of the
   environment in which they are operating.

   When used via Internet TCP, the contact port assigned for this
   service is 119.

2.2.  Character Codes

   Commands and replies are composed of characters from the ASCII
   character set.  When the transport service provides an 8-bit byte
   (octet) transmission channel, each 7-bit character is transmitted
   right justified in an octet with the high order bit cleared to zero.

2.3.  Commands

   Commands consist of a command word, which in some cases may be
   followed by a parameter.  Commands with parameters must separate the
   parameters from each other and from the command by one or more space
   or tab characters.  Command lines must be complete with all required
   parameters, and may not contain more than one command.

   Commands and command parameters are not case sensitive. That is, a
   command or parameter word may be upper case, lower case, or any
   mixture of upper and lower case.

   Each command line must be terminated by a CR-LF (Carriage Return -
   Line Feed) pair.

   Command lines shall not exceed 512 characters in length, counting all
   characters including spaces, separators, punctuation, and the
   trailing CR-LF (thus there are 510 characters maximum allowed for the
   command and its parameters).  There is no provision for continuation
   command lines.




Kantor & Lapsley                                                [Page 5]



RFC 977                                                    February 1986
Network News Transfer Protocol


2.4.  Responses

   Responses are of two kinds, textual and status.

2.4.1.  Text Responses

   Text is sent only after a numeric status response line has been sent
   that indicates that text will follow.  Text is sent as a series of
   successive lines of textual matter, each terminated with CR-LF pair.
   A single line containing only a period (.) is sent to indicate the
   end of the text (i.e., the server will send a CR-LF pair at the end
   of the last line of text, a period, and another CR-LF pair).

   If the text contained a period as the first character of the text
   line in the original, that first period is doubled.  Therefore, the
   client must examine the first character of each line received, and
   for those beginning with a period, determine either that this is the
   end of the text or whether to collapse the doubled period to a single
   one.

   The intention is that text messages will usually be displayed on the
   user's terminal whereas command/status responses will be interpreted
   by the client program before any possible display is done.

2.4.2.  Status Responses

   These are status reports from the server and indicate the response to
   the last command received from the client.

   Status response lines begin with a 3 digit numeric code which is
   sufficient to distinguish all responses.  Some of these may herald
   the subsequent transmission of text.

   The first digit of the response broadly indicates the success,
   failure, or progress of the previous command.

      1xx - Informative message
      2xx - Command ok
      3xx - Command ok so far, send the rest of it.
      4xx - Command was correct, but couldn't be performed for
            some reason.
      5xx - Command unimplemented, or incorrect, or a serious
            program error occurred.






Kantor & Lapsley                                                [Page 6]



RFC 977                                                    February 1986
Network News Transfer Protocol


   The next digit in the code indicates the function response category.

      x0x - Connection, setup, and miscellaneous messages
      x1x - Newsgroup selection
      x2x - Article selection
      x3x - Distribution functions
      x4x - Posting
      x8x - Nonstandard (private implementation) extensions
      x9x - Debugging output

   The exact response codes that should be expected from each command
   are detailed in the description of that command.  In addition, below
   is listed a general set of response codes that may be received at any
   time.

   Certain status responses contain parameters such as numbers and
   names. The number and type of such parameters is fixed for each
   response code to simplify interpretation of the response.

   Parameters are separated from the numeric response code and from each
   other by a single space. All numeric parameters are decimal, and may
   have leading zeros. All string parameters begin after the separating
   space, and end before the following separating space or the CR-LF
   pair at the end of the line. (String parameters may not, therefore,
   contain spaces.) All text, if any, in the response which is not a
   parameter of the response must follow and be separated from the last
   parameter by a space.  Also, note that the text following a response
   number may vary in different implementations of the server. The
   3-digit numeric code should be used to determine what response was
   sent.

   Response codes not specified in this standard may be used for any
   installation-specific additional commands also not specified. These
   should be chosen to fit the pattern of x8x specified above.  (Note
   that debugging is provided for explicitly in the x9x response codes.)
   The use of unspecified response codes for standard commands is
   prohibited.

   We have provided a response pattern x9x for debugging.  Since much
   debugging output may be classed as "informative messages", we would
   expect, therefore, that responses 190 through 199 would be used for
   various debugging outputs.  There is no requirement in this
   specification for debugging output, but if such is provided over the
   connected stream, it must use these response codes.  If appropriate
   to a specific implementation, other x9x codes may be used for
   debugging.  (An example might be to use e.g., 290 to acknowledge a
   remote debugging request.)


Kantor & Lapsley                                                [Page 7]



RFC 977                                                    February 1986
Network News Transfer Protocol


2.4.3.  General Responses

   The following is a list of general response codes that may be sent by
   the NNTP server.  These are not specific to any one command, but may
   be returned as the result of a connection, a failure, or some unusual
   condition.

   In general, 1xx codes may be ignored or displayed as desired;  code
   200 or 201 is sent upon initial connection to the NNTP server
   depending upon posting permission; code 400 will be sent when the
   NNTP server discontinues service (by operator request, for example);
   and 5xx codes indicate that the command could not be performed for
   some unusual reason.

      100 help text
      190
        through
      199 debug output

      200 server ready - posting allowed
      201 server ready - no posting allowed

      400 service discontinued

      500 command not recognized
      501 command syntax error
      502 access restriction or permission denied
      503 program fault - command not performed

3.  Command and Response Details

   On the following pages are descriptions of each command recognized by
   the NNTP server and the responses which will be returned by those
   commands.

   Each command is shown in upper case for clarity, although case is
   ignored in the interpretation of commands by the NNTP server.  Any
   parameters are shown in lower case.  A parameter shown in [square
   brackets] is optional.  For example, [GMT] indicates that the
   triglyph GMT may present or omitted.

   Every command described in this section must be implemented by all
   NNTP servers.






Kantor & Lapsley                                                [Page 8]



RFC 977                                                    February 1986
Network News Transfer Protocol


   There is no prohibition against additional commands being added;
   however, it is recommended that any such unspecified command begin
   with the letter "X" to avoid conflict with later revisions of this
   specification.

   Implementors are reminded that such additional commands may not
   redefine specified status response codes.  Using additional
   unspecified responses for standard commands is also prohibited.

3.1.  The ARTICLE, BODY, HEAD, and STAT commands

   There are two forms to the ARTICLE command (and the related BODY,
   HEAD, and STAT commands), each using a different method of specifying
   which article is to be retrieved.  When the ARTICLE command is
   followed by a message-id in angle brackets ("<" and ">"), the first
   form of the command is used; when a numeric parameter or no parameter
   is supplied, the second form is invoked.

   The text of the article is returned as a textual response, as
   described earlier in this document.

   The HEAD and BODY commands are identical to the ARTICLE command
   except that they respectively return only the header lines or text
   body of the article.

   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".

3.1.1.  ARTICLE (selection by message-id)

   ARTICLE <message-id>

   Display the header, a blank line, then the body (text) of the
   specified article.  Message-id is the message id of an article as
   shown in that article's header.  It is anticipated that the client
   will obtain the message-id from a list provided by the NEWNEWS
   command, from references contained within another article, or from
   the message-id provided in the response to some other commands.

   Please note that the internally-maintained "current article pointer"
   is NOT ALTERED by this command. This is both to facilitate the
   presentation of articles that may be referenced within an article


Kantor & Lapsley                                                [Page 9]



RFC 977                                                    February 1986
Network News Transfer Protocol


   being read, and because of the semantic difficulties of determining
   the proper sequence and membership of an article which may have been
   posted to more than one newsgroup.

3.1.2.  ARTICLE (selection by number)

   ARTICLE [nnn]

   Displays the header, a blank line, then the body (text) of the
   current or specified article.  The optional parameter nnn is the

   numeric id of an article in the current newsgroup and must be chosen
   from the range of articles provided when the newsgroup was selected.
   If it is omitted, the current article is assumed.

   The internally-maintained "current article pointer" is set by this
   command if a valid article number is specified.

   [the following applies to both forms of the article command.] A
   response indicating the current article number, a message-id string,
   and that text is to follow will be returned.

   The message-id string returned is an identification string contained
   within angle brackets ("<" and ">"), which is derived from the header
   of the article itself.  The Message-ID header line (required by
   RFC850) from the article must be used to supply this information. If
   the message-id header line is missing from the article, a single
   digit "0" (zero) should be supplied within the angle brackets.

   Since the message-id field is unique with each article, it may be
   used by a news reading program to skip duplicate displays of articles
   that have been posted more than once, or to more than one newsgroup.

3.1.3.  Responses

   220 n <a> article retrieved - head and body follow
           (n = article number, <a> = message-id)
   221 n <a> article retrieved - head follows
   222 n <a> article retrieved - body follows
   223 n <a> 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





Kantor & Lapsley                                               [Page 10]



RFC 977                                                    February 1986
Network News Transfer Protocol


3.2.  The GROUP command

3.2.1.  GROUP

   GROUP ggg

   The required parameter ggg is the name of the newsgroup to be
   selected (e.g. "net.news").  A list of valid newsgroups may be
   obtained from the LIST command.

   The successful selection response will return the article numbers of
   the first and last articles in the group, and an estimate of the
   number of articles on file in the group.  It is not necessary that
   the estimate be correct, although that is helpful; it must only be
   equal to or larger than the actual number of articles on file.  (Some
   implementations will actually count the number of articles on file.
   Others will just subtract first article number from last to get an
   estimate.)

   When a valid group is selected by means of this command, the
   internally maintained "current article pointer" is set to the first
   article in the group.  If an invalid group is specified, the
   previously selected group and article remain selected.  If an empty
   newsgroup is selected, the "current article pointer" is in an
   indeterminate state and should not be used.

   Note that the name of the newsgroup is not case-dependent.  It must
   otherwise match a newsgroup obtained from the LIST command or an
   error will result.

3.2.2.  Responses

   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











Kantor & Lapsley                                               [Page 11]



RFC 977                                                    February 1986
Network News Transfer Protocol


3.3.  The HELP command

3.3.1.  HELP

   HELP

   Provides a short summary of commands that are understood by this
   implementation of the server. The help text will be presented as a
   textual response, terminated by a single period on a line by itself.

   3.3.2.  Responses

   100 help text follows

3.4.  The IHAVE command

3.4.1.  IHAVE

   IHAVE <messageid>

   The IHAVE command informs the server that the client has an article
   whose id is <messageid>.  If the server desires a copy of that
   article, it will return a response instructing the client to send the
   entire article.  If the server does not want the article (if, for
   example, the server already has a copy of it), a response indicating
   that the article is not wanted will be returned.

   If transmission of the article is requested, the client should send
   the entire article, including header and body, in the manner
   specified for text transmission from the server. A response code
   indicating success or failure of the transferral of the article will
   be returned.

   This function differs from the POST command in that it is intended
   for use in transferring already-posted articles between hosts.
   Normally it will not be used when the client is a personal
   newsreading program.  In particular, this function will invoke the
   server's news posting program with the appropriate settings (flags,
   options, etc) to indicate that the forthcoming article is being
   forwarded from another host.

   The server may, however, elect not to post or forward the article if
   after further examination of the article it deems it inappropriate to
   do so.  The 436 or 437 error codes may be returned as appropriate to
   the situation.

   Reasons for such subsequent rejection of an article may include such


Kantor & Lapsley                                               [Page 12]



RFC 977                                                    February 1986
Network News Transfer Protocol


   problems as inappropriate newsgroups or distributions, disk space
   limitations, article lengths, garbled headers, and the like.  These
   are typically restrictions enforced by the server host's news
   software and not necessarily the NNTP server itself.

3.4.2.  Responses

   235 article transferred ok
   335 send article to be transferred.  End with <CR-LF>.<CR-LF>
   435 article not wanted - do not send it
   436 transfer failed - try again later
   437 article rejected - do not try again

   An implementation note:

   Because some host news posting software may not be able to decide
   immediately that an article is inappropriate for posting or
   forwarding, it is acceptable to acknowledge the successful transfer
   of the article and to later silently discard it.  Thus it is
   permitted to return the 235 acknowledgement code and later discard
   the received article.  This is not a fully satisfactory solution to
   the problem.  Perhaps some implementations will wish to send mail to
   the author of the article in certain of these cases.

3.5.  The LAST command

3.5.1.  LAST

   LAST

   The internally maintained "current article pointer" is set to the
   previous article in the current newsgroup.  If already positioned at
   the first article of the newsgroup, an error message is returned and
   the current article remains selected.

   The internally-maintained "current article pointer" is set by this
   command.

   A response indicating the current article number, and a message-id
   string will be returned.  No text is sent in response to this
   command.

3.5.2.  Responses

   223 n a article retrieved - request text separately
           (n = article number, a = unique article id)



Kantor & Lapsley                                               [Page 13]



RFC 977                                                    February 1986
Network News Transfer Protocol


   412 no newsgroup selected
   420 no current article has been selected
   422 no previous article in this group

3.6.  The LIST command

3.6.1.  LIST

   LIST

   Returns a list of valid newsgroups and associated information.  Each
   newsgroup is sent as a line of text in the following format:

      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').

   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.

   Note that posting may still be prohibited to a client even though the
   LIST command indicates that posting is permitted to a particular
   newsgroup. See the POST command for an explanation of client
   prohibitions.  The posting flag exists for each newsgroup because
   some newsgroups are moderated or are digests, and therefore cannot be
   posted to; that is, articles posted to them must be mailed to a
   moderator who will post them for the submitter.  This is independent
   of the posting permission granted to a client by the NNTP server.

   Please note that an empty list (i.e., the text body returned by this
   command consists only of the terminating period) is a possible valid
   response, and indicates that there are currently no valid newsgroups.

3.6.2.  Responses

   215 list of newsgroups follows







Kantor & Lapsley                                               [Page 14]



RFC 977                                                    February 1986
Network News Transfer Protocol


3.7.  The NEWGROUPS command

3.7.1.  NEWGROUPS

   NEWGROUPS date time [GMT] [<distributions>]

   A list of newsgroups created since <date and time> will be listed in
   the same format as the LIST command.

   The date is sent as 6 digits in the format YYMMDD, where YY is the
   last two digits of the year, MM is the two digits of the month (with
   leading zero, if appropriate), and DD is the day of the month (with
   leading zero, if appropriate).  The closest century is assumed as
   part of the year (i.e., 86 specifies 1986, 30 specifies 2030, 99 is
   1999, 00 is 2000).

   Time must also be specified.  It must be as 6 digits HHMMSS with HH
   being hours on the 24-hour clock, MM minutes 00-59, and SS seconds
   00-59.  The time is assumed to be in the server's timezone unless the
   token "GMT" appears, in which case both time and date are evaluated
   at the 0 meridian.

   The optional parameter "distributions" is a list of distribution
   groups, enclosed in angle brackets.  If specified, the distribution
   portion of a new newsgroup (e.g, 'net' in 'net.wombat') will be
   examined for a match with the distribution categories listed, and
   only those new newsgroups which match will be listed.  If more than
   one distribution group is to be listed, they must be separated by
   commas within the angle brackets.

   Please note that an empty list (i.e., the text body returned by this
   command consists only of the terminating period) is a possible valid
   response, and indicates that there are currently no new newsgroups.

3.7.2.  Responses

   231 list of new newsgroups follows












Kantor & Lapsley                                               [Page 15]



RFC 977                                                    February 1986
Network News Transfer Protocol


3.8.  The NEWNEWS command

3.8.1.  NEWNEWS

   NEWNEWS newsgroups date time [GMT] [<distribution>]

   A list of message-ids of articles posted or received to the specified
   newsgroup since "date" will be listed. The format of the listing will
   be one message-id per line, as though text were being sent.  A single
   line consisting solely of one period followed by CR-LF will terminate
   the list.

   Date and time are in the same format as the NEWGROUPS command.

   A newsgroup name containing a "*" (an asterisk) may be specified to
   broaden the article search to some or all newsgroups.  The asterisk
   will be extended to match any part of a newsgroup name (e.g.,
   net.micro* will match net.micro.wombat, net.micro.apple, etc). Thus
   if only an asterisk is given as the newsgroup name, all newsgroups
   will be searched for new news.

   (Please note that the asterisk "*" expansion is a general
   replacement; in particular, the specification of e.g., net.*.unix
   should be correctly expanded to embrace names such as net.wombat.unix
   and net.whocares.unix.)

   Conversely, if no asterisk appears in a given newsgroup name, only
   the specified newsgroup will be searched for new articles. Newsgroup
   names must be chosen from those returned in the listing of available
   groups.  Multiple newsgroup names (including a "*") may be specified
   in this command, separated by a comma.  No comma shall appear after
   the last newsgroup in the list.  [Implementors are cautioned to keep
   the 512 character command length limit in mind.]

   The exclamation point ("!") may be used to negate a match. This can
   be used to selectively omit certain newsgroups from an otherwise
   larger list.  For example, a newsgroups specification of
   "net.*,mod.*,!mod.map.*" would specify that all net.<anything> and
   all mod.<anything> EXCEPT mod.map.<anything> newsgroup names would be
   matched.  If used, the exclamation point must appear as the first
   character of the given newsgroup name or pattern.

   The optional parameter "distributions" is a list of distribution
   groups, enclosed in angle brackets.  If specified, the distribution
   portion of an article's newsgroup (e.g, 'net' in 'net.wombat') will
   be examined for a match with the distribution categories listed, and
   only those articles which have at least one newsgroup belonging to


Kantor & Lapsley                                               [Page 16]



RFC 977                                                    February 1986
Network News Transfer Protocol


   the list of distributions will be listed.  If more than one
   distribution group is to be supplied, they must be separated by
   commas within the angle brackets.

   The use of the IHAVE, NEWNEWS, and NEWGROUPS commands to distribute
   news is discussed in an earlier part of this document.

   Please note that an empty list (i.e., the text body returned by this
   command consists only of the terminating period) is a possible valid
   response, and indicates that there is currently no new news.

3.8.2.  Responses

   230 list of new articles by message-id follows

3.9.  The NEXT command

3.9.1.  NEXT

   NEXT

   The internally maintained "current article pointer" is advanced to
   the next article in the current newsgroup.  If no more articles
   remain in the current group, an error message is returned and the
   current article remains selected.

   The internally-maintained "current article pointer" is set by this
   command.

   A response indicating the current article number, and the message-id
   string will be returned.  No text is sent in response to this
   command.

3.9.2.  Responses

   223 n a article retrieved - request text separately
           (n = article number, a = unique article id)
   412 no newsgroup selected
   420 no current article has been selected
   421 no next article in this group









Kantor & Lapsley                                               [Page 17]



RFC 977                                                    February 1986
Network News Transfer Protocol


3.10.  The POST command

3.10.1.  POST

   POST

   If posting is allowed, response code 340 is returned to indicate that
   the article to be posted should be sent. Response code 440 indicates
   that posting is prohibited for some installation-dependent reason.

   If posting is permitted, the article should be presented in the
   format specified by RFC850, and should include all required header
   lines. After the article's header and body have been completely sent
   by the client to the server, a further response code will be returned
   to indicate success or failure of the posting attempt.

   The text forming the header and body of the message to be posted
   should be sent by the client using the conventions for text received
   from the news server:  A single period (".") on a line indicates the
   end of the text, with lines starting with a period in the original
   text having that period doubled during transmission.

   No attempt shall be made by the server to filter characters, fold or
   limit lines, or otherwise process incoming text.  It is our intent
   that the server just pass the incoming message to be posted to the
   server installation's news posting software, which is separate from
   this specification.  See RFC850 for more details.

   Since most installations will want the client news program to allow
   the user to prepare his message using some sort of text editor, and
   transmit it to the server for posting only after it is composed, the
   client program should take note of the herald message that greeted it
   when the connection was first established. This message indicates
   whether postings from that client are permitted or not, and can be
   used to caution the user that his access is read-only if that is the
   case. This will prevent the user from wasting a good deal of time
   composing a message only to find posting of the message was denied.
   The method and determination of which clients and hosts may post is
   installation dependent and is not covered by this specification.

3.10.2.  Responses

   240 article posted ok
   340 send article to be posted. End with <CR-LF>.<CR-LF>
   440 posting not allowed
   441 posting failed



Kantor & Lapsley                                               [Page 18]



RFC 977                                                    February 1986
Network News Transfer Protocol


   (for reference, one of the following codes will be sent upon initial
   connection; the client program should determine whether posting is
   generally permitted from these:) 200 server ready - posting allowed
   201 server ready - no posting allowed

3.11.  The QUIT command

3.11.1.  QUIT

   QUIT

   The server process acknowledges the QUIT command and then closes the
   connection to the client.  This is the preferred method for a client
   to indicate that it has finished all its transactions with the NNTP
   server.

   If a client simply disconnects (or the connection times out, or some
   other fault occurs), the server should gracefully cease its attempts
   to service the client.

3.11.2.  Responses

   205 closing connection - goodbye!

3.12.  The SLAVE command

3.12.1.  SLAVE

   SLAVE

   Indicates to the server that this client connection is to a slave
   server, rather than a user.

   This command is intended for use in separating connections to single
   users from those to subsidiary ("slave") servers.  It may be used to
   indicate that priority should therefore be given to requests from
   this client, as it is presumably serving more than one person.  It
   might also be used to determine which connections to close when
   system load levels are exceeded, perhaps giving preference to slave
   servers.  The actual use this command is put to is entirely
   implementation dependent, and may vary from one host to another.  In
   NNTP servers which do not give priority to slave servers, this
   command must nonetheless be recognized and acknowledged.

3.12.2.  Responses

   202 slave status noted


Kantor & Lapsley                                               [Page 19]



RFC 977                                                    February 1986
Network News Transfer Protocol


4.  Sample Conversations

   These are samples of the conversations that might be expected with
   the news server in hypothetical sessions.  The notation C: indicates
   commands sent to the news server from the client program; S: indicate
   responses received from the server by the client.

4.1.  Example 1 - relative access with NEXT

   S:      (listens at TCP port 119)

   C:      (requests connection on TCP port 119)
   S:      200 wombatvax news server ready - posting ok

   (client asks for a current newsgroup list)
   C:      LIST
   S:      215 list of newsgroups follows
   S:      net.wombats 00543 00501 y
   S:      net.unix-wizards 10125 10011 y
           (more information here)
   S:      net.idiots 00100 00001 n
   S:      .

   (client selects a newsgroup)
   C:      GROUP net.unix-wizards
   S:      211 104 10011 10125 net.unix-wizards group selected
           (there are 104 articles on file, from 10011 to 10125)

   (client selects an article to read)
   C:      STAT 10110
   S:      223 10110 <[email protected]> article retrieved - statistics
           only (article 10110 selected, its message-id is
           <[email protected]>)

   (client examines the header)
   C:      HEAD
   S:      221 10110 <[email protected]> article retrieved - head
           follows (text of the header appears here)
   S:      .

   (client wants to see the text body of the article)
   C:      BODY
   S:      222 10110 <[email protected]> article retrieved - body
           follows (body text here)
   S:      .

   (client selects next article in group)


Kantor & Lapsley                                               [Page 20]



RFC 977                                                    February 1986
Network News Transfer Protocol


   C:      NEXT
   S:      223 10113 <[email protected]> article retrieved - statistics
           only (article 10113 was next in group)

   (client finishes session)
   C:      QUIT
   S:      205 goodbye.

4.2.  Example 2 - absolute article access with ARTICLE

   S:      (listens at TCP port 119)

   C:      (requests connection on TCP port 119)
   S:      201 UCB-VAX netnews server ready -- no posting allowed

   C:      GROUP msgs
   S:      211 103 402 504 msgs Your new group is msgs
           (there are 103 articles, from 402 to 504)

   C:      ARTICLE 401
   S:      423 No such article in this newsgroup

   C:      ARTICLE 402
   S:      220 402 <[email protected]> Article retrieved, text follows
   S:      (article header and body follow)
   S:      .

   C:      HEAD 403
   S:      221 403 <[email protected]> Article retrieved, header follows
   S:      (article header follows)
   S:      .

   C:      QUIT
   S:      205 UCB-VAX news server closing connection.  Goodbye.

4.3.  Example 3 - NEWGROUPS command

   S:      (listens at TCP port 119)

   C:      (requests connection on TCP port 119)
   S:      200 Imaginary Institute News Server ready (posting ok)

   (client asks for new newsgroups since April 3, 1985)
   C:      NEWGROUPS 850403 020000

   S:      231 New newsgroups since 03/04/85 02:00:00 follow



Kantor & Lapsley                                               [Page 21]



RFC 977                                                    February 1986
Network News Transfer Protocol


   S:      net.music.gdead
   S:      net.games.sources
   S:      .

   C:      GROUP net.music.gdead
   S:      211 0 1 1 net.music.gdead Newsgroup selected
           (there are no articles in that newsgroup, and
           the first and last article numbers should be ignored)

   C:      QUIT
   S:      205 Imaginary Institute news server ceasing service.  Bye!

4.4.  Example 4 - posting a news article

   S:      (listens at TCP port 119)

   C:      (requests connection on TCP port 119)
   S:      200 BANZAIVAX news server ready, posting allowed.

   C:      POST
   S:      340 Continue posting; Period on a line by itself to end
   C:      (transmits news article in RFC850 format)
   C:      .
   S:      240 Article posted successfully.

   C:      QUIT
   S:      205 BANZAIVAX closing connection.  Goodbye.

4.5.  Example 5 - interruption due to operator request

   S:      (listens at TCP port 119)

   C:      (requests connection on TCP port 119)
   S:      201 genericvax news server ready, no posting allowed.

           (assume normal conversation for some time, and
           that a newsgroup has been selected)

   C:      NEXT
   S:      223 1013 <[email protected]> Article retrieved; text separate.

   C:      HEAD
   C:      221 1013 <[email protected]> Article retrieved; head follows.

   S:      (sends head of article, but halfway through is
           interrupted by an operator request.  The following
           then occurs, without client intervention.)


Kantor & Lapsley                                               [Page 22]



RFC 977                                                    February 1986
Network News Transfer Protocol


   S:      (ends current line with a CR-LF pair)
   S:      .
   S:      400 Connection closed by operator.  Goodbye.
   S:      (closes connection)

4.6.  Example 6 - Using the news server to distribute news between
      systems.

   S:      (listens at TCP port 119)

   C:      (requests connection on TCP port 119)
   S:      201 Foobar NNTP server ready (no posting)

   (client asks for new newsgroups since 2 am, May 15, 1985)
   C:      NEWGROUPS 850515 020000
   S:      235 New newsgroups since 850515 follow
   S:      net.fluff
   S:      net.lint
   S:      .

   (client asks for new news articles since 2 am, May 15, 1985)
   C:      NEWNEWS * 850515 020000
   S:      230 New news since 850515 020000 follows
   S:      <[email protected]>
   S:      <[email protected]>
   S:      <[email protected]>
   S:      .

   (client asks for article <[email protected]>)
   C:      ARTICLE <[email protected]>
   S:      220 <[email protected]> All of article follows
   S:      (sends entire message)
   S:      .

   (client asks for article <[email protected]>
   C:      ARTICLE <[email protected]>
   S:      220 <[email protected]> All of article follows
   S:      (sends entire message)
   S:      .

   (client asks for article <[email protected]>
   C:      ARTICLE <[email protected]>
   S:      220 <[email protected]> All of article follows
   S:      (sends entire message)
   S:      .




Kantor & Lapsley                                               [Page 23]



RFC 977                                                    February 1986
Network News Transfer Protocol


   (client offers an article it has received recently)
   C:      IHAVE <[email protected]>
   S:      435 Already seen that one, where you been?

   (client offers another article)
   C:      IHAVE <[email protected]>
   S:      335 News to me!  <CRLF.CRLF> to end.
   C:      (sends article)
   C:      .
   S:      235 Article transferred successfully.  Thanks.

   (or)

   S:      436 Transfer failed.

   (client is all through with the session)
   C:      QUIT
   S:      205 Foobar NNTP server bids you farewell.

4.7.  Summary of commands and responses.

   The following are the commands recognized and responses returned by
   the NNTP server.

4.7.1.  Commands

   ARTICLE
   BODY
   GROUP
   HEAD
   HELP
   IHAVE
   LAST
   LIST
   NEWGROUPS
   NEWNEWS
   NEXT
   POST
   QUIT
   SLAVE
   STAT

4.7.2.  Responses

   100 help text follows
   199 debug output



Kantor & Lapsley                                               [Page 24]



RFC 977                                                    February 1986
Network News Transfer Protocol


   200 server ready - posting allowed
   201 server ready - no posting allowed
   202 slave status noted
   205 closing connection - goodbye!
   211 n f l s group selected
   215 list of newsgroups follows
   220 n <a> article retrieved - head and body follow 221 n <a> article
   retrieved - head follows
   222 n <a> article retrieved - body follows
   223 n <a> article retrieved - request text separately 230 list of new
   articles by message-id follows
   231 list of new newsgroups follows
   235 article transferred ok
   240 article posted ok

   335 send article to be transferred.  End with <CR-LF>.<CR-LF>
   340 send article to be posted. End with <CR-LF>.<CR-LF>

   400 service discontinued
   411 no such news group
   412 no newsgroup has been selected
   420 no current article has been selected
   421 no next article in this group
   422 no previous article in this group
   423 no such article number in this group
   430 no such article found
   435 article not wanted - do not send it
   436 transfer failed - try again later
   437 article rejected - do not try again.
   440 posting not allowed
   441 posting failed

   500 command not recognized
   501 command syntax error
   502 access restriction or permission denied
   503 program fault - command not performed

4.8.  A Brief Word about the USENET News System

   In the UNIX world, which traditionally has been linked by 1200 baud
   dial-up telephone lines, the USENET News system has evolved to handle
   central storage, indexing, retrieval, and distribution of news.  With
   the exception of its underlying transport mechanism (UUCP), USENET
   News is an efficient means of providing news and bulletin service to
   subscribers on UNIX and other hosts worldwide.  The USENET News




Kantor & Lapsley                                               [Page 25]



RFC 977                                                    February 1986
Network News Transfer Protocol


   system is discussed in detail in RFC 850.  It runs on most versions
   of UNIX and on many other operating systems, and is customarily
   distributed without charge.

   USENET uses a spooling area on the UNIX host to store news articles,
   one per file. Each article consists of a series of heading text,
   which contain the sender's identification and organizational
   affiliation, timestamps, electronic mail reply paths, subject,
   newsgroup (subject category), and the like.  A complete news article
   is reproduced in its entirety below.  Please consult RFC 850 for more
   details.

      Relay-Version: version B 2.10.3 4.3bsd-beta 6/6/85; site
      sdcsvax.UUCP
      Posting-Version: version B 2.10.1 6/24/83 SMI; site unitek.uucp
      Path:sdcsvax!sdcrdcf!hplabs!qantel!ihnp4!alberta!ubc-vision!unitek
      !honman
      From: [email protected] (Man Wong)
      Newsgroups: net.unix-wizards
      Subject: foreground -> background ?
      Message-ID: <[email protected]>
      Date: 25 Sep 85 23:51:52 GMT
      Date-Received: 29 Sep 85 09:54:48 GMT
      Reply-To: [email protected] (Hon-Man Wong)
      Distribution: net.all
      Organization: Unitek Technologies Corporation
      Lines: 12

      I have a process (C program) which generates a child and waits for
      it to return.  What I would like to do is to be able to run the
      child process interactively for a while before kicking itself into
      the background so I can return to the parent process (while the
      child process is RUNNING in the background).  Can it be done?  And
      if it can, how?

      Please reply by E-mail.  Thanks in advance.

      Hon-Man Wong











Kantor & Lapsley                                               [Page 26]



RFC 977                                                    February 1986
Network News Transfer Protocol


5.  References

   [1]  Crocker, D., "Standard for the Format of ARPA Internet Text
        Messages", RFC-822, Department of Electrical Engineering,
        University of Delaware, August, 1982.

   [2]  Horton, M., "Standard for Interchange of USENET Messages",
        RFC-850, USENET Project, June, 1983.

   [3]  Postel, J., "Transmission Control Protocol- DARPA Internet
        Program Protocol Specification", RFC-793, USC/Information
        Sciences Institute, September, 1981.

   [4]  Postel, J., "Simple Mail Transfer Protocol", RFC-821,
        USC/Information Sciences Institute, August, 1982.

6.  Acknowledgements

   The authors wish to express their heartfelt thanks to those many
   people who contributed to this specification, and especially to Erik
   Fair and Chuq von Rospach, without whose inspiration this whole thing
   would not have been necessary.

7.  Notes

   <1> UNIX is a trademark of Bell Laboratories.























Kantor & Lapsley                                               [Page 27]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/ntp/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
2003-04-16  Pat Thoyts  <[email protected]>

	* time.man:      Renamed the man page to avoid clashing with
	* ntp_time.man:  the tcl time.n manual page.

2003-03-20  Pat Thoyts  <[email protected]>

	* time.test: Added a test package.
	* pkgIndex.tcl: Added a package index file.

2003-03-17  Pat Thoyts  <[email protected]>

	* 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.
	
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































Deleted modules/ntp/ntp_time.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
[manpage_begin ntp_time n 1.0.0]
[copyright {2002, Pat Thoyts <[email protected]>}]
[moddesc   {ntp}]
[titledesc {Tcl Time Service Client}]
[require Tcl 8.2]
[require time [opt 1.0.0]]
[description]
[para]

This package implements a client for the RFC 868 TIME protocol. This
simple protocol returns the time in seconds since 1 January 1900 to
either tcp or udp clients.

[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.

[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]
[lst_item "[cmd -protocol] [arg number]"]
  Set the default network protocol. This defaults to udp if the tcludp
  package is available. Otherwise it will use tcp.
[lst_item "[cmd -port] [arg number]"]
  Set the default port to use. RFC868 uses port 37.
[lst_item "[cmd -timeout] [arg number]"]
  Set the default timeout value in milliseconds. The default is 10 seconds.
[lst_item "[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.
[lst_item "[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. RFC868 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
}]

[see_also ntp]
[section AUTHORS]
Pat Thoyts

[keywords time NTP RFC868]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































Deleted modules/ntp/pkgIndex.tcl.

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

package ifneeded time 1.0.0 [list source [file join $dir time.tcl]]
<
<
<
<
<
<
<
<
<
<
<






















Deleted modules/ntp/time.tcl.

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

package require Tcl 8.0;                # tcl minimum version
package require log;                    # tcllib 1.3

namespace eval ::time {
    variable version 1.0.0
    variable rcsid {$Id: time.tcl,v 1.3 2003/03/26 22:58:59 patthoyts Exp $}

    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
        }
        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 State -*]] ", "]
                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::gettime {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] }
            -protocol { 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} {
        return -code error "wrong # args:
              \"gettime ?options? timeserver ?port?\""
    }
    set State(-timeserver) [lindex $args 0]
    if {$len == 2} {
        set State(-port) [lindex $args 1]
    }

    return [QueryTime $token]
}

proc ::time::QueryTime {token} {
    variable $token
    upvar 0 $token State

    if {$State(-protocol) == "udp"} {
        set State(sock) [udp_open]
        udp_conf $State(sock) $State(-timeserver) $State(-port)
    } else {
        set State(sock) [socket $State(-timeserver) $State(-port)]
    }
    
    # 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

    puts -nonewline $State(sock) "abcd"

    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)
    }
    binary scan $State(data) I r
    return [expr {$r - $epoch(unix)}]
}

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
    
    set State(data) [read $State(sock)]
    #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 $::time::version

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




















































































































































































































































































































































































































































































































































































































































Deleted modules/ntp/time.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
# time.test = Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# Exercise the tcllib time package.
#
# $Id: time.test,v 1.2 2003/03/20 00:41:04 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

if {[catch {package require time}]} {
        puts "ERROR: failed to load time package. Skipping tests."
        ::tcltest::cleanupTests
        return
}

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

set testScript tstsrv.tmp

proc createServerProcess {} {
    file delete -force $::testScript
    set f [open $::testScript w+]
    puts $f {
        proc ::srv {chan args} {
            if {[catch {
                set r [binary format I [expr {[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

    set f [open |[list [::tcltest::interpreter] $::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.2 {time::unixtime} {
    global token
    list [catch {
        set t [time::unixtime $token]
        string is integer -strict $t
    } m] $m
} {0 1}

test time-1.3 {time::cget} {
    global token
    list [catch {
        time::cget -port
    } m] $m
} {0 37}

test time-1.4 {time::cleanup} {
    global token
    list [catch {
        time::cleanup $token
    } m] $m
} {0 {}}

# -------------------------------------------------------------------------
file delete -force $::testScript
::tcltest::cleanupTests
return

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




















































































































































































































Deleted modules/pop3/ChangeLog.

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

	* 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  <[email protected]>

	* pop3.tcl:
	* pop3.man:
	* pkgIndex.tcl:  Set version of the package to to 1.6

2003-04-09  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* pop3.man: More semantic markup, less visual one.

2002-10-14  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* pop3.man: New file, doctools manpage.

2002-01-15  Andreas Kupries  <[email protected]>

	* Bumped version to 1.5.1

2001-12-11  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* pop3.n:
	* pop3.tcl:
	* pkgIndex.tcl: Version up to 1.5

2001-08-20  Andreas Kupries  <[email protected]>

	* pop3.tcl: Added UIDL command, patch [448634] by Mark G. Saye
	  <[email protected]>. 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  <[email protected]>

	* 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
	  <[email protected]> for his help in testing the code.

2001-07-31  Andreas Kupries <[email protected]>

	* 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 <[email protected]>

	* pop3.tcl: Fixed dubious code reported by frink.

2001-01-24  Scott Redman  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* ChangeLog:
	* man.macros:
	* pkgIndex.tcl:
	* pop3.n:
	* pop3.tcl:  New POP3 email client API, inspired by Scott
	Beasley's "frenchie" email client program.  
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































Deleted modules/pop3/clnt.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

# pop3 client, loaded with sequence of operations
# to perform.

set modules [file dirname $testdir]
set pop     [file join $modules pop3]

# Read client functionality

source [file join $testdir pop3.tcl]

proc log {code {payload {}}} {
    puts stdout [list $code $payload]
    flush stdout
    return
}

proc res {fail msg} {log res [list $fail $msg]}
proc wait {} {while {[gets stdin line] < 0} {}}

# Run the provided operations ...
# Mini CPU ...

set chan {}
set fail 0

foreach op $ops {
    foreach {cmd ca} $op break
    switch -exact -- $cmd {
	wait {wait}
	poke {
	    res 0 $::pop3::state($chan)
	}
	open {
	    foreach {user passwd} $ca break
	    set  fail [catch {set chan [::pop3::open localhost $user $passwd $port]} msg]
	    res $fail $msg
	}
	close {
	    set  fail [catch {::pop3::close $chan} msg]
	    res $fail $msg
	}
	status {
	    set  fail [catch {::pop3::status $chan} msg]
	    res $fail $msg
	}
	top {
	    foreach {msg n} $ca break
	    set  fail [catch {::pop3::top $chan $msg $n} msg]
	    res $fail $msg
	}
	retrieve {
	    foreach {start end} $ca break
	    if {$end == {}} {set end -1}
	    set  fail [catch {::pop3::retrieve $chan $start $end} msg]
	    res $fail $msg
	}
	delete {
	    foreach {start end} $ca break
	    if {$end == {}} {set end -1}
	    set  fail [catch {::pop3::delete $chan $start $end} msg]
	    res $fail $msg
	}
	list {
	    foreach {msg} $ca break
	    set  fail [catch {::pop3::list $chan $msg} msg]
	    res $fail $msg
	}
	uidl {
	    foreach {msg} $ca break
	    set  fail [catch {::pop3::uidl $chan $msg} msg]
	    res $fail $msg
	}
	last {
	    set  fail [catch {::pop3::last $chan} msg]
	    res $fail $msg
	}
    }
    if {$fail} break
}

# Wait for last call from control and then exit.

log done
wait
exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































Deleted modules/pop3/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 pop3 1.6 [list source [file join $dir pop3.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/pop3/pop3.man.

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

The [package pop3] package provides a simple Tcl-only client library
for the POP3 email protocol (RFC1939). 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.

[section COMMANDS]

[list_begin definitions]

[call [cmd ::pop3::open] [opt "[option -msex] 0|1"] [opt "[option -retr-mode] retr|list|slow"] [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 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.

[nl]

The command recognizes the options [option -msex] and

[option -retr-mode]. The first of them can be used to notify the
package of the fact that the server to talk to is an MS Exchange
server (which has some oddities we have to work around). The default
is 0.

[nl]

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.


[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
byte 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.

[nl]

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.

[nl]

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]

[lst_item [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]

[lst_item [const start]]

This is a logical value for the first message in the spool, equivalent
to the value 1.

[lst_item [const next]]

The message immediately following the last message read, see
[cmd ::pop3::last]. 

[lst_item [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]

[lst_item [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]

[lst_item [const last]]

The message is the last message read by a POP3 client, see
[cmd ::pop3::last].

[lst_item [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::close] [arg chan]]

Gracefully close the connect after sending a POP3 QUIT command down
the socket.

[list_end]

[keywords mail email pop pop3 RFC1939]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































Deleted modules/pop3/pop3.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
'\"
'\" Copyright (c) 2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: pop3.n,v 1.9 2002/01/18 20:51:16 andreas_kupries Exp $
'\" 
.so man.macros
.TH pop3 n 1.5.1 pop3 "Tcl POP3 Client Library"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
pop3 \- Tcl client for POP3 email protocol
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require pop3 ?1.5.1?\fR
.sp
\fB::pop3::open\fR ?-msex \fB0|1\fR? ?-retr-mode \fBretr|list|slow\fR? \fIhost user Ipassword \fR?\fIport\fR? 
.sp
\fB::pop3::status\fR \fIchan\fR
.sp
\fB::pop3::last\fR \fIchan\fR
.sp
\fB::pop3::retrieve\fR \fIchan startIndex \fR?\fIendIndex\fR?
.sp
\fB::pop3::delete\fR \fIchan startIndex \fR?\fIendIndex\fR?
.sp
\fB::pop3::list\fR \fIchan\fR \fR?\fImsg\fR?
.sp
\fB::pop3::top\fR \fIchan\fR \fImsg\fR \fIn\fR
.sp
\fB::pop3::uidl\fR \fIchan\fR \fR?\fImsg\fR?
.sp
\fB::pop3::close\fR \fIchan\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fBpop3\fR package provides a simple Tcl-only client library for
the POP3 email protocol (RFC1939). 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
\fBcatch\fR command.
.SH COMMANDS
.TP
\fB::pop3::open\fR ?-msex \fB0|1\fR? ?-retr-mode \fBretr|list|slow\fR? \fIhost username password \fR?\fIport\fR?
Open a socket connection to the server specified by \fIhost\fR,
transmit the \fIusername\fR and \fIpassword\fR as login information to
the server.  The default port number is 110, which can be overridden
using the optional \fIport\fR argument.  The return value is a channel
used by all of the other ::pop3 functions.

The command recognizes the options \fI-msex\fR and
\fI-retr-mode\fR. The first of them can be used to notify the package
of the fact that the server to talk to is an MS Exchange server (which
has some oddities we have to work around). The default is 0.

The retrieval mode determines how exactly messages are read from the
server. The allowed values are \fBretr\fR, \fBlist\fR and
\fBslow\fR. The default is \fBretr\fR. See \fB::pop3::retrieve\fR for
more information.
.TP
\fB::pop3::status\fR \fIchan\fR
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
byte blocks) of the entire mail spool.
.TP
\fB::pop3::last\fR \fIchan\fR
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.
.TP
\fB::pop3::retrieve\fR \fIchan startIndex \fR?\fIendIndex\fR?
Retrieve a range of messages from the server.  If the \fIendIndex\fR
is not specified, only one message will be retrieved.  The return
value is a list containing each message as a separate element.  See
the \fIstartIndex\fR and \fIendIndex\fR descriptions below.

The retrieval mode determines how exactly messages are read from the
server. The mode \fBretr\fR 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 \fBlist\fR 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, \fBslow\fR, 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.

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.
.TP
\fB::pop3::delete\fR \fIchan startIndex \fR?\fIendIndex\fR?
Delete a range of messages from the server.  If the \fIendIndex\fR 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 \fIstartIndex\fR and \fIendIndex\fR descriptions below.
.TP
\fIstartIndex\fR
The \fIstartIndex\fR may be an index of a specific message starting
with the index 1, or it have any of the following values:
.RS
.TP
\fBstart\fR
This is a logical value for the first message in the spool, equivalent
to the value 1.
.TP
\fBnext\fR
The message immediately following the last message read, see
\fB::pop3::last\fR. 
.TP
\fBend\fR
The most recent message in the spool (the end of the spool).  This is
useful to retrieve only the most recent message.
.RE
.TP
\fIendIndex\fR
The \fIendIndex\fR is an optional parameter and defaults to the value -1,
which indicates to only retrieve the one message specified by
\fIstartIndex\fR.  If specified, it may be an index of a specific
message starting with the index 1, or it have any of the following
values:
.RS
.TP
\fBlast\fR
The message is the last message read by a POP3 client, see
\fB::pop3::last\fR.
.TP
\fBend\fR
The most recent message in the spool (the end of the spool).
.RE
.TP
\fB::pop3::list\fR \fIchan\fR \fR?\fImsg\fR?
Returns the scan listing of the mailbox. If parameter \fImsg\fR 
is given, then the listing only for that message is returned.
.TP
\fB::pop3::top\fR \fIchan\fR \fImsg\fR \fIn\fR 
Optional POP3 command, not all servers may support this. 
\fB::pop3::top\fR retrieves headers of a message, specified by parameter 
\fImsg\fR, and number of \fIn\fR lines from the message body.   
.TP
\fB::pop3::uidl\fR \fIchan\fR \fR?\fImsg\fR?
Optional POP3 command, not all servers may support this. 
\fB::pop3::uidl\fR returns the uid listing of the mailbox. If the
parameter \fImsg\fR is specified, then the listing only for that
message is returned.
.TP
\fB::pop3::close\fR \fIchan\fR
Gracefully close the connect after sending a POP3 QUIT command down
the socket.
.SH KEYWORDS
mail, email, pop, pop3, RFC1939
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































Deleted modules/pop3/pop3.tcl.

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

package require Tcl 8.2
package require cmdline
package require log
package provide pop3 1.6

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
}

# ::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}} {
    
    set count [lindex [::pop3::status $chan] 0]
    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 {msex 0 retr_mode retr}

    log::log debug "pop3::open | [join $args]"

    while {[set err [cmdline::getopt args {msex.arg retr-mode.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"
		    }
		}
	    }
	    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 == {}} {
	set port 110
    }

    log::log debug "pop3::open | protocol, connect to $host $port"

    # Argument processing is finally complete, now open the channel

    set chan [socket $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
	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
    }

    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
	error "POP3 LOGIN ERROR: $errorStr"
    }

    # 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 [lindex [::pop3::status $chan] 0]
    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 jsut 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 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 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 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>"
	}
    } else {
	while {[set line [gets $chan]] != ".\r"} {
	    ::log::log debug "pop3 $chan ____ <$line>"
	    append msgBuffer $line
	}
	::log::log debug "pop3 $chan /1__ <$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
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/pop3/pop3.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join $::tcltest::testsDirectory pop3.tcl]
source [file join [file dirname $::tcltest::testsDirectory] devtools subserv.tcl]

if 0 {
    rename test test__
    proc test {args} {
	puts "[lindex $args 0] ____________________________________________"
	return [uplevel test__ $args]
    }
}


package require pop3
puts "tcltest [package present tcltest]"
puts "pop3    [package present pop3]"

# ----------------------------------------------------------------------
# Dialog scripts for the various servers we start ...

set __Init [list \
	CrLf \
	{Send    {+OK localhost muserv ready <534358773_pop3d1_12380@localhost>}} \
	]

set __InitBad [list \
	CrLf \
	{Send    {Grumble}} \
	]

set     __loginOk $__Init
lappend __loginOk \
	{Respond {+OK please send PASS command}} \
	{Respond {+OK congratulations}}

set     __loginFailed $__Init
lappend __loginFailed \
	{Respond {+OK please send PASS command}} \
	{Respond {-ERR authentication failed, sorry}}

set     __loginFailedLock $__Init
lappend __loginFailedLock \
	{Respond {+OK please send PASS command}} \
	{Respond {-ERR could not aquire lock for maildrop ak}}


set     __statusOk $__loginOk
lappend __statusOk \
	{Respond {+OK 11 176}}

set     __statusOkQuit $__statusOk
lappend __statusOkQuit \
	{Respond {+OK localhost muserv shutting down}}

set     __lastFailed $__loginOk
lappend __lastFailed \
	{Respond {-ERR unknown command 'LAST'}}

set     __uidlFailed $__loginOk
lappend __uidlFailed \
	{Respond {-ERR unknown command 'UIDL'}}

set     __retrFail $__statusOk
lappend __retrFail \
	{Respond {-ERR unknown command 'LAST'}} \
	{Respond {+OK localhost muserv shutting down}}

set     __topFail $__loginOk
lappend __topFail \
	{Respond {-ERR no such message}} \
	{Respond {+OK localhost muserv shutting down}}

set __message {MIME-Version: 1.0
Content-Type: text/plain;
              charset="us-ascii"

Test ______

.

--
Done
}

proc message {msg {n {}}} {
    if {$n == {}} {set n [string length $msg]}
    set res [list]
    foreach l [split $msg \n] {
	if {[string match .* $l]} {set l .$l}
	lappend res [list Send $l]
    }
    if {[lindex $res end] == {Send {}}} {
	set res [lrange $res 0 end-1]
    }
    lappend res {Send .}
    return [join $res \n]
}


proc retrMessage {list msg {n {}}} {
    if {$n == {}} {set n [string length $msg]}
    global       __loginOk
    set     res $__loginOk
    lappend res \
	    "Respond {+OK 1 $n}" \
	    {Respond {-ERR unknown command 'LAST'}}
    if {$list} {lappend res "Respond {+OK 1 $n}"}
    lappend res \
	    "Respond {+OK $n octets}" \
	    [message $msg $n] \
	    {Respond {+OK localhost muserv shutting down}} \
	    ]
    return $res
}

proc topMessage {msg} {
    global       __loginOk
    set     res $__loginOk
    lappend res \
	    {Respond +OK} \
	    [message $msg] \
	    {Respond {+OK localhost muserv shutting down}} \
	    ]
    return $res
}

proc deleDialog {} {
    global       __loginOk
    set     res $__loginOk
    lappend res \
	    {RespondLog {+OK 11 176}}

    foreach n {1 2 3 4 5 6 7 8 9 10 11} {
	lappend res \
		{RespondLog {+OK 11 176}} \
		{RespondLog {-ERR unknown command 'LAST'}} \
		{RespondLog {+OK 6 octets}} \
		{Send       {Content-Type: text/plain;}} \
		{Send       {              charset="us-ascii"}} \
		{Send       {}} \
		{Send       {    }} \
		{Send       {.}} \
		{RespondLog {+OK 11 176}} \
		{RespondLog {-ERR unknown command 'LAST'}} \
		"RespondLog {+OK message $n deleted}"
    }
    lappend res \
	    {RespondLog {+OK localhost muserv shutting down}}
    return $res
}


proc setupServer {responses} {
    return [::subserv::muservSpawn [makeFile {} __pop3d] 0 [join $responses \n]]
}


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.
::log::lvSuppress info
::log::lvSuppress notice
::log::lvSuppress debug
::log::lvSuppress warning

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
    set msg
} {couldn't open socket: connection refused}

test pop3-0.6 {wrong type of server (fake)} {
    set port [setupServer $__InitBad]
    catch {pop3::open localhost foo foo $port} msg
    ::subserv::muservStop
    regsub {^([^:]*:).*$} $msg {\1} msg
    set msg
} {POP3 CONNECT ERROR:}

test pop3-0.7 {unknown user} {
    set port [setupServer $__loginFailed]
    catch {pop3::open localhost usrX *** $port} msg
    ::subserv::muservStop
    set msg
} {POP3 LOGIN ERROR:  authentication failed, sorry}

test pop3-0.8 {open pop3 channel} {
    set port [setupServer $__loginOk]
    set psock [pop3::open localhost ak smash $port]
    close $psock
    ::subserv::muservStop
    regsub -all {[0-9]} $psock {} msg
    # status data is retained if the connection is not closed through
    # the prescribed api command.
    lappend msg [peek $psock]
    set msg
} {sock {msex 0 retr_mode retr}}

test pop3-0.9 {outside close} {
    set port [setupServer $__loginOk]
    set psock [pop3::open localhost ak smash $port]
    close $psock
    catch {pop3::close $psock} msg
    ::subserv::muservStop
    blot $msg $psock
} {can not find channel named "SOCK"}

test pop3-0.10 {multiple open pop3 channel to same maildrop} {
    set port [setupServer $__loginFailedLock]
    catch {pop3::open localhost ak smash $port} msg
    ::subserv::muservStop
    set msg
} {POP3 LOGIN ERROR:  could not aquire lock for maildrop ak}


# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
# Handling of 'status'.
# ----------------------------------------------------------------------
# ----------------------------------------------------------------------

test pop3-1.0 {status after cut} {
    set port  [setupServer $__loginOk]
    set psock [pop3::open localhost ak smash $port]
    close $psock
    catch {pop3::status $psock} msg
    ::subserv::muservStop
    blot $msg $psock
} {POP3 STAT ERROR: can not find channel named "SOCK"}

test pop3-1.1 {status after close} {
    set port  [setupServer $__loginOk]
    set psock [pop3::open localhost ak smash $port]
    pop3::close $psock
    catch {pop3::status $psock} msg
    ::subserv::muservStop
    blot $msg $psock
} {POP3 STAT ERROR: can not find channel named "SOCK"}

test pop3-1.2 {status ok} {
    set port [setupServer $__statusOkQuit]
    set psock      [pop3::open localhost ak smash $port]
    set status     [pop3::status $psock]
    lappend status [peek $psock]
    pop3::close $psock
    ::subserv::muservStop
    set status
} {11 176 {msex 0 retr_mode retr}}

# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
# Handling of 'retrieve'.
# ----------------------------------------------------------------------
# ----------------------------------------------------------------------

test pop3-2.0 {retrieve, no arguments} {
    catch {pop3::retrieve} msg
    set msg
} [tcltest::getErrorMessage "pop3::retrieve" "chan start ?end?" 0]

test pop3-2.1 {retrieve, not enough arguments} {
    catch {pop3::retrieve sock5} msg
    set msg
} [tcltest::getErrorMessage "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::tooManyMessage "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} {
    set port  [setupServer $__retrFail]
    set psock [pop3::open localhost ak smash $port]
    catch {pop3::retrieve $psock foo bar} msg
    pop3::close $psock
    ::subserv::muservStop
    set msg
} {POP3 Retrieval error: Bad start index foo}

test pop3-2.5 {retrieve, invalid end} {
    set port  [setupServer $__retrFail]
    set psock [pop3::open localhost ak smash $port]
    catch {pop3::retrieve $psock 0 bar} msg
    pop3::close $psock
    ::subserv::muservStop
    set msg
} {POP3 Retrieval error: Bad end index bar}

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" {
	set port  [setupServer [retrMessage $listflag $__message $len]]
	set psock [pop3::open -retr-mode $mode localhost ak smash $port]
	set res [pop3::retrieve $psock 1]
	pop3::close $psock
	::subserv::muservStop
	set res
    } [list $__message] ; # {}
}

# 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} {
    set port  [setupServer [retrMessage 0 $__message 98]]
    set psock [pop3::open -retr-mode retr localhost ak smash $port]
    set res   [pop3::retrieve $psock 1]
    pop3::close $psock
    ::subserv::muservStop
    set res
} [list $__message]


test pop3-2.8 {fast retrieval, .-stuff border break, #528928} {
    set port  [setupServer [retrMessage 0 $__message 114]]
    set psock [pop3::open -retr-mode retr localhost ak smash $port]
    set res   [pop3::retrieve $psock 1]
    pop3::close $psock
    ::subserv::muservStop
    set res
} [list $__message]

# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
# Handling of 'top'.
# ----------------------------------------------------------------------
# ----------------------------------------------------------------------

test pop3-3.0 {top, no arguments} {
    catch {pop3::top} msg
    set msg
} [tcltest::getErrorMessage "pop3::top" "chan msg n" 0]

test pop3-3.1 {top, not enough arguments} {
    catch {pop3::top sock5} msg
    set msg
} [tcltest::getErrorMessage "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::tooManyMessage "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} {
    set port  [setupServer $__topFail]
    set psock [pop3::open localhost ak smash $port]
    catch {pop3::top $psock foo bar} msg
    pop3::close $psock
    ::subserv::muservStop
    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} {
    set port [setupServer [topMessage $__message]]
    set psock [pop3::open localhost ak smash $port]
    set res [pop3::top $psock 1 1]
    pop3::close $psock
    ::subserv::muservStop
    set res
} $__message

# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
# Handling of 'delete'
# ----------------------------------------------------------------------
# ----------------------------------------------------------------------


test pop3-5.0 {get and delete all message, nano-client} {
    set res ""
    set port  [setupServer [deleDialog]]

    set psock [pop3::open -retr-mode slow localhost ak smash $port]
    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
    lappend res [::subserv::muservLog]
    ::subserv::muservStop
    set res
} {11 67 67 67 67 67 67 67 67 67 67 67 {STAT STAT LAST {RETR 1} STAT LAST {DELE 1} STAT LAST {RETR 2} STAT LAST {DELE 2} STAT LAST {RETR 3} STAT LAST {DELE 3} STAT LAST {RETR 4} STAT LAST {DELE 4} STAT LAST {RETR 5} STAT LAST {DELE 5} STAT LAST {RETR 6} STAT LAST {DELE 6} STAT LAST {RETR 7} STAT LAST {DELE 7} STAT LAST {RETR 8} STAT LAST {DELE 8} STAT LAST {RETR 9} STAT LAST {DELE 9} STAT LAST {RETR 10} STAT LAST {DELE 10} STAT LAST {RETR 11} STAT 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} {
    set port [setupServer $__lastFailed]
    set psock [pop3::open localhost ak smash $port]
    catch {pop3::last $psock} msg
    pop3::close $psock
    ::subserv::muservStop
    set msg
} {POP3 LAST ERROR:  unknown command 'LAST'}

test pop3-6.1 {uidl} {
    set port [setupServer $__uidlFailed]
    set psock [pop3::open localhost ak smash $port]
    catch {pop3::uidl $psock} msg
    pop3::close $psock
    ::subserv::muservStop
    set msg
} {POP3 UIDL ERROR:  unknown command 'UIDL'}


# ----------------------------------------------------------------------
# ----------------------------------------------------------------------
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/pop3/srv.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

# pop3 server for testing the client.
# Spawn this via pipe. Writes the port
# it is listening on to stdout. Takes
# the directory for its file system parts
# from the command line. Exits if stdin is
# closed.

# tmpdir  | set by caller
# testdir |
# logfile |

set modules [file dirname $testdir]
set popd    [file join $modules pop3d]
##set logfile [file join $tmpdir $logfile]
set log     [open $logfile w]

fconfigure $log -buffering none
proc log {txt} {global log ; puts $log $txt}
proc log__ {l t} {log "$l $t"}

fileevent stdin readable done
fconfigure stdin -blocking 0
proc done {} {
    gets stdin
    if {[eof stdin]} {
	global dboxdir
	log "shutdown through caller"
	catch {file delete -force $dboxdir}
	exit
    }
}


# Read server functionality

source [file join $popd pop3d.tcl]
source [file join $popd pop3d_dbox.tcl]
source [file join $popd pop3d_udb.tcl]

# Prevent log messages for now, or log into server log.

::log::lvCmdForall log__
#::log::lvSuppress info
#::log::lvSuppress notice
#::log::lvSuppress debug
#::log::lvSuppress warning


# Setup basic server

set srv [::pop3d::new]

$srv configure -port    0
$srv configure -auth    [set udb  [::pop3d::udb::new]]
$srv configure -storage [set dbox [::pop3d::dbox::new]]

# Configure the mail storage ...
# Directory, folders and mails .

set dboxdir [file join $tmpdir __dbox__]
if {[file exists $dboxdir]} {
    file delete -force $dboxdir
}
file mkdir $dboxdir
$dbox base $dboxdir
$dbox add         usr0
$dbox add         usr1

foreach m {10 20 30 40 50 60 70 80 90 100} {
    set f [open [file join $dboxdir usr0 $m] w]
    puts $f {
    }
    close $f

    set f [open [file join $dboxdir usr1 $m] w]
    puts $f {
    }
    close $f
}

set    f [open [file join $dboxdir usr0 15] w]
puts  $f {MIME-Version: 1.0
Content-Type: text/plain;
              charset="us-ascii"

Test1
Test2
Test3
Test4
x

.

--
Done}
close $f

# Configure the authentication ...

$udb add ak smash usr0
$udb add jh wooof usr1

# Start server ...

$srv up
set port [$srv cget -port]
puts  stdout $port
flush stdout

log "server up at $port"

vwait forever
log "reached infinity"
catch {file delete -force $dboxdir}
exit
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































Deleted modules/pop3d/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
2003-04-13  Andreas Kupries  <[email protected]>

	* pop3d.test: Updated to new version number.

2003-04-11  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* pop3d.tcl: A bit more logging of internals.

2003-04-02  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* pop3d.man: More semantic markup, less visual one.
	* pop3d_dbox.man:
	* pop3d_udb.man: 

2002-09-03  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* pop3d.test: Modified testsuite courtesy Gerald Lester
	  <[email protected]> for better execution of the
	  subshells under windows.

2002-05-15  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	* 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.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































Deleted modules/pop3d/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
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.

if {![package vsatisfies [package provide Tcl] 8.2]} {return}

package ifneeded pop3d       1.0.1 [list source [file join $dir pop3d.tcl]]
package ifneeded pop3d::udb  1.1   [list source [file join $dir pop3d_udb.tcl]]
package ifneeded pop3d::dbox 1.0.1 [list source [file join $dir pop3d_dbox.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























Deleted modules/pop3d/pop3d.man.

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

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]

[lst_item [const kill]]

Destroys the server immediately, and forcefully closes all currently
open connections. This is the default mode.

[lst_item [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]

[lst_item "[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.

[lst_item "[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].

[lst_item "[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].

[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 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.

[nl]

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]

[keywords pop3 internet network protocol rfc1939]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































Deleted modules/pop3d/pop3d.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
# pop3d.tcl --
#
#	Implementation of a pop3 server for Tcl.
#
# 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.
# 
# RCS: @(#) $Id: pop3d.tcl,v 1.8 2003/04/11 20:11:26 andreas_kupries Exp $

package require md5  ; # tcllib | APOP
package require mime ; # tcllib | storage callback
package require log  ; # tcllib | tracing

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
    # 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 ; set version 1.0.1
    variable server  "tcllib/pop3d-$version"

    variable cmdMap ; array set cmdMap {
	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
    }
    # -- 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 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}::sock     sock

    log::log debug "pop3d $name up"
    if {[string equal $state up]} {return}

    log::log debug "pop3d $name listening, requested port $port"

    set s [socket -server [list ::pop3d::HandleNewConnection $name] $port]
    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
	}
	default {
	    return -code error \
		    "Unknown option \"$anoption\":\
		    Expected \"-state\", \"-port\", \"-auth\", 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}::state    state

    if {$argc == 0} {
	# Return the full configuration.
	return [list \
		-port    $trueport \
		-auth    $authCmd  \
		-storage $storCmd  \
		-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}
	    -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\", 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 "$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 "$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

    ::log::log debug "$name $sock closing connection"

    if {[catch {close $sock} msg]} {
	::log::log error "$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 "$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 "$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 "$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 "$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 "$name $sock > $ok $wtext"
    puts $sock                    "$ok $wtext"
    return
}

##########################
##########################
# Command implementations.

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 "$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 "$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 "$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 "$name $sock $authCmd lookup $cstate(name) : $msg"
	CheckLogin $name $sock "" "" ""
	return
    }

    set pwd     [lindex $info 0]
    set storage [lindex $info 1]

    ::log::log debug "$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::md5 "$cstate(id)$pwd"]

    ::log::log debug "$name $sock digest input <$cstate(id)$pwd>"
    ::log::log debug "$name $sock digest outpt <$ourDigest>"
    ::log::log debug "$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)]
	}
    }

    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 "$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 "$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 "$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 \
		"$name $sock login $cstate(name) $storage $cstate(msg)"
	::log::log notice "$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

    fileevent $sock readable {}

    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 "$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 "$name Transfer $msgid /full"

	#::mime::copymessage $token $sock

	# We do "."-stuffing here. This is not in the scope of the
	# MIME library we use, but a transport dependent thing.

log::log debug "([string trimright [string map [list "\n." "\n.."] [mime::buildmessage $token]] \n])"

	puts $sock [string trimright [string map [list "\n." "\n.."] [mime::buildmessage $token]] \n]
	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.
    }
    fileevent $sock readable [list ::pop3d::HandleCommand $name $sock]
    ::log::log debug "$name $sock transfer complete, listening again"
    # response already sent.
    return
}

##########################
# Module initialization

package provide pop3d $::pop3d::version
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/pop3d/pop3d.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
# -*- 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 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: pop3d.test,v 1.4 2003/04/14 04:59:43 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require pop3d
package require pop3d::udb
package require pop3d::dbox

puts "pop3d [package present pop3d]"
puts "- udb  [package present pop3d::udb]"
puts "- dbox [package present pop3d::dbox]"

proc bgerror {message} {
    global errorCode errorInfo
    puts $errorCode
    puts $errorInfo
    return
}

# Reduce output generated by the server objects
::log::lvSuppress info
::log::lvSuppress notice
::log::lvSuppress debug
::log::lvSuppress warning

# ----------------------------------------------------------------------
# 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 {} -state down}

foreach {n opt val} {
    0 -port    110
    1 -state   down
    2 -auth    {}
    3 -storage {}
} {
    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
} {
    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
    set res [$srv configure]
    $srv destroy
    set res
} {-port 2048 -auth p3udb54 -storage p3dbox128 -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
    set    srv [::pop3d::new]
    $srv configure -port 0
    $srv up
    ::log::log debug "$srv @ [$srv cget -port]"
    return
}

proc delsrv {} {
    global srv
    $srv destroy
}

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

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 openpipe {} {
    global tcl_platform
    
    switch -exact $tcl_platform(platform) {
	windows {
	    return [open "|\"[info nameofexecutable]\" __script" r]
	}
	default {
	    return [open "|[info nameofexecutable] __script" r]
	}
    }
}

proc subshell {script args} {
    global pipe
    removeFile  __script
    makeFile {} __script
    set f [open __script w]

    foreach {k v} $args {
	puts $f [list set $k $v]
    }
    puts  $f $script
    puts  $f exit
    close $f

    set ::result [list]
    set        pipe [openpipe]
    fileevent $pipe readable [list subget $pipe]
    vwait ::stop
    if {[catch {close $pipe} msg]} {
	return "$::stop % $msg"
    }
    return $::stop
}

proc subshellpar {script myscript args} {
    global pipe
    removeFile  __script
    makeFile {} __script
    set f [open __script w]

    foreach {k v} $args {
	puts $f [list set $k $v]
    }
    puts  $f "proc wait {} {gets stdin ; return}"
    puts  $f $script
    puts  $f exit
    close $f
    ## global srv ; file copy __script __script.$srv

    set ::result [list]
    set        pipe [openpipe]
    fileevent $pipe readable [list subget $pipe]
    uplevel 1 $myscript
    vwait ::stop
    if {[catch {close $pipe} msg]} {
	return "$::stop % $msg"
    }
    return $::stop
}

proc subgo   {} {global pipe ; puts  $pipe . ; return}
proc subwait {} {vwait ::result ; return}

proc subget {pipe} {
    if {[eof $pipe]} {
	set ::stop [join $::result \n]
	return
    }
    if {[gets $pipe line] < 0} {return}

    # Strip standard variant information out of all responses.
    regsub -all [info hostname] $line {%%} line
    lappend ::result $line
    return
}

proc asort {kv} {
    set tmp [list]
    foreach {k v} $kv {lappend tmp [list $k $v]}
    set kv [list]
    foreach item [lsort -index 0 $tmp] {
	foreach {k v} $item break
	lappend kv $k $v
    }
    return $kv
}

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 [asort [array get tmp]]
}

makeDirectory __dbox__
proc newfsrv {} {
    global srv udb dbox
    newsrv
    $srv configure \
	    -auth    [set udb  [::pop3d::udb::new]] \
	    -storage [set dbox [::pop3d::dbox::new]]

    $dbox base __dbox__

    $dbox add         usr0
    $udb  add ak smash usr0

    makeFile {} [file join __dbox__ usr0 10]
    makeFile {} [file join __dbox__ usr0 20]
    makeFile {} [file join __dbox__ usr0 30]

    $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
    return
}


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

test pop3-srv-4.0 {connection introspection} {
    newsrv

    subshellpar {
	set c [socket localhost $port]
	after 3000
	gets  $c
	close $c
    } {
	after 1000 {set res [$srv conn state [$srv conn list]]}
    } port [$srv cget -port] ; # {}

    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delsrv
    set res
} {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}


test pop3-srv-5.0 {initial contact, greeting} {
    newsrv

    set res [subshell {
	set c [socket localhost $port]
	puts "greeting: [gets $c]"
	close $c
    } port [$srv cget -port]] ; # {}

    #regsub -all [info hostname]        $res {%%}  res
    regsub "\[0-9\]+_${srv}_\[0-9\]+@" $res {==@} res

    delsrv
    set res
} {greeting: +OK %% tcllib/pop3d-1.0.1 ready <==@%%>}


test pop3-srv-6.0 {unknown command} {
    newsrv

    set res [subshell {
	set c [socket localhost $port]
	gets $c
	puts $c "FOOBAR blub" ; flush $c
	puts [gets $c]
	after 3000
	close $c
    } port [$srv cget -port]] ; # {}

    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 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    1 {deleted {} id <==@%%> logon {} msg 0 name {} remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    2 {}
    3 {deleted {} id <==@%%> logon {} msg 0 name foo remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    4 {deleted {} id <==@%%> logon {} msg 3 name ak remotehost 127.0.0.1 remoteport {} server 1 size 3 state trans storage usr0}
    5 {deleted {} id <==@%%> logon {} msg 0 name ak remotehost 127.0.0.1 remoteport {} server 1 size 0 state auth storage {}}
    6 {deleted 1 id <==@%%> logon {} msg 3 name ak remotehost 127.0.0.1 remoteport {} server 1 size 3 state trans storage usr0}
}
array set log {
    0  {+OK please send PASS command}
    1  {+OK %% tcllib/pop3d-1.0.1 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}
}

# ======================================================================
# ======================================================================
# AUTHORIZATION state - Initial state, after the greeting.
# Allowed commands: USER, APOP, QUIT
# Not permitted:    PASS, STAT, DELE, RETR, TOP, RSET, LIST, NOOP
# 

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
} {
    test pop3-srv-7.0.$n "auth, $cmd" {
	newfsrv
	set res ""
	set trace [subshellpar {
	    set c [socket localhost $port]
	    gets $c line
	    puts $c "$cmd" ; flush $c ; gets $c line
	    after 3000
	    close $c
	    puts $line
	} {
	    after 2000 {
		catch {
		    set res [$srv conn state [$srv conn list]]
		}
	    }
	} port [$srv cget -port] cmd $cmd] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

# ----------------------------------------------------------------------
# Mutual exclusion of the different authentication methods,
# block multiple authentication

test pop3-srv-7.1 "auth, USER/APOP" {
    newfsrv
    set res ""
    set trace [subshellpar {
	set c [socket localhost $port]
	gets $c
	puts $c "USER foo" ; flush $c
	gets $c
	puts $c "APOP foo barr" ; flush $c
	puts [gets $c]
	after 3000
	close $c
    } {
	after 2000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port]] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list $log(4) $cstate(0)] ; # {}

test pop3-srv-7.2 "auth, APOP/USER" {
    newfsrv
    set res ""
    set trace [subshellpar {
	package require md5
	set c [socket localhost $port]
	regexp {(<.*>)} [gets $c] -> id
	set hash [md5::md5 ${id}smash]
	puts $c "APOP ak $hash" ; flush $c
	set line [gets $c]
	puts $c "USER foo" ; flush $c
	puts "$line [gets $c]"
	after 5000
	close $c
    } {
	after 3000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port]] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list $log(5) $cstate(4)] ; # {}

# ----------------------------------------------------------------------
# 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
	set res ""
	set trace [subshellpar {
	    set c [socket localhost $port]
	    gets $c line
	    puts $c "USER $user" ; flush $c ; gets $c line
	    puts $c "PASS $pass" ; flush $c ; gets $c line
	    after 3000
	    close $c
	    puts $line
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] user $user pass $pass] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}

    test pop3-srv-7.4.$n {APOP} {
	newfsrv
	set res ""
	set trace [subshellpar {
	    package require md5
	    set c [socket localhost $port]
	    gets $c line ; regexp {(<.*>)} $line -> id
	    set hash [md5::md5 ${id}$pass]
	    puts $c "APOP $user $hash" ; flush $c ; gets $c line
	    after 3000
	    close $c
	    puts $line
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] user $user pass $pass] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}


# ======================================================================
# ======================================================================
# TRANSACTION state - after successful authentication.
# Allowed commands: QUIT, STAT, DELE, RETR, TOP, RSET, LIST, NOOP
# 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
} {
    test pop3-srv-7.5.$n "trans, $cmd" {
	newfsrv
	set res ""
	set trace [subshellpar {
	    set   c [socket localhost $port]
	    gets $c
	    puts $c "USER ak"    ; flush $c ; gets $c
	    puts $c "PASS smash" ; flush $c ; gets $c
	    puts $c "$cmd"       ; flush $c
	    puts [gets $c]
	    after 3000
	    close $c
	} {
	    after 2000 {
		catch {
		    set res [$srv conn state [$srv conn list]]
		}
	    }
	} port [$srv cget -port] cmd $cmd] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

# ======================================================================
# ======================================================================
# 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" {
	newfsrv
	set res ""
	set trace [subshellpar {
	    set c [socket localhost $port]
	    gets $c
	    puts $c "USER ak"    ; flush $c ; gets $c
	    puts $c "PASS smash" ; flush $c ; gets $c
	    puts $c "DELE $mid"  ; flush $c
	    puts [gets $c]
	    after 3000
	    close $c
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] mid $id] ; # {}
	
	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

test pop3-srv-7.6.4 "DELE, out of range" {
    newfsrv
    set res ""
    set trace [subshellpar {
	set c [socket localhost $port]
	gets $c
	puts $c "USER ak"    ; flush $c ; gets $c
	puts $c "PASS smash" ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c
	puts [gets $c]
	after 3000
	close $c
    } {
	after 2000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port] mid $id] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list $log(13) $cstate(6)] ; # {}


test pop3-srv-7.7 "DELE, abort" {
    newfsrv
    set res ""
    set trace [subshellpar {
	set res [list]

	lappend res [file exists [file join __dbox__ usr0 10]]

	set c [socket localhost $port]
	gets $c
	puts $c "USER ak"    ; flush $c ; gets $c
	puts $c "PASS smash" ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c ; gets $c line
	lappend res [file exists [file join __dbox__ usr0 10]]
	after 3000
	close $c
	lappend res [file exists [file join __dbox__ usr0 10]]
	lappend res $line
	puts $res
    } {
	after 2000 {
	    set res [$srv conn state [$srv conn list]]
	}
    } port [$srv cget -port]] ; # {}
    
    # Postprocess state to remove variable data from comparison
    set res [ppcstate $res]
    delfsrv
    list $trace $res
} [list [list 1 1 1 $log(9)] $cstate(6)] ; # {}

test pop3-srv-7.8 "DELE, complete" {
    newfsrv
    set trace [subshell {
	set res [list]

	lappend res [file exists [file join __dbox__ usr0 10]]

	set c [socket localhost $port]
	gets $c
	puts $c "USER ak"    ; flush $c ; gets $c
	puts $c "PASS smash" ; flush $c ; gets $c
	puts $c "DELE 1"     ; flush $c ; gets $c line
	lappend res [file exists [file join __dbox__ usr0 10]]
	puts $c "QUIT"       ; flush $c ; gets $c
	after 3000
	close $c
	lappend res [file exists [file join __dbox__ usr0 10]]
	lappend res $line
	puts $res
    } port [$srv cget -port]] ; # {}
    
    delfsrv
    set trace
} [list 1 1 0 $log(9)] ; # {}

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
	set res ""
	set trace [subshellpar {
	    set   c [socket localhost $port]
	    gets $c
	    puts $c "USER ak"    ; flush $c ; gets $c
	    puts $c "PASS smash" ; flush $c ; gets $c
	    puts $c "DELE 1"     ; flush $c ; gets $c
	    puts $c "$cmd"       ; flush $c
	    puts [gets $c]
	    after 3000
	    close $c
	} {
	    after 2000 {
		set res [$srv conn state [$srv conn list]]
	    }
	} port [$srv cget -port] cmd $cmd] ; # {}

	# Postprocess state to remove variable data from comparison
	set res [ppcstate $res]
	delfsrv
	list $trace $res
    } [list $log($lidx) $cstate($cidx)] ; # {}
}

# ======================================================================
# ======================================================================
# 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
	set trace [subshell {
	    set res [list]
	    set c [socket localhost $port]
	    gets $c
	    puts $c "USER $user" ; flush $c ; gets $c
	    puts $c "PASS $pass" ; flush $c ; gets $c
	    puts $c "LIST $id"   ; flush $c ; gets $c line
	    lappend res $line
	    if {$id == {}} {
		while {![eof $c]} {
		    gets $c line
		    if {[string equal $line .]} {break}
		    lappend res $line
		}
	    }
	    close $c
	    puts [join $res]
	} port [$srv cget -port] id $id user $user pass $pass] ; # {}
	
	delfsrv
	set trace
    } $log($lidx) ; # {}
}

# ----------------------------------------------------------------------
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/pop3d/pop3d_dbox.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
[comment {-*- tcl -*-}]
[manpage_begin pop3d::dbox n 1.1]
[copyright {2002 Andreas Kupries <[email protected]>}]
[moddesc   {Tcl POP3 Server Package}]
[titledesc {Simple mailbox database for pop3d}]
[require Tcl 8.2]
[require pop3d::dbox [opt 1.1]]
[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
RFC822 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]

[keywords pop3 internet network protocol rfc1939]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































Deleted modules/pop3d/pop3d_dbox.tcl.

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

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"	\
	    ]

    variable version ; set version 1.1
}


# ::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 $::pop3d::dbox::version
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/pop3d/pop3d_dbox.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require pop3d::dbox
puts "pop3d::dbox [package present pop3d::dbox]"

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

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}

makeFile {} __bar__
test pop3-dbox-2.2 {initialization} {
    set dbox [::pop3d::dbox::new]
    catch {$dbox base __bar__} res
    $dbox destroy
    set res
} {base: "__bar__" not a directory}

makeDirectory __dbox__
test pop3-dbox-2.3 {initialization} {
    set dbox [::pop3d::dbox::new]
    set     res [list [$dbox base __dbox__]]
    lappend res [$dbox list]
    $dbox destroy
    set res
} {{} {}}

makeDirectory [file join __dbox__ known]

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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox add known} res
    $dbox destroy
    set res
} {cannot add "known", mailbox already in existence}

test pop3-dbox-3.2 {adding mailboxes} {
    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
    set res
} {0 1 {known 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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox remove usr1} res
    $dbox destroy
    set res
} {cannot remove "usr1", mailbox does not exist}

test pop3-dbox-4.2 {removing mailboxes} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    set res [file exists [file join  __dbox__ usr0]]
    $dbox remove usr0
    lappend res [file exists [file join  __dbox__ usr0]]
    $dbox destroy
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox move usr0 usr1} res
    $dbox destroy
    set res
} {cannot move "usr0", mailbox does not exist}

test pop3-dbox-5.2 {renaming mailboxes} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    $dbox add usr0
    catch {$dbox move usr0 known} res
    $dbox remove usr0
    $dbox destroy
    set res
} {cannot move "usr0", destination "known" already exists}

test pop3-dbox-5.3 {renaming mailboxes} {
    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
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    set res [$dbox exists foo]
    $dbox destroy
    set res
} 0

test pop3-dbox-6.2 {existence of mailboxes} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    set res [$dbox exists known]
    $dbox destroy
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    set res [$dbox locked known]
    $dbox destroy
    set res
} 0

test pop3-dbox-7.4 {locking} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    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
    set res
} {0 1 1 0}

test pop3-dbox-7.5 {locking} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    set     res [$dbox lock known]
    lappend res [$dbox lock known]
    $dbox unlock known
    lappend res [$dbox locked known]
    $dbox destroy
    set res
} {1 0 0}

test pop3-dbox-7.6 {locking} {
    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
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox stat known} res
    $dbox destroy
    set res
} {mailbox "known" is not locked}

test pop3-dbox-8.2 {stat} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    $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]
    $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
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox size known 0} res
    $dbox destroy
    set res
} {id "0" out of range}

test pop3-dbox-9.2 {size} {
    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
    set res
} {id "1" out of range}

test pop3-dbox-9.3 {size} {
    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
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox get known 0} res
    $dbox destroy
    set res
} {id "0" out of range}

test pop3-dbox-10.2 {get} {
    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
    set res
} {id "1" out of range}

test pop3-dbox-10.3 {get} {
    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
    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} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox dele known {}} res
    $dbox destroy
    set res
} {nothing to delete}

test pop3-dbox-11.2 {dele} {
    set dbox [::pop3d::dbox::new]
    $dbox base __dbox__
    catch {$dbox dele known 0} res
    $dbox destroy
    set res
} {id "0" out of range}

test pop3-dbox-11.3 {dele} {
    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
    set res
} {id "1" out of range}

test pop3-dbox-11.4 {dele} {
    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
    set res
} {1 1 1 3 0 0 0 3 {id "4" out of range}}


# ----------------------------------------------------------------------
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/pop3d/pop3d_udb.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
[comment {-*- tcl -*-}]
[manpage_begin pop3d::udb n 1.0.1]
[copyright {2002 Andreas Kupries <[email protected]>}]
[moddesc   {Tcl POP3 Server Package}]
[titledesc {Simple user database for pop3d}]
[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]

[keywords pop3 internet network protocol rfc1939]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































Deleted modules/pop3d/pop3d_udb.tcl.

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

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"		\
	    ]

    variable version ; set version 1.1
}


# ::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 $::pop3d::udb::version
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































Deleted modules/pop3d/pop3d_udb.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require pop3d::udb
puts "pop3d::udb [package present 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-3.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-3.1 {renaming entries} {
    set udb [::pop3d::udb::new]
    catch {$udb rename {} {}} res
    $udb destroy
    set res
} {user specification missing}

test pop3-udb-3.2 {renaming entries} {
    set udb [::pop3d::udb::new]
    catch {$udb rename bar {}} res
    $udb destroy
    set res
} {user specification missing}

test pop3-udb-3.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-3.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-4.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-4.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-5.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-5.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

makeFile {} __UDB__
makeFile {} __UDB__.old

test pop3-udb-6.0 {save database} {
    set udb [::pop3d::udb::new]
    $udb add bar blurb ****
    $udb add booze Xblurb ***X
    $udb save __UDB__
    $udb destroy
    viewFile __UDB__
} {# -*- tcl -*-
# ----------- user authentication database -

	add bar blurb ****
	add booze Xblurb ***X
}

test pop3-udb-6.1 {read database} {
    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
    set res
} {{bar booze} {blurb ****} {Xblurb ***X}}



# ----------------------------------------------------------------------
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































Deleted modules/pop3d/rfc1939.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291




Network Working Group                                           J. Myers
Request for Comments: 1939                               Carnegie Mellon
STD: 53                                                          M. Rose
Obsoletes: 1725                             Dover Beach Consulting, Inc.
Category: Standards Track                                       May 1996


                    Post Office Protocol - Version 3

Status of this Memo

   This document specifies an Internet standards track protocol for the
   Internet community, and requests discussion and suggestions for
   improvements.  Please refer to the current edition of the "Internet
   Official Protocol Standards" (STD 1) for the standardization state
   and status of this protocol.  Distribution of this memo is unlimited.

Table of Contents

   1. Introduction ................................................    2
   2. A Short Digression ..........................................    2
   3. Basic Operation .............................................    3
   4. The AUTHORIZATION State .....................................    4
      QUIT Command ................................................    5
   5. The TRANSACTION State .......................................    5
      STAT Command ................................................    6
      LIST Command ................................................    6
      RETR Command ................................................    8
      DELE Command ................................................    8
      NOOP Command ................................................    9
      RSET Command ................................................    9
   6. The UPDATE State ............................................   10
      QUIT Command ................................................   10
   7. Optional POP3 Commands ......................................   11
      TOP Command .................................................   11
      UIDL Command ................................................   12
      USER Command ................................................   13
      PASS Command ................................................   14
      APOP Command ................................................   15
   8. Scaling and Operational Considerations ......................   16
   9. POP3 Command Summary ........................................   18
   10. Example POP3 Session .......................................   19
   11. Message Format .............................................   19
   12. References .................................................   20
   13. Security Considerations ....................................   20
   14. Acknowledgements ...........................................   20
   15. Authors' Addresses .........................................   21
   Appendix A. Differences from RFC 1725 ..........................   22



Myers & Rose                Standards Track                     [Page 1]

RFC 1939                          POP3                          May 1996


   Appendix B. Command Index ......................................   23

1. Introduction

   On certain types of smaller nodes in the Internet it is often
   impractical to maintain a message transport system (MTS).  For
   example, a workstation may not have sufficient resources (cycles,
   disk space) in order to permit a SMTP server [RFC821] and associated
   local mail delivery system to be kept resident and continuously
   running.  Similarly, it may be expensive (or impossible) to keep a
   personal computer interconnected to an IP-style network for long
   amounts of time (the node is lacking the resource known as
   "connectivity").

   Despite this, it is often very useful to be able to manage mail on
   these smaller nodes, and they often support a user agent (UA) to aid
   the tasks of mail handling.  To solve this problem, a node which can
   support an MTS entity offers a maildrop service to these less endowed
   nodes.  The Post Office Protocol - Version 3 (POP3) is intended to
   permit a workstation to dynamically access a maildrop on a server
   host in a useful fashion.  Usually, this means that the POP3 protocol
   is used to allow a workstation to retrieve mail that the server is
   holding for it.

   POP3 is not intended to provide extensive manipulation operations of
   mail on the server; normally, mail is downloaded and then deleted.  A
   more advanced (and complex) protocol, IMAP4, is discussed in
   [RFC1730].

   For the remainder of this memo, the term "client host" refers to a
   host making use of the POP3 service, while the term "server host"
   refers to a host which offers the POP3 service.

2. A Short Digression

   This memo does not specify how a client host enters mail into the
   transport system, although a method consistent with the philosophy of
   this memo is presented here:

      When the user agent on a client host wishes to enter a message
      into the transport system, it establishes an SMTP connection to
      its relay host and sends all mail to it.  This relay host could
      be, but need not be, the POP3 server host for the client host.  Of
      course, the relay host must accept mail for delivery to arbitrary
      recipient addresses, that functionality is not required of all
      SMTP servers.





Myers & Rose                Standards Track                     [Page 2]

RFC 1939                          POP3                          May 1996


3. Basic Operation

   Initially, the server host starts the POP3 service by listening on
   TCP port 110.  When a client host wishes to make use of the service,
   it establishes a TCP connection with the server host.  When the
   connection is established, the POP3 server sends a greeting.  The
   client and POP3 server then exchange commands and responses
   (respectively) until the connection is closed or aborted.

   Commands in the POP3 consist of a case-insensitive keyword, possibly
   followed by one or more arguments.  All commands are terminated by a
   CRLF pair.  Keywords and arguments consist of printable ASCII
   characters.  Keywords and arguments are each separated by a single
   SPACE character.  Keywords are three or four characters long. Each
   argument may be up to 40 characters long.

   Responses in the POP3 consist of a status indicator and a keyword
   possibly followed by additional information.  All responses are
   terminated by a CRLF pair.  Responses may be up to 512 characters
   long, including the terminating CRLF.  There are currently two status
   indicators: positive ("+OK") and negative ("-ERR").  Servers MUST
   send the "+OK" and "-ERR" in upper case.

   Responses to certain commands are multi-line.  In these cases, which
   are clearly indicated below, after sending the first line of the
   response and a CRLF, any additional lines are sent, each terminated
   by a CRLF pair.  When all lines of the response have been sent, a
   final line is sent, consisting of a termination octet (decimal code
   046, ".") and a CRLF pair.  If any line of the multi-line response
   begins with the termination octet, the line is "byte-stuffed" by
   pre-pending the termination octet to that line of the response.
   Hence a multi-line response is terminated with the five octets
   "CRLF.CRLF".  When examining a multi-line response, the client checks
   to see if the line begins with the termination octet.  If so and if
   octets other than CRLF follow, the first octet of the line (the
   termination octet) is stripped away.  If so and if CRLF immediately
   follows the termination character, then the response from the POP
   server is ended and the line containing ".CRLF" is not considered
   part of the multi-line response.

   A POP3 session progresses through a number of states during its
   lifetime.  Once the TCP connection has been opened and the POP3
   server has sent the greeting, the session enters the AUTHORIZATION
   state.  In this state, the client must identify itself to the POP3
   server.  Once the client has successfully done this, the server
   acquires resources associated with the client's maildrop, and the
   session enters the TRANSACTION state.  In this state, the client
   requests actions on the part of the POP3 server.  When the client has



Myers & Rose                Standards Track                     [Page 3]

RFC 1939                          POP3                          May 1996


   issued the QUIT command, the session enters the UPDATE state.  In
   this state, the POP3 server releases any resources acquired during
   the TRANSACTION state and says goodbye.  The TCP connection is then
   closed.

   A server MUST respond to an unrecognized, unimplemented, or
   syntactically invalid command by responding with a negative status
   indicator.  A server MUST respond to a command issued when the
   session is in an incorrect state by responding with a negative status
   indicator.  There is no general method for a client to distinguish
   between a server which does not implement an optional command and a
   server which is unwilling or unable to process the command.

   A POP3 server MAY have an inactivity autologout timer.  Such a timer
   MUST be of at least 10 minutes' duration.  The receipt of any command
   from the client during that interval should suffice to reset the
   autologout timer.  When the timer expires, the session does NOT enter
   the UPDATE state--the server should close the TCP connection without
   removing any messages or sending any response to the client.

4. The AUTHORIZATION State

   Once the TCP connection has been opened by a POP3 client, the POP3
   server issues a one line greeting.  This can be any positive
   response.  An example might be:

      S:  +OK POP3 server ready

   The POP3 session is now in the AUTHORIZATION state.  The client must
   now identify and authenticate itself to the POP3 server.  Two
   possible mechanisms for doing this are described in this document,
   the USER and PASS command combination and the APOP command.  Both
   mechanisms are described later in this document.  Additional
   authentication mechanisms are described in [RFC1734].  While there is
   no single authentication mechanism that is required of all POP3
   servers, a POP3 server must of course support at least one
   authentication mechanism.

   Once the POP3 server has determined through the use of any
   authentication command that the client should be given access to the
   appropriate maildrop, the POP3 server then acquires an exclusive-
   access lock on the maildrop, as necessary to prevent messages from
   being modified or removed before the session enters the UPDATE state.
   If the lock is successfully acquired, the POP3 server responds with a
   positive status indicator.  The POP3 session now enters the
   TRANSACTION state, with no messages marked as deleted.  If the
   maildrop cannot be opened for some reason (for example, a lock can
   not be acquired, the client is denied access to the appropriate



Myers & Rose                Standards Track                     [Page 4]

RFC 1939                          POP3                          May 1996


   maildrop, or the maildrop cannot be parsed), the POP3 server responds
   with a negative status indicator.  (If a lock was acquired but the
   POP3 server intends to respond with a negative status indicator, the
   POP3 server must release the lock prior to rejecting the command.)
   After returning a negative status indicator, the server may close the
   connection.  If the server does not close the connection, the client
   may either issue a new authentication command and start again, or the
   client may issue the QUIT command.

   After the POP3 server has opened the maildrop, it assigns a message-
   number to each message, and notes the size of each message in octets.
   The first message in the maildrop is assigned a message-number of
   "1", the second is assigned "2", and so on, so that the nth message
   in a maildrop is assigned a message-number of "n".  In POP3 commands
   and responses, all message-numbers and message sizes are expressed in
   base-10 (i.e., decimal).

   Here is the summary for the QUIT command when used in the
   AUTHORIZATION state:

      QUIT

         Arguments: none

         Restrictions: none

         Possible Responses:
             +OK

         Examples:
             C: QUIT
             S: +OK dewey POP3 server signing off

5. The TRANSACTION State

   Once the client has successfully identified itself to the POP3 server
   and the POP3 server has locked and opened the appropriate maildrop,
   the POP3 session is now in the TRANSACTION state.  The client may now
   issue any of the following POP3 commands repeatedly.  After each
   command, the POP3 server issues a response.  Eventually, the client
   issues the QUIT command and the POP3 session enters the UPDATE state.










Myers & Rose                Standards Track                     [Page 5]

RFC 1939                          POP3                          May 1996


   Here are the POP3 commands valid in the TRANSACTION state:

      STAT

         Arguments: none

         Restrictions:
             may only be given in the TRANSACTION state

         Discussion:
             The POP3 server issues a positive response with a line
             containing information for the maildrop.  This line is
             called a "drop listing" for that maildrop.

             In order to simplify parsing, all POP3 servers are
             required to use a certain format for drop listings.  The
             positive response consists of "+OK" followed by a single
             space, the number of messages in the maildrop, a single
             space, and the size of the maildrop in octets.  This memo
             makes no requirement on what follows the maildrop size.
             Minimal implementations should just end that line of the
             response with a CRLF pair.  More advanced implementations
             may include other information.

                NOTE: This memo STRONGLY discourages implementations
                from supplying additional information in the drop
                listing.  Other, optional, facilities are discussed
                later on which permit the client to parse the messages
                in the maildrop.

             Note that messages marked as deleted are not counted in
             either total.

         Possible Responses:
             +OK nn mm

         Examples:
             C: STAT
             S: +OK 2 320


      LIST [msg]

         Arguments:
             a message-number (optional), which, if present, may NOT
             refer to a message marked as deleted





Myers & Rose                Standards Track                     [Page 6]

RFC 1939                          POP3                          May 1996


         Restrictions:
             may only be given in the TRANSACTION state

         Discussion:
             If an argument was given and the POP3 server issues a
             positive response with a line containing information for
             that message.  This line is called a "scan listing" for
             that message.

             If no argument was given and the POP3 server issues a
             positive response, then the response given is multi-line.
             After the initial +OK, for each message in the maildrop,
             the POP3 server responds with a line containing
             information for that message.  This line is also called a
             "scan listing" for that message.  If there are no
             messages in the maildrop, then the POP3 server responds
             with no scan listings--it issues a positive response
             followed by a line containing a termination octet and a
             CRLF pair.

             In order to simplify parsing, all POP3 servers are
             required to use a certain format for scan listings.  A
             scan listing consists of the message-number of the
             message, followed by a single space and the exact size of
             the message in octets.  Methods for calculating the exact
             size of the message are described in the "Message Format"
             section below.  This memo makes no requirement on what
             follows the message size in the scan listing.  Minimal
             implementations should just end that line of the response
             with a CRLF pair.  More advanced implementations may
             include other information, as parsed from the message.

                NOTE: This memo STRONGLY discourages implementations
                from supplying additional information in the scan
                listing.  Other, optional, facilities are discussed
                later on which permit the client to parse the messages
                in the maildrop.

             Note that messages marked as deleted are not listed.

         Possible Responses:
             +OK scan listing follows
             -ERR no such message

         Examples:
             C: LIST
             S: +OK 2 messages (320 octets)
             S: 1 120



Myers & Rose                Standards Track                     [Page 7]

RFC 1939                          POP3                          May 1996


             S: 2 200
             S: .
               ...
             C: LIST 2
             S: +OK 2 200
               ...
             C: LIST 3
             S: -ERR no such message, only 2 messages in maildrop


      RETR msg

         Arguments:
             a message-number (required) which may NOT refer to a
             message marked as deleted

         Restrictions:
             may only be given in the TRANSACTION state

         Discussion:
             If the POP3 server issues a positive response, then the
             response given is multi-line.  After the initial +OK, the
             POP3 server sends the message corresponding to the given
             message-number, being careful to byte-stuff the termination
             character (as with all multi-line responses).

         Possible Responses:
             +OK message follows
             -ERR no such message

         Examples:
             C: RETR 1
             S: +OK 120 octets
             S: <the POP3 server sends the entire message here>
             S: .


      DELE msg

         Arguments:
             a message-number (required) which may NOT refer to a
             message marked as deleted

         Restrictions:
             may only be given in the TRANSACTION state






Myers & Rose                Standards Track                     [Page 8]

RFC 1939                          POP3                          May 1996


         Discussion:
             The POP3 server marks the message as deleted.  Any future
             reference to the message-number associated with the message
             in a POP3 command generates an error.  The POP3 server does
             not actually delete the message until the POP3 session
             enters the UPDATE state.

         Possible Responses:
             +OK message deleted
             -ERR no such message

         Examples:
             C: DELE 1
             S: +OK message 1 deleted
                ...
             C: DELE 2
             S: -ERR message 2 already deleted


      NOOP

         Arguments: none

         Restrictions:
             may only be given in the TRANSACTION state

         Discussion:
             The POP3 server does nothing, it merely replies with a
             positive response.

         Possible Responses:
             +OK

         Examples:
             C: NOOP
             S: +OK


      RSET

         Arguments: none

         Restrictions:
             may only be given in the TRANSACTION state

         Discussion:
             If any messages have been marked as deleted by the POP3
             server, they are unmarked.  The POP3 server then replies



Myers & Rose                Standards Track                     [Page 9]

RFC 1939                          POP3                          May 1996


             with a positive response.

         Possible Responses:
             +OK

         Examples:
             C: RSET
             S: +OK maildrop has 2 messages (320 octets)

6. The UPDATE State

   When the client issues the QUIT command from the TRANSACTION state,
   the POP3 session enters the UPDATE state.  (Note that if the client
   issues the QUIT command from the AUTHORIZATION state, the POP3
   session terminates but does NOT enter the UPDATE state.)

   If a session terminates for some reason other than a client-issued
   QUIT command, the POP3 session does NOT enter the UPDATE state and
   MUST not remove any messages from the maildrop.

      QUIT

         Arguments: none

         Restrictions: none

         Discussion:
             The POP3 server removes all messages marked as deleted
             from the maildrop and replies as to the status of this
             operation.  If there is an error, such as a resource
             shortage, encountered while removing messages, the
             maildrop may result in having some or none of the messages
             marked as deleted be removed.  In no case may the server
             remove any messages not marked as deleted.

             Whether the removal was successful or not, the server
             then releases any exclusive-access lock on the maildrop
             and closes the TCP connection.

         Possible Responses:
             +OK
             -ERR some deleted messages not removed

         Examples:
             C: QUIT
             S: +OK dewey POP3 server signing off (maildrop empty)
                ...
             C: QUIT



Myers & Rose                Standards Track                    [Page 10]

RFC 1939                          POP3                          May 1996


             S: +OK dewey POP3 server signing off (2 messages left)
                ...

7. Optional POP3 Commands

   The POP3 commands discussed above must be supported by all minimal
   implementations of POP3 servers.

   The optional POP3 commands described below permit a POP3 client
   greater freedom in message handling, while preserving a simple POP3
   server implementation.

      NOTE: This memo STRONGLY encourages implementations to support
      these commands in lieu of developing augmented drop and scan
      listings.  In short, the philosophy of this memo is to put
      intelligence in the part of the POP3 client and not the POP3
      server.

      TOP msg n

         Arguments:
             a message-number (required) which may NOT refer to to a
             message marked as deleted, and a non-negative number
             of lines (required)

         Restrictions:
             may only be given in the TRANSACTION state

         Discussion:
             If the POP3 server issues a positive response, then the
             response given is multi-line.  After the initial +OK, the
             POP3 server sends the headers of the message, the blank
             line separating the headers from the body, and then the
             number of lines of the indicated message's body, being
             careful to byte-stuff the termination character (as with
             all multi-line responses).

             Note that if the number of lines requested by the POP3
             client is greater than than the number of lines in the
             body, then the POP3 server sends the entire message.

         Possible Responses:
             +OK top of message follows
             -ERR no such message

         Examples:
             C: TOP 1 10
             S: +OK



Myers & Rose                Standards Track                    [Page 11]

RFC 1939                          POP3                          May 1996


             S: <the POP3 server sends the headers of the
                message, a blank line, and the first 10 lines
                of the body of the message>
             S: .
                ...
             C: TOP 100 3
             S: -ERR no such message


      UIDL [msg]

      Arguments:
          a message-number (optional), which, if present, may NOT
          refer to a message marked as deleted

      Restrictions:
          may only be given in the TRANSACTION state.

      Discussion:
          If an argument was given and the POP3 server issues a positive
          response with a line containing information for that message.
          This line is called a "unique-id listing" for that message.

          If no argument was given and the POP3 server issues a positive
          response, then the response given is multi-line.  After the
          initial +OK, for each message in the maildrop, the POP3 server
          responds with a line containing information for that message.
          This line is called a "unique-id listing" for that message.

          In order to simplify parsing, all POP3 servers are required to
          use a certain format for unique-id listings.  A unique-id
          listing consists of the message-number of the message,
          followed by a single space and the unique-id of the message.
          No information follows the unique-id in the unique-id listing.

          The unique-id of a message is an arbitrary server-determined
          string, consisting of one to 70 characters in the range 0x21
          to 0x7E, which uniquely identifies a message within a
          maildrop and which persists across sessions.  This
          persistence is required even if a session ends without
          entering the UPDATE state.  The server should never reuse an
          unique-id in a given maildrop, for as long as the entity
          using the unique-id exists.

          Note that messages marked as deleted are not listed.

          While it is generally preferable for server implementations
          to store arbitrarily assigned unique-ids in the maildrop,



Myers & Rose                Standards Track                    [Page 12]

RFC 1939                          POP3                          May 1996


          this specification is intended to permit unique-ids to be
          calculated as a hash of the message.  Clients should be able
          to handle a situation where two identical copies of a
          message in a maildrop have the same unique-id.

      Possible Responses:
          +OK unique-id listing follows
          -ERR no such message

      Examples:
          C: UIDL
          S: +OK
          S: 1 whqtswO00WBw418f9t5JxYwZ
          S: 2 QhdPYR:00WBw1Ph7x7
          S: .
             ...
          C: UIDL 2
          S: +OK 2 QhdPYR:00WBw1Ph7x7
             ...
          C: UIDL 3
          S: -ERR no such message, only 2 messages in maildrop


      USER name

         Arguments:
             a string identifying a mailbox (required), which is of
             significance ONLY to the server

         Restrictions:
             may only be given in the AUTHORIZATION state after the POP3
             greeting or after an unsuccessful USER or PASS command

         Discussion:
             To authenticate using the USER and PASS command
             combination, the client must first issue the USER
             command.  If the POP3 server responds with a positive
             status indicator ("+OK"), then the client may issue
             either the PASS command to complete the authentication,
             or the QUIT command to terminate the POP3 session.  If
             the POP3 server responds with a negative status indicator
             ("-ERR") to the USER command, then the client may either
             issue a new authentication command or may issue the QUIT
             command.

             The server may return a positive response even though no
             such mailbox exists.  The server may return a negative
             response if mailbox exists, but does not permit plaintext



Myers & Rose                Standards Track                    [Page 13]

RFC 1939                          POP3                          May 1996


             password authentication.

         Possible Responses:
             +OK name is a valid mailbox
             -ERR never heard of mailbox name

         Examples:
             C: USER frated
             S: -ERR sorry, no mailbox for frated here
                ...
             C: USER mrose
             S: +OK mrose is a real hoopy frood


      PASS string

         Arguments:
             a server/mailbox-specific password (required)

         Restrictions:
             may only be given in the AUTHORIZATION state immediately
             after a successful USER command

         Discussion:
             When the client issues the PASS command, the POP3 server
             uses the argument pair from the USER and PASS commands to
             determine if the client should be given access to the
             appropriate maildrop.

             Since the PASS command has exactly one argument, a POP3
             server may treat spaces in the argument as part of the
             password, instead of as argument separators.

         Possible Responses:
             +OK maildrop locked and ready
             -ERR invalid password
             -ERR unable to lock maildrop

         Examples:
             C: USER mrose
             S: +OK mrose is a real hoopy frood
             C: PASS secret
             S: -ERR maildrop already locked
               ...
             C: USER mrose
             S: +OK mrose is a real hoopy frood
             C: PASS secret
             S: +OK mrose's maildrop has 2 messages (320 octets)



Myers & Rose                Standards Track                    [Page 14]

RFC 1939                          POP3                          May 1996


      APOP name digest

         Arguments:
             a string identifying a mailbox and a MD5 digest string
             (both required)

         Restrictions:
             may only be given in the AUTHORIZATION state after the POP3
             greeting or after an unsuccessful USER or PASS command

         Discussion:
             Normally, each POP3 session starts with a USER/PASS
             exchange.  This results in a server/user-id specific
             password being sent in the clear on the network.  For
             intermittent use of POP3, this may not introduce a sizable
             risk.  However, many POP3 client implementations connect to
             the POP3 server on a regular basis -- to check for new
             mail.  Further the interval of session initiation may be on
             the order of five minutes.  Hence, the risk of password
             capture is greatly enhanced.

             An alternate method of authentication is required which
             provides for both origin authentication and replay
             protection, but which does not involve sending a password
             in the clear over the network.  The APOP command provides
             this functionality.

             A POP3 server which implements the APOP command will
             include a timestamp in its banner greeting.  The syntax of
             the timestamp corresponds to the `msg-id' in [RFC822], and
             MUST be different each time the POP3 server issues a banner
             greeting.  For example, on a UNIX implementation in which a
             separate UNIX process is used for each instance of a POP3
             server, the syntax of the timestamp might be:

                <process-ID.clock@hostname>

             where `process-ID' is the decimal value of the process's
             PID, clock is the decimal value of the system clock, and
             hostname is the fully-qualified domain-name corresponding
             to the host where the POP3 server is running.

             The POP3 client makes note of this timestamp, and then
             issues the APOP command.  The `name' parameter has
             identical semantics to the `name' parameter of the USER
             command. The `digest' parameter is calculated by applying
             the MD5 algorithm [RFC1321] to a string consisting of the
             timestamp (including angle-brackets) followed by a shared



Myers & Rose                Standards Track                    [Page 15]

RFC 1939                          POP3                          May 1996


             secret.  This shared secret is a string known only to the
             POP3 client and server.  Great care should be taken to
             prevent unauthorized disclosure of the secret, as knowledge
             of the secret will allow any entity to successfully
             masquerade as the named user.  The `digest' parameter
             itself is a 16-octet value which is sent in hexadecimal
             format, using lower-case ASCII characters.

             When the POP3 server receives the APOP command, it verifies
             the digest provided.  If the digest is correct, the POP3
             server issues a positive response, and the POP3 session
             enters the TRANSACTION state.  Otherwise, a negative
             response is issued and the POP3 session remains in the
             AUTHORIZATION state.

             Note that as the length of the shared secret increases, so
             does the difficulty of deriving it.  As such, shared
             secrets should be long strings (considerably longer than
             the 8-character example shown below).

         Possible Responses:
             +OK maildrop locked and ready
             -ERR permission denied

         Examples:
             S: +OK POP3 server ready <[email protected]>
             C: APOP mrose c4c9334bac560ecc979e58001b3e22fb
             S: +OK maildrop has 1 message (369 octets)

             In this example, the shared  secret  is  the  string  `tan-
             staaf'.  Hence, the MD5 algorithm is applied to the string

                <[email protected]>tanstaaf

             which produces a digest value of

                c4c9334bac560ecc979e58001b3e22fb

8. Scaling and Operational Considerations

   Since some of the optional features described above were added to the
   POP3 protocol, experience has accumulated in using them in large-
   scale commercial post office operations where most of the users are
   unrelated to each other.  In these situations and others, users and
   vendors of POP3 clients have discovered that the combination of using
   the UIDL command and not issuing the DELE command can provide a weak
   version of the "maildrop as semi-permanent repository" functionality
   normally associated with IMAP.  Of course the other capabilities of



Myers & Rose                Standards Track                    [Page 16]

RFC 1939                          POP3                          May 1996


   IMAP, such as polling an existing connection for newly arrived
   messages and supporting multiple folders on the server, are not
   present in POP3.

   When these facilities are used in this way by casual users, there has
   been a tendency for already-read messages to accumulate on the server
   without bound.  This is clearly an undesirable behavior pattern from
   the standpoint of the server operator.  This situation is aggravated
   by the fact that the limited capabilities of the POP3 do not permit
   efficient handling of maildrops which have hundreds or thousands of
   messages.

   Consequently, it is recommended that operators of large-scale multi-
   user servers, especially ones in which the user's only access to the
   maildrop is via POP3, consider such options as:

   *  Imposing a per-user maildrop storage quota or the like.

      A disadvantage to this option is that accumulation of messages may
      result in the user's inability to receive new ones into the
      maildrop.  Sites which choose this option should be sure to inform
      users of impending or current exhaustion of quota, perhaps by
      inserting an appropriate message into the user's maildrop.

   *  Enforce a site policy regarding mail retention on the server.

      Sites are free to establish local policy regarding the storage and
      retention of messages on the server, both read and unread.  For
      example, a site might delete unread messages from the server after
      60 days and delete read messages after 7 days.  Such message
      deletions are outside the scope of the POP3 protocol and are not
      considered a protocol violation.

      Server operators enforcing message deletion policies should take
      care to make all users aware of the policies in force.

      Clients must not assume that a site policy will automate message
      deletions, and should continue to explicitly delete messages using
      the DELE command when appropriate.

      It should be noted that enforcing site message deletion policies
      may be confusing to the user community, since their POP3 client
      may contain configuration options to leave mail on the server
      which will not in fact be supported by the server.

      One special case of a site policy is that messages may only be
      downloaded once from the server, and are deleted after this has
      been accomplished.  This could be implemented in POP3 server



Myers & Rose                Standards Track                    [Page 17]

RFC 1939                          POP3                          May 1996


      software by the following mechanism: "following a POP3 login by a
      client which was ended by a QUIT, delete all messages downloaded
      during the session with the RETR command".  It is important not to
      delete messages in the event of abnormal connection termination
      (ie, if no QUIT was received from the client) because the client
      may not have successfully received or stored the messages.
      Servers implementing a download-and-delete policy may also wish to
      disable or limit the optional TOP command, since it could be used
      as an alternate mechanism to download entire messages.

9. POP3 Command Summary

      Minimal POP3 Commands:

         USER name               valid in the AUTHORIZATION state
         PASS string
         QUIT

         STAT                    valid in the TRANSACTION state
         LIST [msg]
         RETR msg
         DELE msg
         NOOP
         RSET
         QUIT

      Optional POP3 Commands:

         APOP name digest        valid in the AUTHORIZATION state

         TOP msg n               valid in the TRANSACTION state
         UIDL [msg]

      POP3 Replies:

         +OK
         -ERR

      Note that with the exception of the STAT, LIST, and UIDL commands,
      the reply given by the POP3 server to any command is significant
      only to "+OK" and "-ERR".  Any text occurring after this reply
      may be ignored by the client.









Myers & Rose                Standards Track                    [Page 18]

RFC 1939                          POP3                          May 1996


10. Example POP3 Session

      S: <wait for connection on TCP port 110>
      C: <open connection>
      S:    +OK POP3 server ready <[email protected]>
      C:    APOP mrose c4c9334bac560ecc979e58001b3e22fb
      S:    +OK mrose's maildrop has 2 messages (320 octets)
      C:    STAT
      S:    +OK 2 320
      C:    LIST
      S:    +OK 2 messages (320 octets)
      S:    1 120
      S:    2 200
      S:    .
      C:    RETR 1
      S:    +OK 120 octets
      S:    <the POP3 server sends message 1>
      S:    .
      C:    DELE 1
      S:    +OK message 1 deleted
      C:    RETR 2
      S:    +OK 200 octets
      S:    <the POP3 server sends message 2>
      S:    .
      C:    DELE 2
      S:    +OK message 2 deleted
      C:    QUIT
      S:    +OK dewey POP3 server signing off (maildrop empty)
      C:  <close connection>
      S:  <wait for next connection>

11. Message Format

   All messages transmitted during a POP3 session are assumed to conform
   to the standard for the format of Internet text messages [RFC822].

   It is important to note that the octet count for a message on the
   server host may differ from the octet count assigned to that message
   due to local conventions for designating end-of-line.  Usually,
   during the AUTHORIZATION state of the POP3 session, the POP3 server
   can calculate the size of each message in octets when it opens the
   maildrop.  For example, if the POP3 server host internally represents
   end-of-line as a single character, then the POP3 server simply counts
   each occurrence of this character in a message as two octets.  Note
   that lines in the message which start with the termination octet need
   not (and must not) be counted twice, since the POP3 client will
   remove all byte-stuffed termination characters when it receives a
   multi-line response.



Myers & Rose                Standards Track                    [Page 19]

RFC 1939                          POP3                          May 1996


12. References

   [RFC821] Postel, J., "Simple Mail Transfer Protocol", STD 10, RFC
       821, USC/Information Sciences Institute, August 1982.

   [RFC822] Crocker, D., "Standard for the Format of ARPA-Internet Text
       Messages", STD 11, RFC 822, University of Delaware, August 1982.

   [RFC1321] Rivest, R., "The MD5 Message-Digest Algorithm", RFC 1321,
       MIT Laboratory for Computer Science, April 1992.

   [RFC1730] Crispin, M., "Internet Message Access Protocol - Version
       4", RFC 1730, University of Washington, December 1994.

   [RFC1734] Myers, J., "POP3 AUTHentication command", RFC 1734,
       Carnegie Mellon, December 1994.

13. Security Considerations

   It is conjectured that use of the APOP command provides origin
   identification and replay protection for a POP3 session.
   Accordingly, a POP3 server which implements both the PASS and APOP
   commands should not allow both methods of access for a given user;
   that is, for a given mailbox name, either the USER/PASS command
   sequence or the APOP command is allowed, but not both.

   Further, note that as the length of the shared secret increases, so
   does the difficulty of deriving it.

   Servers that answer -ERR to the USER command are giving potential
   attackers clues about which names are valid.

   Use of the PASS command sends passwords in the clear over the
   network.

   Use of the RETR and TOP commands sends mail in the clear over the
   network.

   Otherwise, security issues are not discussed in this memo.

14. Acknowledgements

   The POP family has a long and checkered history.  Although primarily
   a minor revision to RFC 1460, POP3 is based on the ideas presented in
   RFCs 918, 937, and 1081.

   In addition, Alfred Grimstad, Keith McCloghrie, and Neil Ostroff
   provided significant comments on the APOP command.



Myers & Rose                Standards Track                    [Page 20]

RFC 1939                          POP3                          May 1996


15. Authors' Addresses

   John G. Myers
   Carnegie-Mellon University
   5000 Forbes Ave
   Pittsburgh, PA 15213

   EMail: [email protected]


   Marshall T. Rose
   Dover Beach Consulting, Inc.
   420 Whisman Court
   Mountain View, CA  94043-2186

   EMail: [email protected]



































Myers & Rose                Standards Track                    [Page 21]

RFC 1939                          POP3                          May 1996


Appendix A. Differences from RFC 1725

   This memo is a revision to RFC 1725, a Draft Standard.  It makes the
   following changes from that document:

      - clarifies that command keywords are case insensitive.

      - specifies that servers must send "+OK" and "-ERR" in
        upper case.

      - specifies that the initial greeting is a positive response,
        instead of any string which should be a positive response.

      - clarifies behavior for unimplemented commands.

      - makes the USER and PASS commands optional.

      - clarified the set of possible responses to the USER command.

      - reverses the order of the examples in the USER and PASS
        commands, to reduce confusion.

      - clarifies that the PASS command may only be given immediately
        after a successful USER command.

      - clarified the persistence requirements of UIDs and added some
        implementation notes.

      - specifies a UID length limitation of one to 70 octets.

      - specifies a status indicator length limitation
        of 512 octets, including the CRLF.

      - clarifies that LIST with no arguments on an empty mailbox
        returns success.

      - adds a reference from the LIST command to the Message Format
        section

      - clarifies the behavior of QUIT upon failure

      - clarifies the security section to not imply the use of the
        USER command with the APOP command.

      - adds references to RFCs 1730 and 1734

      - clarifies the method by which a UA may enter mail into the
        transport system.



Myers & Rose                Standards Track                    [Page 22]

RFC 1939                          POP3                          May 1996


      - clarifies that the second argument to the TOP command is a
        number of lines.

      - changes the suggestion in the Security Considerations section
        for a server to not accept both PASS and APOP for a given user
        from a "must" to a "should".

      - adds a section on scaling and operational considerations

Appendix B. Command Index

       APOP .......................................................   15
       DELE .......................................................    8
       LIST .......................................................    6
       NOOP .......................................................    9
       PASS .......................................................   14
       QUIT .......................................................    5
       QUIT .......................................................   10
       RETR .......................................................    8
       RSET .......................................................    9
       STAT .......................................................    6
       TOP ........................................................   11
       UIDL .......................................................   12
       USER .......................................................   13



























Myers & Rose                Standards Track                    [Page 23]



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/profiler/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
2003-04-13  Andreas Kupries <[email protected]>

	* profiler.test:
	* profiler.tcl: Accepted patch #575376 by Hemang Lavana
	  <[email protected]> reorganizing the internals
	  a bit and using the 8.4 specific trace support if possible.

2003-04-11  Andreas Kupries  <[email protected]>

	* profiler.tcl:
	* profiler.man:
	* pkgIndex.tcl:  Set version of the package to to 0.2.1.

2003-02-24  David N. Welton  <[email protected]>

	* profiler.tcl (::profiler::tZero): Use string map instead of
	regsub.

2003-02-06  David N. Welton  <[email protected]>

	* profiler.tcl (::profiler::profProc): Use string match instead of
	  regexp.

2003-01-16  Andreas Kupries  <[email protected]>

	* profiler.man: More semantic markup, less visual one.

2002-10-14  Jeff Hobbs  <[email protected]>

	* profiler.tcl (dump): required result initialization. [Bug #564767]

2002-04-15  Andreas Kupries <[email protected]>

	* profiler.man: Added doctools manpage.

2001-08-21  Andreas Kupries <[email protected]>

	* 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
	  <[email protected]>, adding support for
	  resume/suspend operations to the profiler. moved version to 0.2.

2001-07-31  Andreas Kupries <[email protected]>

	* profiler.tcl (Handler): Fixed [446562].

2001-07-10  Andreas Kupries <[email protected]>

	* profiler.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* profiler.tcl: Fixed dubious code reported by frink.

2000-09-20  Eric Melski  <[email protected]>

	* profiler.tcl: Corrected some non-Tcl-style-guide conforming
	function headers.

2000-06-15  Eric Melski  <[email protected]>

	* profiler.tcl: Added mods from Philip Ehrens
	<[email protected]> to changed formatting, add additional
	statistics. [RFE: 5060]

2000-03-27  Eric Melski  <[email protected]>

	* profiler.tcl: Added a check for [clock clicks] wrapping.

2000-03-20  Eric Melski  <[email protected]>

	* profiler.test: 
	* profiler.tcl: Fixed issue with printing of descendants.

2000-03-09  Eric Melski  <[email protected]>

	* profiler.test: Adapted tests to work inside and outside of
	tcllib test framework.

2000-03-08  Eric Melski  <[email protected]>

	* 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  <[email protected]>

	* profiler.tcl: Added profiler::reset function and enhanced 
	profiler::sortFunctions

	* profiler.n: Updated documentation.

2000-02-24  Eric Melski  <[email protected]>

	* profiler.tcl: Fixed dump command output to include
	the name of the function being dumped.

2000-02-17  Eric Melski  <[email protected]>

	* 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.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































Deleted modules/profiler/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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.3]} {return}
package ifneeded profiler 0.2.1 [list source [file join $dir profiler.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/profiler/profiler.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin profiler n 0.2.1]
[moddesc   {Tcl Profiler}]
[titledesc {Tcl source code profiler}]
[require Tcl 8.3]
[require profiler [opt 0.2.1]]
[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]

[lst_item [const totalCalls]]

The total number of times [arg functionName] was called.

[lst_item [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].

[lst_item [const compileTime]]

The runtime, in clock clicks, of [arg functionName] the first time
that it was called.

[lst_item [const totalRuntime]]

The sum of the runtimes of all calls of [arg functionName].

[lst_item [const averageRuntime]]

Average runtime of [arg functionName].

[lst_item [const descendantTime]]

Sum of the time spent in descendants of [arg functionName].

[lst_item [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]]

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]

[keywords profile performance speed]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































Deleted modules/profiler/profiler.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: profiler.n,v 1.6 2001/08/21 23:36:32 andreas_kupries Exp $
'\" 
.so man.macros
.TH profiler n 0.2 profiler "Tcl Profiler"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
profiler \- Tcl source code profiler
.SH SYNOPSIS
\fBpackage require Tcl 8.3\fR
.sp
\fBpackage require profiler ?0.2?\fR
.sp
\fB::profiler::suspend\fR ?\fIpattern\fR?
.sp
\fB::profiler::resume\fR ?\fIpattern\fR?
.sp
\fB::profiler::init\fR
.sp
\fB::profiler::dump\fR ?\fIpattern\fR?
.sp
\fB::profiler::print\fR ?\fIpattern\fR?
.sp
\fB::profiler::reset\fR ?\fIpattern\fR?
.sp
\fB::profiler::sortFunctions\fR \fIkey\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fBprofiler\fR 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 \fBproc\fR command.
Profiling is initiated via the \fB::profiler::init\fR command.
.SH COMMANDS
.TP
\fB::profiler::init\fR
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.
.TP
\fB::profiler::dump\fR \fIpattern\fR
Dump profiling information for the all functions matching
\fIpattern\fR.  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: 
.RS
.TP
\fBtotalCalls\fR
The total number of times \fIfunctionName\fR was called.
.TP
\fBcallerDist\fB
A list of key/value pairs mapping each calling function that called
\fIfunctionName\fR to the number of times it called \fIfunctionName\fR.
.TP
\fBcompileTime\fR
The runtime, in clock clicks, of \fIfunctionName\fR the first time
that it was called.
.TP
\fBtotalRuntime\fR
The sum of the runtimes of all calls of \fIfunctionName\fR.
.TP
\fBaverageRuntime\fR
Average runtime of \fIfunctionName\fR.
.TP
\fBdescendantTime\fR
Sum of the time spent in descendants of \fIfunctionName\fR.
.TP
\fBaverageDescendantTime\fR
Average time spent in descendants of \fIfunctionName\fR. 
.RE
.TP
\fB::profiler::print\fR ?\fIpattern\fR?
Print profiling information for all functions matching \fIpattern\fR.
If no pattern is specified, information about all functions will be displayed.
The return result is a human readable display of the profiling
information.
.TP
\fB::profiler::reset\fR
Reset profiling information for all functions matching \fIpattern\fR.
If no pattern is specified, information will be reset for all functions.
.TP
\fB::profiler::suspend\fR ?\fIpattern\fR?
Suspend profiling for all functions matching \fIpattern\fR.
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.
.TP
\fB::profiler::resume\fR ?\fIpattern\fR?
Resume profiling for all functions matching \fIpattern\fR.
If no pattern is specified, profiling will be resumed for
all functions.  This command should be invoked after suspending
the profiler in the code.
.TP
\fB::profiler::sortFunctions\fR \fIkey\fR
Return a list of functions sorted by a particular profiling
statistic.  Supported values for \fIkey\fR are: \fBcalls\fR,
\fBexclusiveTime\fR, \fBcompileTime\fR, \fBnonCompileTime\fR,
\fBtotalRuntime\fR, \fBavgExclusiveTime\fR, and \fBavgRuntime\fR.  The
return result is a list of lists, where each sublist consists of a
function name and the value of \fIkey\fR for that function.
.SH KEYWORDS
profile, performance, speed
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































Deleted modules/profiler/profiler.tcl.

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

package require Tcl 8.3		;# uses [clock clicks -milliseconds]
package provide profiler 0.2.1

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 {
           set sum [ expr { $sum+$val } ]
        }
        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)) } ]
        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]
    }

    ::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]
    }

    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::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
    variable compileTime
    variable totalRuntime
    variable descendantTime
    variable descendants
    variable statTime
    variable callers
    
    set result ""
    foreach name [lsort [array names callCount $pattern]] {
	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"
	    continue
	}
	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::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
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/profiler/profiler.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# This constraint restricts certain tests to run on tcl8.3 version only
if {[package vsatisfies [package provide tcltest] 2.0]} {
    # tcltest2.0+ has an API to specify a test constraint
    ::tcltest::testConstraint tcl8.3only \
        [expr {![package vsatisfies [package provide Tcl] 8.4]}]
} else {
    # In tcltest1.0, a global variable needs to be set directly.
    set ::tcltest::testConstraints(tcl8.3only) \
        [expr {![package vsatisfies [package provide Tcl] 8.4]}]
}

# Add the test script dir to the auto_path, so that we can package require
# profiler
set auto_path [linsert $auto_path 0 [file dirname [info script]]]

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-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]
	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} {
    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.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}

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/report/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
2003-04-11  Andreas Kupries  <[email protected]>

	* report.tcl:
	* report.man:
	* pkgIndex.tcl:  Set version of the package to to 0.3.1

2003-01-16  Andreas Kupries  <[email protected]>

	* report.man: More semantic markup, less visual one.

2002-03-20  Andreas Kupries  <[email protected]>

	* report.n: 
	* report.man: Corrected example for "captionedtable".

2002-03-15  Andreas Kupries  <[email protected]>

	* report.man: Added example of formatting a matrix using tabular
	  reports (See tcllib module "struct" too.). Fixes #530207.

2002-02-28  Andreas Kupries  <[email protected]>

	* report.man: New file, manpage in doctools format.

2002-02-01  Andreas Kupries  <[email protected]>

	* Version up to 0.3 to differentiate development from the
	  version in the tcllib 1.2 release.

	* report.tcl: 
	* report.test: Updated code and tests to cover all paths through the
	  code.

2001-10-16  Andreas Kupries  <[email protected]>

	* report.n:
	* report.tcl:
	* pkgIndex.tcl: Version up to 0.2

2001-08-20  Andreas Kupries  <[email protected]>

	* report.test: Fixed broken error messages for 8.4. Using
	  [tcltest::getErrorMessage] now to get the correct message for
	  all versions of the core. Bug [440049] reported by Larry Virden.

2001-07-10  Andreas Kupries <[email protected]>

	* report.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* report.tcl: Fixed dubious code reported by frink.

2001-06-19  Andreas Kupries <[email protected]>

	* report.n: Fixed nroff trouble.

2001-05-01  Andreas Kupries <[email protected]>

	* Committed to CVS head at SF.

2001-04-22  Andreas Kupries <[email protected]>

	* New module for formatting matrices, reporting tabular data
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































Deleted modules/report/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 report 0.3.1 [list source [file join $dir report.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/report/report.man.

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

This package provides report objects which can be used by the
formatting methods of matrix objects to generate tabular reports of
the matrix in various forms. The report objects defined here break
each report down into three [sectref REGIONS] and ten classes of
[term lines] (various separator- and data-lines). See the following
section for more detailed explanations.

[list_begin definitions]

[call [cmd ::report::report] [arg reportName] [arg columns] [opt "[const style] [arg "style arg..."]"]]

Creates a new report object for a report having [arg columns] columns
with an associated global Tcl command whose name is

[arg reportName]. This command may be used to invoke various
configuration operations on the report. It has the following general
form:

[list_begin definitions]

[call [cmd reportName] [arg option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command. See section [sectref {REPORT METHODS}] for more
explanations. If no [const style] is specified the report will use
the builtin style [const plain] as its default configuration.

[list_end]

[call [cmd ::report::defstyle] [arg "styleName arguments script"]]

Defines the new style [arg styleName]. See section [sectref STYLES]
for more information.

[call [cmd ::report::rmstyle] [arg styleName]]

Deletes the style [arg styleName]. Trying to delete an unknown or
builtin style will result in an error. Beware, this command will not
check that there are no other styles depending on the deleted
one. Deleting a style which is still used by another style FOO will
result in a runtime error when FOO is applied to a newly instantiated
report.

[call [cmd ::report::stylearguments] [arg styleName]]

This introspection command returns the list of arguments associated
with the style [arg styleName].

[call [cmd ::report::stylebody] [arg styleName]]

This introspection command returns the script associated with the
style [arg styleName].

[call [cmd ::report::styles]]

This introspection command returns a list containing the names of all
styles known to the package at the time of the call. The order of the
names in the list reflects the order in which the styles were
created. In other words, the first item is the predefined style
[const plain], followed by the first style defined by the user, and
so on.

[list_end]

[section REGIONS]
[para]

The three regions are the [term {top caption}],

[term {data area}] and [term {bottom caption}]. These are,
roughly speaking, the title, the values to report and a title at the
bottom. The size of the caption regions can be specified by the user
as the number of rows they occupy in the matrix to format. The size of
the data area is specified implicitly.

[section LINES]
[para]

[sectref TEMPLATES] are associated with each of the ten line classes,
defining the formatting for this kind of line. The user is able to
enable and disable the separator lines at will, but not the data
lines. Their usage is solely determined by the number of rows
contained in the three regions. Data lines and all enabled separators
must have a template associated with them.

[para]

Note that the data-lines in a report and the rows in the matrix the
report was generated from are [emph not] in a 1:1 relationship if
any row in the matrix has a height greater than one.

[para]

The different kinds of lines and the codes used by the report methods
to address them are:

[list_begin definitions]


[lst_item [const top]]

The topmost line of a report. Separates the report from anything which
came before it. The user can enable the usage of this line at will.

[lst_item [const topdatasep]]

This line is used to separate the data rows in the top caption region,
if it contains more than one row and the user enabled its usage.

[lst_item [const topcapsep]]

This line is used to separate the top caption and data regions, if the
top caption is not empty and the user enabled its usage.

[lst_item [const datasep]]

This line is used to separate the data rows in the data region, if it
contains more than one row and the user enabled its usage.

[lst_item [const botcapsep]]

This line is used to separate the data and bottom caption regions, if
the bottom caption is not empty and the user enabled its usage.

[lst_item [const botdatasep]]

This line is used to separate the data rows in the bottom caption
region, if it contains more than one row and the user enabled its
usage.

[lst_item [const bottom]]

The bottommost line of a report. Separates the report from anything
which comes after it. The user can enable the usage of this line at
will.

[lst_item [const topdata]]

This line defines the format of data lines in the top caption region
of the report.

[lst_item [const data]]

This line defines the format of data lines in the data region of the
report.

[lst_item [const botdata]]

This line defines the format of data lines in the bottom caption
region of the report.

[list_end]

[section TEMPLATES]
[para]

Each template is a list of strings used to format the line it is
associated with. For a report containing [var n] columns a template
for a data line has to contain "[var n]+1" items and a template for a
separator line "2*[var n]+1" items.

[para]

The items in a data template specify the strings used to separate the
column information. Together with the corresponding items in the
separator templates they form the vertical lines in the report.

[para]

[emph Note] that the corresponding items in all defined templates
have to be of equal length. This will be checked by the report
object. The first item defines the leftmost vertical line and the last
item defines the rightmost vertical line. The item at index [var k]
("1",...,"[var n]-2") separates the information in the columns

"[var k]-1" and "[var k]".

[para]

The items in a separator template having an even-numbered index
("0","2",...)  specify the column separators. The item at index
"2*[var k]" ("0","2",...,"2*[var n]") corresponds to the items at
index "[var k]" in the data templates.

[para]

The items in a separator template having an odd-numbered index
("1","3",...) specify the strings used to form the horizontal lines in
the separator lines. The item at index "2*[var k]+1"
("1","3",...,"2*[var n]+1") corresponds to column "[var k]". When
generating the horizontal lines the items are replicated to be at
least as long as the size of their column and then cut to the exact
size.

[section STYLES]
[para]

Styles are a way for the user of this package to define common
configurations for report objects and then use them later during the
actual instantiation of report objects. They are defined as tcl
scripts which when executed configure the report object into the
requested configuration.

[para]

The command to define styles is [cmd ::report::defstyle]. Its last
argument is the tcl [type script] performing the actual
reconfiguration of the report object to obtain the requested style.

[para]

In this script the names of all previously defined styles are
available as commands, as are all commands found in a safe interpreter
and the configuration methods of report objects. The latter implicitly
operate on the object currently executing the style script. The

[var arguments] declared here are available in the [type script] as
variables. When calling the command of a previously declared style all
the arguments expected by it have to be defined in the call.

[section {REPORT METHODS}]
[para]

The following commands are possible for report objects:

[list_begin definitions]


[call [arg reportName] [method destroy]]

Destroys the report, including its storage space and associated
command.

[call [arg reportName] [arg templatecode] [method disable]|[method enable]]

Enables or disables the usage of the template addressed by the

[arg templatecode]. Only the codes for separator lines are allowed
here. It is not possible to enable or disable data lines.

[nl]

Enabling a template causes the report to check all used templates for
inconsistencies in the definition of the vertical lines (See section
[sectref TEMPLATES]).

[call [arg reportName] [arg templatecode] [method enabled]]

Returns the whether the template addressed by the [arg templatecode]
is currently enabled or not.

[call [arg reportName] [arg templatecode] [method get]]

Returns the template currently associated with the kind of line
addressed by the [arg templatecode]. All known templatecodes are
allowed here.

[call [arg reportName] [arg templatecode] [method set] [arg templatedata]]

Sets the template associated with the kind of line addressed by the
[arg templatecode] to the new value in [arg templatedata]. See section
[sectref TEMPLATES] for constraints on the length of templates.

[call [arg reportName] [method tcaption] [opt [arg size]]]

Specifies the [arg size] of the top caption region as the number rows
it occupies in the matrix to be formatted. Only numbers greater than
or equal to zero are allowed. If no [arg size] is specified the
command will return the current size instead.

[nl]

Setting the size of the top caption to a value greater than zero
enables the corresponding data template and causes the report to check
all used templates for inconsistencies in the definition of the
vertical lines (See section [sectref TEMPLATES]).

[call [arg reportName] [method bcaption] [arg size]]

Specifies the [arg size] of the bottom caption region as the number
rows it occupies in the matrix to be formatted. Only numbers greater
than or equal to zero are allowed. If no [arg size] is specified the
command will return the current size instead.

[nl]

Setting the size of the bottom caption to a value greater than zero
enables the corresponding data template and causes the report to check
all used templates for inconsistencies in the definition of the
vertical lines (See section [sectref TEMPLATES]).

[call [arg reportName] [cmd size] [arg column] [opt "[arg number]|[const dyn]"]]

Specifies the size of the [arg column] in the output. The value
[const dyn] means that the columnwidth returned by the matrix to be
formatted for the specified column shall be used. The formatting of
the column is dynamic. If a fixed [arg number] is used instead of
[const dyn] it means that the column has a width of that many
characters (padding excluded). Only numbers greater than zero are
allowed here.

[nl]

If no size specification is given the command will return the current
size of the [arg column] instead.

[call [arg reportName] [cmd sizes] [opt [arg size-list]]]

This method allows the user to specify the sizes of all columns in one
call. Its argument is a list containing the sizes to associate with
the columns. The first item is associated with column 0, the next with
column 1, and so on.

[nl]

If no [arg size-list] is specified the command will return a list
containing the currently set sizes instead.

[call [arg reportName] [cmd pad] [arg column] [opt "[const left]|[const right]|[const both] [opt [arg padstring]]"]]

This method allows the user to specify padding on the left, right or
both sides of a [arg column]. If the [arg padstring] is not specified
it defaults to a single space character. [emph Note]: An alternative
way of specifying the padding is to use vertical separator strings
longer than one character in the templates (See section
[sectref TEMPLATES]).

[nl]

If no pad specification is given at all the command will return the
current state of padding for the column instead. This will be a list
containing two elements, the first element the left padding, the
second describing the right padding.

[call [arg reportName] [cmd justify] [arg column] [opt [const left]|[const right]|[const center]]]

Declares how the cell values for a [arg column] are filled into the
report given the specified size of a column in the report.

[nl]

For [const left] and [const right] justification a cell value
shorter than the width of the column is bound with its named edge to
the same edge of the column. The other side is filled with spaces. In
the case of [const center] the spaces are placed to both sides of the
value and the left number of spaces is at most one higher than the
right number of spaces.

[nl]

For a value longer than the width of the column the value is cut at
the named edge. This means for [const left] justification that the
[emph tail] (i.e. the [const right] part) of the value is made
visible in the output. For [const center] the value is cut at both
sides to fit into the column and the number of characters cut at the
left side of the value is at most one less than the number of
characters cut from the right side.

[nl]

If no justification was specified the command will return the current
justification for the column instead.

[call [arg reportName] [cmd printmatrix] [arg matrix]]

Formats the [arg matrix] according to the configuration of the report
and returns the resulting string. The matrix has to have the same
number of columns as the report. The matrix also has to have enough
rows so that the top and bottom caption regions do not overlap. The
data region is allowed to be empty.

[call [arg reportName] [cmd printmatrix2channel] [arg "matrix chan"]]

Formats the [arg matrix] according to the configuration of the report
and writes the result into the channel [arg chan]. The matrix has to
have the same number of columns as the report. The matrix also has to
have enough rows so that the top and bottom caption regions do not
overlap. The data region is allowed to be empty.

[call [arg reportName] [cmd columns]]

Returns the number of columns in the report.

[list_end]

[para]

The methods [method size], [method pad] and [method justify] all take
a column index as their first argument. This index is allowed to use
all the forms of an index as accepted by the [cmd lindex] command. The
allowed range for indices is

	"0,...,[lb][var reportName] columns[rb]-1".

[section EXAMPLES]
[para]

Our examples define some generally useful report styles.

[para]

A simple table with lines surrounding all information and vertical
separators, but without internal horizontal separators.

[para]

[example {
    ::report::defstyle simpletable {} {
	data	set [split "[string repeat "| "   [columns]]|"]
	top	set [split "[string repeat "+ - " [columns]]+"]
	bottom	set [top get]
	top	enable
	bottom	enable
    }
}]

[para]

An extension of a [cmd simpletable], see above, with a title area.

[para]

[example {
    ::report::defstyle captionedtable {{n 1}} {
	simpletable
	topdata   set [data get]
	topcapsep set [top get]
	topcapsep enable
	tcaption $n
    }
}]

[para]

Given the definitions above now an example which actually formats a
matrix into a tabular report. It assumes that the matrix actually
contains useful data.

[para]

[example {
    % ::struct::matrix m
    % # ... fill m with data, assume 5 columns
    % ::report::report r 5 style captionedtable 1
    % r printmatrix m
    +---+-------------------+-------+-------+--------+
    |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          |15     |47     |31.91   |
    |   |true numeric       |       |       |        |
    +---+-------------------+-------+-------+--------+
    %
    % # alternate way of doing the above
    % m format 2string r
}]

[keywords matrix report table]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/report/report.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
'\" 
'\" Copyright (c) 2001 by Andreas Kupries <[email protected]>
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: report.n,v 1.7 2002/03/26 05:25:24 andreas_kupries Exp $
'\" 
.so man.macros
.TH report n 0.3 Report "Matrix reports"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::report::report \- Create and manipulate report objects
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require report ?0.3?\fR
.sp
\fB::report::report\fR \fIreportName columns\fR ?\fBstyle\fR \fIstyle arg...\fR?
.sp
\fB::report::defstyle\fR \fIstyleName arguments script\fR
.sp
\fB::report::rmstyle\fR \fIstyleName\fR
.sp
\fB::report::stylearguments\fR \fIstyleName\fR
.sp
\fB::report::stylebody\fR \fIstyleName\fR
.sp
\fB::report::styles\fR
.sp
.BE
.SH DESCRIPTION
.PP
This package provides report objects which can be used by the
formatting methods of matrix objects to generate tabular reports of
the matrix in various forms. The report objects defined here break
each report down into three \fBregions\fR and ten classes of
\fBlines\fR (various separator- and data-lines). See the following
section for more detailed explanations.
.TP
\fB::report::report\fR \fIreportName columns\fR ?\fBstyle\fR \fIstyle
arg...\fR?  Creates a new report object for a report having
\fIcolumns\fR columns with an associated global Tcl command whose name
is \fIreportName\fR.  This command may be used to invoke various
configuration operations on the report. It has the following general
form: \fIreportName option \fR?\fIarg arg ...\fR?
.sp
\fIOption\fR and the \fIarg\fRs determine the exact behavior of the
command. See section \fBREPORT METHODS\fR for more explanations. If no
\fIstyle\fR is specified the report will use the builtin style
\fBplain\fR as its default configuration.
.TP
\fB::report::defstyle\fR \fIstyleName arguments script\fR
Defines the new style \fIstyleName\fR. See section \fBSTYLES\fR for
more information.
.TP
\fB::report::rmstyle\fR \fIstyleName\fR
Deletes the style \fIstyleName\fR. Trying to delete an unknown or
builtin style will result in an error. Beware, this command will not
check that there are no other styles depending on the deleted
one. Deleting a style which is still used by another style FOO will
result in a runtime error when FOO is applied to a newly instantiated
report.
.TP
\fB::report::stylearguments\fR \fIstyleName\fR
This introspection command returns the list of arguments associated with the
style \fIstyleName\fR.
.TP
\fB::report::stylebody\fR \fIstyleName\fR
This introspection command returns the script associated with the
style \fIstyleName\fR.
.TP
\fB::report::styles\fR
This introspection command returns a list containing the names of all
styles known to the package at the time of the call. The order of the
names in the list reflects the order in which the styles were
created. In other words, the first item is the predefined style
\fBplain\fR, followed by the first style defined by the user, and so
on.
.SH REGIONS
.PP
The three regions are the \fBtop caption\fR, \fBdata area\fR and
\fBbottom caption\fR. These are, roughly speaking, the title, the
values to report and a title at the bottom. The size of the caption
regions can be specified by the user as the number of rows they occupy
in the matrix to format. The size of the data area is specified
implicitly.
.SH LINES
.PP
Each of the ten line classes can have a \fBtemplate\fR (see section
below) associated with it defining the formatting for this kind of
line. The user is able to enable and disable the separator lines at
will, but not the data lines. Their usage is solely determined by the
number of rows contained in the three regions. Data lines and all
enabled separators must have a template associated with them.
.PP
Note that the data-lines in a report and the rows in the matrix the
report was generated from are \fBnot\fR in a 1:1 relationship if any
row in the matrix has a height greater than one.
.PP
The different kinds of lines and the codes used by the report methods
to address them are:
.TP
\fBtop\fR
The topmost line of a report. Separates the report from anything which
came before it. The user can enable the usage of this line at will.
.TP
\fBtopdatasep\fR
This line is used to separate the data rows in the top caption region,
if it contains more than one row and the user enabled its usage.
.TP
\fBtopcapsep\fR
This line is used to separate the top caption and data regions, if the
top caption is not empty and the user enabled its usage.
.TP
\fBdatasep\fR
This line is used to separate the data rows in the data region, if it
contains more than one row and the user enabled its usage.
.TP
\fBbotcapsep\fR
This line is used to separate the data and bottom caption regions, if
the bottom caption is not empty and the user enabled its usage.
.TP
\fBbotdatasep\fR
This line is used to separate the data rows in the bottom caption
region, if it contains more than one row and the user enabled its
usage.
.TP
\fBbottom\fR
The bottommost line of a report. Separates the report from anything
which comes after it. The user can enable the usage of this line at
will.
.TP
\fBtopdata\fR
This line defines the format of data lines in the top caption region
of the report.
.TP
\fBdata\fR
This line defines the format of data lines in the data region of the
report.
.TP
\fBbotdata\fR
This line defines the format of data lines in the bottom caption
region of the report.
.SH TEMPLATES
.PP
Each template is a list of strings used to format the line it is
associated with. For a report containing \fIn\fR columns a template
for a data line has to contain "\fIn\fR+1" items and a template for a
separator line "2*\fIn\fR+1" items.
.PP
The items in a data template specify the strings used to separate the
column information. Together with the corresponding items in the
separator templates they form the vertical lines in the
report.
.PP
\fBNote\fR that the corresponding items in all defined templates have
to be of equal length. This will be checked by the report object. The
first item defines the leftmost vertical line and the last item
defines the rightmost vertical line. The item at index \fIk\fR
("1",...,"\fIn\fR-2") separates the information in the columns
"\fIk\fR-1" and "\fIk\fR".
.PP
The items in a separator template having an even-numbered index
("0","2",...)  specify the column separators. The item at index
"2*\fIk\fR" ("0","2",...,"2*\fIn\fR") corresponds to the items at
index "\fIk\fR" in the data templates.
.PP
The items in a separator template having an odd-numbered index
("1","3",...) specify the strings used to form the horizontal lines in
the separator lines. The item at index "2*\fIk\fR+1"
("1","3",...,"2*\fIn\fR+1") corresponds to column "\fIk\fR". When
generating the horizontal lines the items are replicated to be at
least as long as the size of their column and then cut to the exact
size.
.SH STYLES
.PP
Styles are a way for the user of this package to define common
configurations for report objects and then use them later during the
actual instantiation of report objects. They are defined as tcl
scripts which when executed configure the report object into the
requested configuration.
.PP
The command to define styles is \fB::report::defstyle\fR. Its last
argument is the tcl \fIscript\fR performing the actual reconfiguration
of the report object to obtain the requested style.
.PP
In this script the names of all previously defined styles are
available as commands, as are all commands found in a safe interpreter
and the configuration methods of report objects. The latter implicitly
operate on the object currently executing the style script. The
\fIarguments\fR declared here are available in the \fIscript\fR as
variables. When calling the command of a previously declared style all
the arguments expected by it have to be defined in the call.
.SH REPORT METHODS
.PP
The following commands are possible for report objects:
.TP
\fIreportName\fR \fBdestroy\fR
Destroys the report, including its storage space and associated
command.
.TP
\fIreportName\fR \fItemplatecode\fR \fBdisable\fR|\fBenable\fR
Enables or disables the usage of the template addressed by the
\fItemplatecode\fR. Only the codes for separator lines are allowed
here. It is not possible to enable or disable data lines.
.sp
Enabling a template causes the report to check all used templates for
inconsistencies in the definition of the vertical lines (See section
\fBTEMPLATES\fR).
.TP
\fIreportName\fR \fItemplatecode\fR \fBenabled\fR
Returns the whether the template addressed by the \fItemplatecode\fR is
currently enabled or not.
.TP
\fIreportName\fR \fItemplatecode\fR \fBget\fR
Returns the template currently associated with the kind of line
addressed by the \fItemplatecode\fR. All known templatecodes are
allowed here.
.TP
\fIreportName\fR \fItemplatecode\fR \fBset\fR \fItemplatedata\fR
Sets the template associated with the kind of line addressed by the
\fItemplatecode\fR to the new value in \fItemplatedata\fR. See section
\fBTEMPLATES\fR for constraints on the length of templates.
.TP
\fIreportName\fR \fBtcaption\fR ?\fIsize\fR?
Specifies the \fIsize\fR of the top caption region as the number rows
it occupies in the matrix to be formatted. Only numbers greater than
or equal to zero are allowed. If no \fIsize\fR is specified the
command will return the current size instead.
.sp
Setting the size of the top caption to a value greater than zero
enables the corresponding data template and causes the report to check
all used templates for inconsistencies in the definition of the
vertical lines (See section \fBTEMPLATES\fR).
.TP
\fIreportName\fR \fBbcaption\fR \fIsize\fR
Specifies the \fIsize\fR of the bottom caption region as the number
rows it occupies in the matrix to be formatted. Only numbers greater
than or equal to zero are allowed. If no \fIsize\fR is specified the
command will return the current size instead.
.sp
Setting the size of the bottom caption to a value greater than zero
enables the corresponding data template and causes the report to check
all used templates for inconsistencies in the definition of the
vertical lines (See section \fBTEMPLATES\fR).
.TP
\fIreportName\fR \fBsize\fR \fIcolumn\fR ?\fInumber\fR|\fBdyn\fR?
Specifies the size of the \fIcolumn\fR in the output. The value
\fBdyn\fR means that the columnwidth returned by the matrix to be
formatted for the specified column shall be used. The formatting of
the column is "dynamic". If a fixed \fInumber\fR is used instead of
\fBdyn\fR it means that the column has a width of that many characters
(padding excluded). Only numbers greater than zero are allowed here.
.sp
If no size specification is given the command will return the current
size of the \fIcolumn\fR instead.
.TP
\fIreportName\fR \fBsizes\fR ?\fIsize-list\fR?
This method allows the user to specify the sizes of all columns in one
call. Its argument is a list containing the sizes to associate with
the columns. The first item is associated with column 0, the next with
column 1, and so on.
.sp
If no \fIsize-list\fR is specified the command will return a list
containing the currently set sizes instead.
.TP
\fIreportName\fR \fBpad\fR \fIcolumn\fR ?\fBleft\fR|\fBright\fR|\fBboth\fR ?\fIpadstring\fR??
This method allows the user to specify padding on the left, right or
both sides of a \fIcolumn\fR. If the \fIpadstring\fR is not specified
it defaults to a single space character. \fBNote\fR: An alternative
way of specifying the padding is to use vertical separator strings
longer than one character in the templates (See section
\fBTEMPLATES\fR).
.sp
If no pad specification is given at all the command will return the
current state of padding for the column instead. This will be a list
containing two elements, the first element the left padding, the
second describing the right padding.
.TP
\fIreportName\fR \fBjustify\fR \fIcolumn\fR ?\fBleft\fR|\fBright\fR|\fBcenter\fR?
Declares how the cell values for a \fIcolumn\fR are filled into the
report given the specified size of a column in the report.
.sp
For \fBleft\fR and \fBright\fR justification a cell value shorter than
the width of the column is bound with its named edge to the same edge
of the column. The other side is filled with spaces. In the case of
\fBcenter\fR the spaces are placed to both sides of the value and the
left number of spaces is at most one higher than the right number of
spaces.
.sp
For a value longer than the width of the column the value is cut at
the named edge. This means for \fBleft\fR justification that the
\fBtail\fR (i.e. the \fBright\fR part) of the value is made visible in
the output. For \fBcenter\fR the value is cut at both sides to fit
into the column and the number of characters cut at the left side of
the value is at most one less than the number of characters cut from
the right side.
.sp
If no justification was specified the command will return the
current justification for the column instead.
.TP
\fIreportName\fR \fBprintmatrix\fR \fImatrix\fR
Formats the \fImatrix\fR according to the configuration of the report
and returns the resulting string. The matrix has to have the same
number of columns as the report. The matrix also has to have enough
rows so that the top and bottom caption regions do not overlap. The
data region is allowed to be empty.
.TP
\fIreportName\fR \fBprintmatrix2channel\fR \fImatrix chan\fR
Formats the \fImatrix\fR according to the configuration of the report
and writes the result into the channel \fIchan\fR. The matrix has to
have the same number of columns as the report. The matrix also has to
have enough rows so that the top and bottom caption regions do not
overlap. The data region is allowed to be empty.
.TP
\fIreportName\fR \fBcolumns\fR
Returns the number of columns in the report.
.PP
The methods \fBsize\fR, \fBpad\fR and \fBjustify\fR all take a column
index as their first argument. This index is allowed to use all the
forms of an index as accepted by the \fBlindex\fR command. The allowed
range for indices is "0,...,[\fIreportName\fR columns]-1".
.SH EXAMPLES
.PP
Our examples define some generally useful report styles.
.PP
A simple table with lines surrounding all information and vertical
separators, but without internal horizontal separators.
.PP
.CS
::report::defstyle simpletable {} {
	data	set [split "[string repeat "| "   [columns]]|"]
	top	set [split "[string repeat "+ - " [columns]]+"]
	bottom	set [top get]
	top	enable
	bottom	enable
}
.CE
.PP
An extension of a \fBsimpletable\fR, see above, with a title area.
.PP
.CS
::report::defstyle captionedtable {{n 1}} {
	simpletable
	topdata   set [data get]
	topcapsep set [top get]
	topcapsep enable
	tcaption $n
}
.CE
.SH KEYWORDS
matrix, report, table
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































Deleted modules/report/report.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
# report.tcl --
#
#	Implementation of report objects for Tcl.
#
# Copyright (c) 2001 by Andreas Kupries <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: report.tcl,v 1.7 2003/04/11 20:15:11 andreas_kupries Exp $

package require Tcl 8.2
package provide report 0.3.1

namespace eval ::report {
    # Data storage in the report module
    # -------------------------------
    #
    # One namespace per object, containing
    #  1) An array mapping from template codes to templates
    #  2) An array mapping from template codes and columns to horizontal template items
    #  3) An array mapping from template codes and columns to vertical template items
    #  4) ... deleted, local to formatting
    #  5) An array mapping from columns to left padding
    #  6) An array mapping from columns to right padding
    #  7) An array mapping from columns to column size
    #  8) An array mapping from columns to justification
    #  9) A scalar containing the number of columns in the report.
    # 10) An array mapping from template codes to enabledness
    # 11) A scalar containing the size of the top caption
    # 12) A scalar containing the size of the bottom caption
    #
    # 1 - template		5 - lpad	 9 - columns
    # 2 - hTemplate		6 - rpad	10 - enabled
    # 3 - vTemplate		7 - csize	11 - tcaption
    # 4 - fullHTemplate		8 - cjust	12 - bcaption

    # commands is the list of subcommands recognized by the report
    variable commands [list		\
	    "bcaption"			\
	    "botcapsep"			\
	    "botdata"			\
	    "botdatasep"		\
	    "bottom"			\
	    "columns"			\
	    "data"			\
	    "datasep"			\
	    "justify"			\
	    "pad"			\
	    "printmatrix"		\
	    "printmatrix2channel"	\
	    "size"			\
	    "sizes"			\
	    "tcaption"			\
	    "top"			\
	    "topcapsep"			\
	    "topdata"			\
	    "topdatasep"
	    ]

    # Only export the toplevel commands
    namespace export report defstyle rmstyle stylearguments stylebody

    # Global data, style definitions

    variable styles [list plain]
    variable styleargs
    variable stylebody

    array set styleargs {plain {}}
    array set stylebody {plain {}}

    # Global data, template codes, for easy checking

    variable  tcode
    array set tcode {
	topdata    0	data       0
	botdata    0	top        1
	topdatasep 1	topcapsep  1
	datasep    1	botcapsep  1
	botdatasep 1	bottom     1
    }
}

# ::report::report --
#
#	Create a new report with a given name
#
# Arguments:
#	name	Optional name of the report; if null or not given, generate one.
#
# Results:
#	name	Name of the report created

proc ::report::report {name columns args} {
    variable styleargs

    if { [llength [info commands ::$name]] } {
	error "command \"$name\" already exists, unable to create report"
    }
    if {![string is integer $columns]} {
	return -code error "columns: expected integer greater than zero, got \"$columns\""
    } elseif {$columns <= 0} {
	return -code error "columns: expected integer greater than zero, got \"$columns\""
    }

    set styleName ""
    switch -exact -- [llength $args] {
	0 {# No style was specied. This is OK}
	1 {
	    # We possibly got the "style" keyword, but everything behind is missing
	    return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??"
	}
	default {
	    # Break tail apart, check for correct keyword, ensure that style is known too.
	    # Don't forget to check the actual against the formal arguments.

	    foreach {dummy styleName} $args break
	    set args [lrange $args 2 end]

	    if {![string equal $dummy style]} {
		return -code error "wrong # args: report name columns ?\"style\" styleName ?arg...??"
	    }
	    if {![info exists styleargs($styleName)]} {
		return -code error "style \"$styleName\" is not known"
	    }
	    CheckStyleArguments $styleName $args
	}
    }

    # The arguments seem to be ok, setup the namespace for the object
    # and configure it to style "plain".

    namespace eval ::report::report$name "variable columns $columns"
    namespace eval ::report::report$name {
	variable tcaption 0
	variable bcaption 0
	variable template
	variable enabled
	variable hTemplate
	variable vTemplate
	variable lpad
	variable rpad
	variable csize
	variable cjust

	variable t
	variable i
	variable dt [list]
	variable st [list]
	for {set i 0} {$i < $columns} {incr i} {
	    set lpad($i) ""
	    set rpad($i) ""
	    set csize($i) dyn
	    set cjust($i) left
	    lappend dt {}
	    lappend st {} {}
	}
	lappend dt {}
	lappend st {}

	foreach t {
	    topdata data botdata
	} {
	    set enabled($t) 1
	    set template($t) $dt
	    for {set i 0} {$i <= $columns} {incr i} {
		set vTemplate($t,$i) {}
	    }
	}
	foreach t {
	    top topdatasep topcapsep
	    datasep
	    botcapsep botdatasep bottom
	} {
	    set enabled($t) 0
	    set template($t) $st
	    for {set i 0} {$i < $columns} {incr i} {
		set hTemplate($t,$i) {}
	    }
	    for {set i 0} {$i <= $columns} {incr i} {
		set vTemplate($t,$i) {}
	    }
	}

	unset t i dt st
    }

    # Create the command to manipulate the report
    #                 $name -> ::report::ReportProc $name
    interp alias {} ::$name {} ::report::ReportProc $name

    # If a style was specified execute it now, before the oobject is
    # handed back to the user.

    if {$styleName != {}} {
	ExecuteStyle $name $styleName $args
    }

    return $name
}

# ::report::defstyle --
#
#	Defines a new named style, with arguments and defining script.
#
# Arguments:
#	styleName	Name of the new style.
#	arguments	Formal arguments of the style, some format as for proc.
#	body		The script actually defining the style.
#
# Results:
#	None.

proc ::report::defstyle {styleName arguments body} {
    variable styleargs
    variable stylebody
    variable styles

    if {[info exists styleargs($styleName)]} {
	return -code error "Cannot create style \"$styleName\", already exists"
    }

    # Check the formal arguments
    # 1. Arguments without default may not follow an argument with a
    #    default. The special "args" is no exception!
    # 2. Compute the minimal number of arguments required by the proc.

    set min 0
    set def 0
    set ca  0

    foreach v $arguments {
	switch -- [llength $v] {
	    1 {
		if {$def} {
		    return -code error \
			    "Found argument without default after arguments having defaults"
		}
		incr min
	    }
	    2 {
		set def 1
	    }
	    default {
		error "Illegal length of value \"$v\""
	    }
	}
    }
    if {[string equal args [lindex $arguments end]]} {
	# Correct requirements if we have a catch-all at the end.
	incr min -1
	set  ca 1
    }

    # Now we are allowed to extend the internal database

    set styleargs($styleName) [list $min $ca $arguments]
    set stylebody($styleName) $body
    lappend styles $styleName
    return
}

# ::report::rmstyle --
#
#	Deletes the specified style.
#
# Arguments:
#	styleName	Name of the style to destroy.
#
# Results:
#	None.

proc ::report::rmstyle {styleName} {
    variable styleargs
    variable stylebody
    variable styles

    if {![info exists styleargs($styleName)]} {
	return -code error "cannot delete unknown style \"$styleName\""
    }
    if {[string equal $styleName plain]} {
	return -code error {cannot delete builtin style "plain"}
    }

    unset styleargs($styleName)
    unset stylebody($styleName)

    set pos    [lsearch -exact $styles $styleName]
    set styles [lreplace $styles $pos $pos]
    return
}

# ::report::_stylearguments --
#
#	Introspection, returns the list of formal arguments of the
#	specified style.
#
# Arguments:
#	styleName	Name of the style to query.
#
# Results:
#	A list containing the formal argument of the style

proc ::report::stylearguments {styleName} {
    variable styleargs
    if {![info exists styleargs($styleName)]} {
	return -code error "style \"$styleName\" is not known"
    }
    return [lindex $styleargs($styleName) 2]
}

# ::report::_stylebody --
#
#	Introspection, returns the body/script of the
#	specified style.
#
# Arguments:
#	styleName	Name of the style to query.
#
# Results:
#	A script, the body of the style.

proc ::report::stylebody {styleName} {
    variable stylebody
    if {![info exists stylebody($styleName)]} {
	return -code error "style \"$styleName\" is not known"
    }
    return $stylebody($styleName)
}

# ::report::_styles --
#
#	Returns alist containing the names of all known styles.
#
# Arguments:
#	None.
#
# Results:
#	A list containing the names of all known styles

proc ::report::styles {} {
    variable styles
    return  $styles
}

##########################
# Private functions follow

# ::report::CheckStyleArguments --
#
#	Internal helper. Used to check actual arguments of a style against the formal ones.
#
# Arguments:
#	styleName	Name of the style in question
#	arguments	Actual arguments for the style.
#
# Results:
#	None, or an error in case of problems.

proc ::report::CheckStyleArguments {styleName arguments} {
    variable styleargs

    # Match formal and actual arguments, error out in case of problems.
    foreach {min catchall formal} $styleargs($styleName) break

    if {[llength $arguments] < $min} {
	# Determine the name of the first formal parameter which did not get a value.
	set firstmissing [lindex $formal [llength $arguments]]
	return -code error "no value given for parameter \"$firstmissing\" to style \"$styleName\""
    } elseif {[llength $arguments] > $min} {
	if {!$catchall && ([llength $arguments] > [llength $formal])} {
	    # More actual arguments than formals, without catch-all argument, error
	    return -code error "called style \"$styleName\" with too many arguments"
	}
    }
}

# ::report::ExecuteStyle --
#
#	Internal helper. Applies a named style to the specified report object.
#
# Arguments:
#	name		Name of the report the style is applied to.
#	styleName	Name of the style to apply
#	arguments	Actual arguments for the style.
#
# Results:
#	None.

proc ::report::ExecuteStyle {name styleName arguments} {
    variable styleargs
    variable stylebody
    variable styles
    variable commands

    CheckStyleArguments $styleName $arguments
    foreach {min catchall formal} $styleargs($styleName) break

    array set a {}

    if {([llength $arguments] > $min) && $catchall} {
	# #min = number of formal arguments - 1
	set a(args) [lrange $arguments $min end]
	set formal  [lrange $formal 0 end-1]
	incr min -1
	set arguments [lrange $arguments 0 $min]

	# arguments and formal are now of equal length and we also
	# know that there are no arguments having a default value.
	foreach v $formal aval $arguments {
	    set a($v) $aval
	}
    }

    # More arguments than minimally required, but no more than formal
    # arguments! Proceed to standard matching: Go through the actual
    # values and associate them with a formal argument. Then fill the
    # remaining formal arguments with their default values.

    foreach aval $arguments {
	set v      [lindex $formal 0]
	set formal [lrange $formal 1 end]
	if {[llength $v] > 1} {set v [lindex $v 0]}
	set a($v) $aval
    }

    foreach vd $formal {
	foreach {var default} $vd {
	    set a($var) $default
	}
    }

    # Create and initialize a safe interpreter, execute the style and
    # then break everything down again.

    set ip [interp create -safe]

    # -- Report methods --

    foreach m $commands {
	# safe-ip method --> here report method
	interp alias $ip $m {} $name $m
    }

    # -- Styles defined before this one --

    foreach s $styles {
	if {[string equal $s $styleName]} {break}
	interp alias $ip $s {} ::report::LinkExec $name $s
    }

    # -- Arguments as variables --

    foreach {var val} [array get a] {
	$ip eval [list set $var $val]
    }

    # Finally execute / apply the style.

    $ip eval $stylebody($styleName)
    interp delete $ip
    return
}

# ::report::_LinkExec --
#
#	Internal helper. Used for application of styles from within
#	another style script. Collects the formal arguments into the
#	one list which is expected by "ExecuteStyle".
#
# Arguments:
#	name		Name of the report the style is applied to.
#	styleName	Name of the style to apply
#	args		Actual arguments for the style.
#
# Results:
#	None.

proc ::report::LinkExec {name styleName args} {
    ExecuteStyle $name $styleName $args
}

# ::report::ReportProc --
#
#	Command that processes all report object commands.
#
# Arguments:
#	name	Name of the report object to manipulate.
#	cmd	Subcommand to invoke.
#	args	Arguments for subcommand.
#
# Results:
#	Varies based on command to perform

proc ::report::ReportProc {name {cmd ""} args} {
    variable tcode

    # 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 {[info exists tcode($cmd)]} {
	# Template codes are a bit special
	eval [list ::report::_tAction $name $cmd] $args
    } else {
	if { [llength [info commands ::report::_$cmd]] == 0 } {
	    variable commands
	    set optlist [join $commands ", "]
	    set optlist [linsert $optlist "end-1" "or"]
	    error "bad option \"$cmd\": must be $optlist"
	}
	eval [list ::report::_$cmd $name] $args
    }
}

# ::report::CheckColumn --
#
#	Helper to check and transform column indices. Returns the
#	absolute index number belonging to the specified
#	index. Rejects indices out of the valid range of columns.
#
# Arguments:
#	columns Number of columns
#	column	The incoming index to check and transform
#
# Results:
#	The absolute index to the column

proc ::report::CheckColumn {columns column} {
    switch -regex -- $column {
	{end-[0-9]+} {
	    regsub -- {end-} $column {} column
	    set cc [expr {$columns - 1 - $column}]
	    if {($cc < 0) || ($cc >= $columns)} {
		return -code error "column: index \"end-$column\" out of range"
	    }
	    return $cc
	}
	end {
	    if {$columns <= 0} {
		return -code error "column: index \"$column\" out of range"
	    }
	    return [expr {$columns - 1}]
	}
	{[0-9]+} {
	    if {($column < 0) || ($column >= $columns)} {
		return -code error "column: index \"$column\" out of range"
	    }
	    return $column
	}
	default {
	    return -code error "column: syntax error in index \"$column\""
	}
    }
}

# ::report::CheckVerticals --
#
#	Internal helper. Used to check the consistency of all active
#	templates with respect to the generated vertical separators
#	(Same length).
#
# Arguments:
#	name	Name of the report object to check.
#
# Results:
#	None.

proc ::report::CheckVerticals {name} {
    upvar ::report::report${name}::vTemplate vTemplate
    upvar ::report::report${name}::enabled   enabled
    upvar ::report::report${name}::columns   columns
    upvar ::report::report${name}::tcaption  tcaption
    upvar ::report::report${name}::bcaption  bcaption

    for {set c 0} {$c <= $columns} {incr c} {
	# Collect all lengths for a column in a list, sort that and
	# compare first against last element. If they are not equal we
	# have found an inconsistent definition.

	set     res [list]
	lappend res [string length $vTemplate(data,$c)]

	if {$tcaption > 0} {
	    lappend res [string length $vTemplate(topdata,$c)]
	    if {($tcaption > 1) && $enabled(topdatasep)} {
		lappend res [string length $vTemplate(topdatasep,$c)]
	    }
	    if {$enabled(topcapsep)} {
		lappend res [string length $vTemplate(topcapsep,$c)]
	    }
	}
	if {$bcaption > 0} {
	    lappend res [string length $vTemplate(botdata,$c)]
	    if {($bcaption > 1) && $enabled(botdatasep)} {
		lappend res [string length $vTemplate(botdatasep,$c)]
	    }
	    if {$enabled(botcapsep)} {
		lappend res [string length $vTemplate(botcapsep,$c)]
	    }
	}
	foreach t {top datasep bottom} {
	    if {$enabled($t)} {
		lappend res [string length $vTemplate($t,$c)]
	    }
	}

	set res [lsort $res]

	if {[lindex $res 0] != [lindex $res end]} {
	    return -code error "inconsistent verticals in report"
	}
    }
}

# ::report::_tAction --
#
#	Implements the actions on templates (set, get, enable, disable, enabled)
#
# Arguments:
#	name		Name of the report object.
#	template	Name of the template to query or manipulate.
#	cmd		The action applied to the template
#	args		Additional arguments per action, see documentation.
#
# Results:
#	None.

proc ::report::_tAction {name template cmd args} {
    # When coming in here we know that $template contains a legal
    # template code. No need to check again. We need 'tcode'
    # nevertheless to distinguish between separator (1) and data
    # templates (0).

    variable tcode

    switch -exact -- $cmd {
	set {
	    if {[llength $args] != 1} {
		return -code error "Wrong # args: $name $template $cmd template"
	    }
	    set templval [lindex $args 0]

	    upvar ::report::report${name}::columns   columns
	    upvar ::report::report${name}::template  tpl
	    upvar ::report::report${name}::hTemplate hTemplate
	    upvar ::report::report${name}::vTemplate vTemplate
	    upvar ::report::report${name}::enabled   enabled	    

	    if {$tcode($template)} {
		# Separator template, expected size = 2*colums+1
		if {[llength $templval] > (2*$columns+1)} {
		    return -code error {template to long for number of columns in report}
		} elseif {[llength $templval] < (2*$columns+1)} {
		    return -code error {template to short for number of columns in report}
		}

		set tpl($template) $templval

		set even 1
		set c1   0
		set c2   0
		foreach item $templval {
		    if {$even} {
			set vTemplate($template,$c1) $item
			incr c1
			set even 0
		    } else {
			set hTemplate($template,$c2) $item
			incr c2
			set even 1
		    }
		}
	    } else {
		# Data template, expected size = columns+1
		if {[llength $templval] > ($columns+1)} {
		    return -code error {template to long for number of columns in report}
		} elseif {[llength $templval] < ($columns+1)} {
		    return -code error {template to short for number of columns in report}
		}

		set tpl($template) $templval

		set c 0
		foreach item $templval {
		    set vTemplate($template,$c) $item
		    incr c
		}
	    }
	    if {$enabled($template)} {
		# Perform checks for active separator templates and
		# all data templates.
		CheckVerticals $name
	    }
	}
	get -
	enable -
	disable -
	enabled {
	    if {[llength $args] > 0} {
		return -code error "Wrong # args: $name $template $cmd"
	    }
	    switch -exact -- $cmd {
		get {
		    upvar ::report::report${name}::template  tpl
		    return $tpl($template)
		}
		enable {
		    if {!$tcode($template)} {
			# Data template, can't be enabled.
			return -code error "Cannot enable data template \"$template\""
		    }

		    upvar ::report::report${name}::enabled enabled

		    if {!$enabled($template)} {
			set enabled($template) 1
			CheckVerticals $name
		    }

		}
		disable {
		    if {!$tcode($template)} {
			# Data template, can't be disabled.
			return -code error "Cannot disable data template \"$template\""
		    }

		    upvar ::report::report${name}::enabled enabled
		    if {$enabled($template)} {
			set enabled($template) 0
		    }
		}
		enabled {
		    if {!$tcode($template)} {
			# Data template, can't be disabled.
			return -code error "Cannot query state of data template \"$template\""
		    }

		    upvar ::report::report${name}::enabled enabled
		    return $enabled($template)
		}
		default {error "Can't happen, panic, run, shout"}
	    }
	}
	default {
	    return -code error "Unknown template command \"$cmd\""
	}
    }
    return ""
}

# ::report::_tcaption --
#
#	Sets or queries the size of the top caption region of the report.
#
# Arguments:
#	name	Name of the report object.
#	size	The new size, if not empty. Emptiness indicates that a
#		query was requested
#
# Results:
#	None, or the current size of the top caption region

proc ::report::_tcaption {name {size {}}} {
    upvar ::report::report${name}::tcaption tcaption

    if {$size == {}} {
	return $tcaption
    }
    if {![string is integer $size]} {
	return -code error "size: expected integer greater than or equal to zero, got \"$size\""
    }
    if {$size < 0} {
	return -code error "size: expected integer greater than or equal to zero, got \"$size\""
    }
    if {$size == $tcaption} {
	# No change, nothing to do
	return ""
    }
    if {($size > 0) && ($tcaption == 0)} {
	# Perform a consistency check after the assignment, the
	# template might have been changed.
	set tcaption $size
	CheckVerticals $name
    } else {
	set tcaption $size
    }
    return ""
}

# ::report::_bcaption --
#
#	Sets or queries the size of the bottom caption region of the report.
#
# Arguments:
#	name	Name of the report object.
#	size	The new size, if not empty. Emptiness indicates that a
#		query was requested
#
# Results:
#	None, or the current size of the bottom caption region

proc ::report::_bcaption {name {size {}}} {
    upvar ::report::report${name}::bcaption bcaption

    if {$size == {}} {
	return $bcaption
    }
    if {![string is integer $size]} {
	return -code error "size: expected integer greater than or equal to zero, got \"$size\""
    }
    if {$size < 0} {
	return -code error "size: expected integer greater than or equal to zero, got \"$size\""
    }
    if {$size == $bcaption} {
	# No change, nothing to do
	return ""
    }
    if {($size > 0) && ($bcaption == 0)} {
	# Perform a consistency check after the assignment, the
	# template might have been changed.
	set bcaption $size
	CheckVerticals $name
    } else {
	set bcaption $size
    }
    return ""
}

# ::report::_size --
#
#	Sets or queries the size of the specified column.
#
# Arguments:
#	name	Name of the report object.
#	column	Index of the column to manipulate or query
#	size	The new size, if not empty. Emptiness indicates that a
#		query was requested
#
# Results:
#	None, or the current size of the column

proc ::report::_size {name column {size {}}} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::csize   csize

    set column [CheckColumn $columns $column]

    if {$size == {}} {
	return $csize($column)
    }
    if {[string equal $size dyn]} {
	set csize($column) $size
	return ""
    }
    if {![string is integer $size]} {
	return -code error "expected integer greater than zero, got \"$size\""
    }
    if {$size <= 0} {
	return -code error "expected integer greater than zero, got \"$size\""
    }
    set csize($column) $size
    return ""
}

# ::report::_sizes --
#
#	Sets or queries the sizes of all columns.
#
# Arguments:
#	name	Name of the report object.
#	sizes	The new sizes, if not empty. Emptiness indicates that a
#		query was requested
#
# Results:
#	None, or a list containing the sizes of all columns.

proc ::report::_sizes {name {sizes {}}} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::csize   csize

    if {$sizes == {}} {
	set res [list]
	foreach k [lsort -integer [array names csize]] {
	    lappend res $csize($k)
	}
	return $res
    }
    if {[llength $sizes] != $columns} {
	return -code error "Wrong # number of column sizes"
    }
    foreach size $sizes {
	if {[string equal $size dyn]} {
	    continue
	}
	if {![string is integer $size]} {
	    return -code error "expected integer greater than zero, got \"$size\""
	}
	if {$size <= 0} {
	    return -code error "expected integer greater than zero, got \"$size\""
	}
    }

    set i 0
    foreach s $sizes {
	set csize($i) $s
	incr i
    }
    return ""
}

# ::report::_pad --
#
#	Sets or queries the padding for the specified column.
#
# Arguments:
#	name	Name of the report object.
#	column	Index of the column to manipulate or query
#	where	Where to place the padding. Emptiness indicates
#		that a query was requested.
#
# Results:
#	None, or the padding for the specified column.

proc ::report::_pad {name column {where {}} {string { }}} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::lpad   lpad
    upvar ::report::report${name}::rpad   rpad

    set column [CheckColumn $columns $column]

    if {$where == {}} {
	return [list $lpad($column) $rpad($column)]
    }

    switch -exact -- $where {
	left {
	    set lpad($column) $string
	}
	right {
	    set rpad($column) $string
	}
	both {
	    set lpad($column) $string
	    set rpad($column) $string
	}
	default {
	    return -code error "where: expected left, right, or both, got \"$where\""
	}
    }
    return ""
}

# ::report::_justify --
#
#	Sets or queries the justification for the specified column.
#
# Arguments:
#	name	Name of the report object.
#	column	Index of the column to manipulate or query
#	jvalue	Justification to set. Emptiness indicates
#		that a query was requested
#
# Results:
#	None, or the current justication for the specified column

proc ::report::_justify {name column {jvalue {}}} {
    upvar ::report::report${name}::columns columns
    upvar ::report::report${name}::cjust   cjust

    set column [CheckColumn $columns $column]

    if {$jvalue == {}} {
	return $cjust($column)
    }
    switch -exact -- $jvalue {
	left - right - center {
	    set cjust($column) $jvalue
	    return ""
	}
	default {
	    return -code error "justification: expected, left, right, or center, got \"$jvalue\""
	}
    }
}

# ::report::_printmatrix --
#
#	Format the specified matrix according to the configuration of
#	the report.
#
# Arguments:
#	name	Name of the report object.
#	matrix	Name of the matrix object to format.
#
# Results:
#	A string containing the formatted matrix.

proc ::report::_printmatrix {name matrix} {
    CheckMatrix $name $matrix
    ColumnSizes $name $matrix state

    upvar ::report::report${name}::tcaption tcaption
    upvar ::report::report${name}::bcaption bcaption

    set    row 0
    set    out ""
    append out [Separator top $name $matrix state]
    if {$tcaption > 0} {
	set n $tcaption
	while {$n > 0} {
	    append out [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]]
	    if {$n > 1} {
		append out [Separator topdatasep $name $matrix state]
	    }
	    incr n -1
	    incr row
	}
	append out [Separator topcapsep $name $matrix state]
    }

    set n [expr {[$matrix rows] - $bcaption}]

    while {$row < $n} {
	append out [FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]]
	incr row
	if {$row < $n} {
	    append out [Separator datasep $name $matrix state]
	}
    }

    if {$bcaption > 0} {
	append out [Separator botcapsep $name $matrix state]
	set n $bcaption
	while {$n > 0} {
	    append out [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]]
	    if {$n > 1} {
		append out [Separator botdatasep $name $matrix state]
	    }
	    incr n -1
	    incr row
	}
    }

    append out [Separator bottom $name $matrix state]

    #parray state
    return $out
}

# ::report::_printmatrix2channel --
#
#	Format the specified matrix according to the configuration of
#	the report.
#
# Arguments:
#	name	Name of the report.
#	matrix	Name of the matrix object to format.
#	chan	Handle of the channel to write the formatting result into.
#
# Results:
#	None.

proc ::report::_printmatrix2channel {name matrix chan} {
    CheckMatrix $name $matrix
    ColumnSizes $name $matrix state

    upvar ::report::report${name}::tcaption tcaption
    upvar ::report::report${name}::bcaption bcaption

    set    row 0
    puts -nonewline $chan [Separator top $name $matrix state]
    if {$tcaption > 0} {
	set n $tcaption
	while {$n > 0} {
	    puts -nonewline $chan \
		    [FormatData topdata $name state [$matrix get row $row] [$matrix rowheight $row]]
	    if {$n > 1} {
		puts -nonewline $chan [Separator topdatasep $name $matrix state]
	    }
	    incr n -1
	    incr row
	}
	puts -nonewline $chan [Separator topcapsep $name $matrix state]
    }

    set n [expr {[$matrix rows] - $bcaption}]

    while {$row < $n} {
	puts -nonewline $chan \
		[FormatData data $name state [$matrix get row $row] [$matrix rowheight $row]]
	incr row
	if {$row < $n} {
	    puts -nonewline $chan [Separator datasep $name $matrix state]
	}
    }

    if {$bcaption > 0} {
	puts -nonewline $chan [Separator botcapsep $name $matrix state]
	set n $bcaption
	while {$n > 0} {
	    puts -nonewline $chan \
		    [FormatData botdata $name state [$matrix get row $row] [$matrix rowheight $row]]
	    if {$n > 1} {
		puts -nonewline $chan [Separator botdatasep $name $matrix state]
	    }
	    incr n -1
	    incr row
	}
    }

    puts -nonewline $chan [Separator bottom $name $matrix state]
    return
}

# ::report::_columns --
#
#	Retrieves the number of columns in the report.
#
# Arguments:
#	name	Name of the report queried
#
# Results:
#	A number

proc ::report::_columns {name} {
    upvar ::report::report${name}::columns columns
    return $columns
}

# ::report::_destroy --
#
#	Destroy a report, including its associated command and data storage.
#
# Arguments:
#	name	Name of the report to destroy.
#
# Results:
#	None.

proc ::report::_destroy {name} {
    namespace delete ::report::report$name
    interp alias {} ::$name {}
    return
}

# ::report::CheckMatrix --
#
#	Internal helper for the "print" methods. Checks that the
#	supplied matrix can be formatted by the specified report.
#
# Arguments:
#	name	Name of the report to use for the formatting
#	matrix	Name of the matrix to format.
#
# Results:
#	None, or an error in case of problems.

proc ::report::CheckMatrix {name matrix} {
    upvar ::report::report${name}::columns  columns
    upvar ::report::report${name}::tcaption tcaption
    upvar ::report::report${name}::bcaption bcaption

    if {$columns != [$matrix columns]} {
	return -code error "report/matrix mismatch in number of columns"
    }
    if {($tcaption + $bcaption) > [$matrix rows]} {
	return -code error "matrix too small, top and bottom captions overlap"
    }
}

# ::report::ColumnSizes --
#
#	Internal helper for the "print" methods. Computes the final
#	column sizes (with and without padding) and stores them in
#	the print-state
#
# Arguments:
#	name		Name of the report used for the formatting
#	matrix		Name of the matrix to format.
#	statevar	Name of the array variable holding the state
#			of the formatter.
#
# Results:
#	None.

proc ::report::ColumnSizes {name matrix statevar} {
    # Calculate the final column sizes with and without padding and
    # store them in the local state.

    upvar $statevar state

    upvar ::report::report${name}::columns  columns
    upvar ::report::report${name}::csize    csize
    upvar ::report::report${name}::lpad     lpad
    upvar ::report::report${name}::rpad     rpad

    for {set c 0} {$c < $columns} {incr c} {
	if {[string equal dyn $csize($c)]} {
	    set size [$matrix columnwidth $c]
	} else {
	    set size $csize($c)
	}

	set state(s,$c) $size

	incr size [string length $lpad($c)]
	incr size [string length $rpad($c)]

	set state(s/pad,$c) $size
    }

    return
}

# ::report::Separator --
#
#	Internal helper for the "print" methods. Computes the final
#	shape of the various separators using the column sizes with
#	padding found in the print state. Uses also the print state as
#	a cache to avoid costly recomputation for the separators which
#	are used multiple times.
#
# Arguments:
#	tcode		Code of the separator to compute / template to use
#	name		Name of the report used for the formatting
#	matrix		Name of the matrix to format.
#	statevar	Name of the array variable holding the state
#			of the formatter.
#
# Results:
#	The final separator string. Empty for disabled separators.

proc ::report::Separator {tcode name matrix statevar} {
    upvar ::report::report${name}::enabled  e
    if {!$e($tcode)} {return ""}
    upvar $statevar state
    if {![info exists state($tcode)]} {
	upvar ::report::report${name}::vTemplate vt
	upvar ::report::report${name}::hTemplate ht
	upvar ::report::report${name}::columns   cs
	set str ""
	for {set c 0} {$c < $cs} {incr c} {
	    append str $vt($tcode,$c)
	    set fill $ht($tcode,$c)
	    set flen [string length $fill]
	    set rep  [expr {($state(s/pad,$c)/$flen)+1}]
	    append str [string range [string repeat $fill $rep] 0 [expr {$state(s/pad,$c)-1}]]
	}
	append str $vt($tcode,$cs)
	set state($tcode) $str
    }
    return $state($tcode)\n
}

# ::report::FormatData --
#
#	Internal helper for the "print" methods. Computes the output
#	for one row in the matrix, given its values, the rowheight,
#	padding and justification.
#
# Arguments:
#	tcode		Code of the data template to use
#	name		Name of the report used for the formatting
#	statevar	Name of the array variable holding the state
#			of the formatter.
#	line		List containing the values to format
#	rh		Height of the row (line) in lines.
#
# Results:
#	The formatted string for the supplied row.

proc ::report::FormatData {tcode name statevar line rh} {
    upvar $statevar state
    upvar ::report::report${name}::vTemplate vt
    upvar ::report::report${name}::columns   cs
    upvar ::report::report${name}::lpad      lpad
    upvar ::report::report${name}::rpad      rpad
    upvar ::report::report${name}::cjust     cjust

    if {$rh == 1} {
	set str ""
	set c 0
	foreach cell $line {
	    # prefix, cell (pad-l, value, pad-r)
	    append str $vt($tcode,$c)$lpad($c)[FormatCell $cell $state(s,$c) $cjust($c)]$rpad($c)
	    incr c
	}
	append str $vt($tcode,$cs)\n
	return $str
    } else {
	array set str {}
	for {set l 1} {$l <= $rh} {incr l} {set str($l) ""}

	# - Future - Vertical justification of cells less tall than rowheight
	# - Future - Vertical cutff aftert n lines, auto-repeat of captions
	# - Future - => Higher level, not here, use virtual matrices for this
	# - Future -  and count the generated lines

	set c 0
	foreach fcell $line {
	    set fcell [split $fcell \n]
	    for {set l 1; set lo 0} {$l <= $rh} {incr l; incr lo} {
		append str($l) $vt($tcode,$c)$lpad($c)[FormatCell \
			[lindex $fcell $lo] $state(s,$c) $cjust($c)]$rpad($c)
	    }
	    incr c
	}
	set strout ""
	for {set l 1} {$l <= $rh} {incr l} {
	    append strout $str($l)$vt($tcode,$cs)\n
	}
	return $strout
    }
}

# ::report::FormatCell --
#
#	Internal helper for the "print" methods. Formats the value of
#	a single cell according to column size and justification.
#
# Arguments:
#	value	The value to format
#	size	The size of the column, without padding
#	just	The justification for the current cell/column
#
# Results:
#	The formatted string for the supplied cell.

proc ::report::FormatCell {value size just} {
    set vlen [string length $value]

    if {$vlen == $size} {
	# Value fits exactly, justification is irrelevant
	return $value
    }

    # - Future - Other fill characters ...
    # - Future - Different fill characters per class of value => regex/glob pattern|functions
    # - Future - Wraparound - interacts with rowheight!

    switch -exact -- $just {
	left {
	    if {$vlen < $size} {
		return $value[string repeat " " [expr {$size - $vlen}]]
	    }
	    return [string range $value [expr {$vlen - $size}] end]
	}
	right {
	    if {$vlen < $size} {
		return [string repeat " " [expr {$size - $vlen}]]$value
	    }
	    incr size -1
	    return [string range $value 0 $size]
	}
	center {
	    if {$vlen < $size} {
		set fill  [expr {$size - $vlen}]
		set rfill [expr {$fill / 2}]
		set lfill [expr {$fill - $rfill}]
		return [string repeat " " $lfill]$value[string repeat " " $rfill]
	    }

	    set cut  [expr {$vlen - $size}]
	    set lcut [expr {$cut / 2}]
	    set rcut [expr {$cut - $lcut}]

	    return [string range $value $lcut end-$rcut]
	}
	default {
	    error "Can't happen, panic, run, shout"
	}
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/report/report.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
# -*- tcl -*-
# report.test:  tests for the report 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 by Andreas Kupries <[email protected]>
# All rights reserved.
#
# RCS: @(#) $Id: report.test,v 1.3 2002/02/02 01:07:51 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require report
package require struct
puts "report [package present report]"
puts "- struct  [package present struct]"

namespace import ::report::report

# styles .............................................................

test report-1.0 {styles introspection} {
    ::report::styles
} {plain}

test report-1.1 {styles introspection} {
    set     result [list]
    lappend result [::report::styles]
    ::report::defstyle foo {a b} {bla}
    lappend result [::report::styles]
    ::report::rmstyle foo
    lappend result [::report::styles]
    set result
} {plain {plain foo} plain}


test report-2.0 {style definition errors} {
    catch {::report::defstyle} result
    set result
} [tcltest::getErrorMessage "::report::defstyle" "styleName arguments body" 0]

test report-2.1 {style definition error} {
    catch {::report::defstyle foo} result
    set result
} [tcltest::getErrorMessage "::report::defstyle" "styleName arguments body" 1]

test report-2.2 {style definition errors} {
    catch {::report::defstyle foo {}} result
    set result
} [tcltest::getErrorMessage "::report::defstyle" "styleName arguments body" 2]

test report-2.3 {style definition errors} {
    catch {::report::defstyle foo {} {} bla} result
    set result
} [if {[info tclversion] < 8.4} {
    set msg {called "::report::defstyle" with too many arguments}
} else {
    set msg {wrong # args: should be "::report::defstyle styleName arguments body"}
}]

test report-2.4 {style definition errors} {
    catch {::report::defstyle plain {} {}} result
    set result
} {Cannot create style "plain", already exists}

test report-2.5 {style definition error} {
    catch {::report::defstyle foo {{a default} b} {}} result
    set result
} {Found argument without default after arguments having defaults}

test report-2.6 {style definition error} {
    catch {::report::defstyle foo {a {a b c}} {}} result
    set result
} {Illegal length of value "a b c"}

test report-2.7 {style definition error} {
    catch {::report::defstyle foo {a {}} {}} result
    set result
} {Illegal length of value ""}


test report-3.0 {style deletion errors} {
    catch {::report::rmstyle} result
    set result
} [tcltest::getErrorMessage "::report::rmstyle" "styleName" 0]

test report-3.1 {style deletion errors} {
    catch {::report::rmstyle plain} result
    set result
} {cannot delete builtin style "plain"}

test report-3.2 {style deletion errors} {
    catch {::report::rmstyle foo} result
    set result
} {cannot delete unknown style "foo"}


test report-4.0 {style introspection error} {
    catch {::report::stylearguments} result
    set result
} [tcltest::getErrorMessage "::report::stylearguments" "styleName" 0]

test report-4.1 {style introspection error} {
    catch {::report::stylearguments foo} result
    set result
} {style "foo" is not known}

test report-4.2 {style introspection error} {
    catch {::report::stylebody} result
    set result
} [tcltest::getErrorMessage "::report::stylebody" "styleName" 0]

test report-4.3 {style introspection error} {
    catch {::report::stylebody foo} result
    set result
} {style "foo" is not known}

test report-4.4 {style introspection} {
    ::report::defstyle foo {a b} {bar}
    set     result [list]
    lappend result [::report::stylearguments foo]
    lappend result [::report::stylebody      foo]
    ::report::rmstyle foo
    set result
} {{a b} bar}

test report-4.5 {style introspection} {
    ::report::defstyle foo {a args} {bar}
    set     result [list]
    lappend result [::report::stylearguments foo]
    lappend result [::report::stylebody      foo]
    ::report::rmstyle foo
    set result
} {{a args} bar}

test report-4.6 {style introspection} {
    set     result [list]
    lappend result [::report::stylearguments plain]
    lappend result [::report::stylebody      plain]
    set result
} {{} {}}

# Define now two generally useful styles.
# They are used in the following tests.
# ---------------------------------------

::report::defstyle simpletable {} {
    data   set [split "[string repeat "| "   [columns]]|"]
    top    set [split "[string repeat "+ - " [columns]]+"]
    bottom set [top get]
    top	   enable
    bottom enable
}
::report::defstyle captionedtable {{n 1}} {
    simpletable
    topdata   set [data get]
    topcapsep set [top  get]
    topcapsep enable
    tcaption $n
}
::report::defstyle bcaptionedtable {{n 1}} {
    simpletable
    topdata   set [data get]
    topcapsep set [top  get]
    topcapsep enable
    tcaption $n
    botdata   set [data   get]
    botcapsep set [bottom get]
    botcapsep enable
    bcaption $n
}
::report::defstyle bdcaptionedtable {{n 1}} {
    simpletable
    topdata    set [data get]
    topcapsep  set [top  get]
    topdatasep set [top  get]
    topcapsep  enable
    topdatasep enable
    tcaption $n
    botdata    set [data   get]
    botcapsep  set [bottom get]
    botdatasep set [top  get]
    botcapsep  enable
    botdatasep enable
    bcaption $n
}

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

test report-5.0 {style application errors} {
    catch {report myreport 3 style} result
    set result
} {wrong # args: report name columns ?"style" styleName ?arg...??}

test report-5.1 {style application errors} {
    catch {report myreport 3 blarg foo ...} result
    set result
} {wrong # args: report name columns ?"style" styleName ?arg...??}

test report-5.2 {style application errors} {
    catch {report myreport 3 style foo} result
    set result
} {style "foo" is not known}

test report-5.3 {style application errors} {
    ::report::defstyle foo {a b} {}
    catch {report myreport 3 style foo} result
    ::report::rmstyle foo
    set result
} {no value given for parameter "a" to style "foo"}

# [tcltest::getErrorMessage "foo" "a b" 0]

test report-5.4 {style application errors} {
    ::report::defstyle foo {a b} {}
    catch {report myreport 5 style foo a b c d e} result
    ::report::rmstyle foo
    set result
} {called style "foo" with too many arguments}

test report-5.5 {style application} {
    report myreport 3 style simpletable

    set     result [list]
    lappend result [myreport data get]
    lappend result [myreport top get]
    lappend result [myreport bottom get]
    lappend result [myreport topcapsep get]
    lappend result [myreport top enabled]
    lappend result [myreport bottom enabled]
    lappend result [myreport topcapsep enabled]

    myreport destroy
    set result
} {{| | | |} {+ - + - + - +} {+ - + - + - +} {{} {} {} {} {} {} {}} 1 1 0}

test report-5.6 {style application} {

    set result [list]
    ::report::defstyle foo {a b args} {
	# Hack to transfer information out of the safe interp to the
	# test environment.
	botcapsep set [list $a $b $args]
    }
    report mr 1 style foo A B       ; lappend result [mr botcapsep get]
    mr destroy
    report mr 1 style foo A B C     ; lappend result [mr botcapsep get]
    mr destroy
    report mr 1 style foo A B C D E ; lappend result [mr botcapsep get]
    mr destroy
    ::report::rmstyle foo

    set result
} {{A B {}} {A B C} {A B {C D E}}}


# reports .............................................................

test report-6.0 {report errors} {
    catch {report myreport} msg
    set msg
} [tcltest::getErrorMessage "report" "name columns args" 1]

test report-6.1 {report errors} {
    catch {report myreport -5} msg
    set msg
} {columns: expected integer greater than zero, got "-5"}

test report-6.2 {report errors} {
    catch {report myreport 0} msg
    set msg
} {columns: expected integer greater than zero, got "0"}

test report-6.3 {report errors} {
    catch {report myreport foo} msg
    set msg
} {columns: expected integer greater than zero, got "foo"}

test report-6.4 {report errors} {
    catch {report set 4} msg
    set msg
} "command \"set\" already exists, unable to create report"

test report-6.5 {report errors} {
    report myreport 3
    catch {report myreport 3} msg
    myreport destroy
    set msg
} "command \"myreport\" already exists, unable to create report"

test report-6.6 {report errors} {
    catch {report myreport 3 foo} msg
    set msg
} {wrong # args: report name columns ?"style" styleName ?arg...??}

# report methods ......................................................

test report-7.0 {report method errors} {
    report myreport 3
    catch {myreport} msg
    myreport destroy
    set msg
} "wrong # args: should be \"myreport option ?arg arg ...?\""

test report-7.1 {report errors} {
    report myreport 3
    catch {myreport foo} msg
    myreport destroy
    set msg
} "bad option \"foo\": must be bcaption, botcapsep, botdata, botdatasep, bottom, columns, data, datasep, justify, pad, printmatrix, printmatrix2channel, size, sizes, tcaption, top, topcapsep, topdata, or topdatasep"

foreach {n m} {
    8 tcaption
    9 bcaption
} {
    test report-$n.0 {captions} {
	report myreport 3
	set result [myreport $m]
	myreport $m 5
	lappend result [myreport $m]
	myreport $m 0
	lappend result [myreport $m]
	myreport $m 0
	lappend result [myreport $m]
	myreport destroy
	set result
    } {0 5 0 0}

    test report-$n.1 {captions} {
	report myreport 3
	catch [list myreport $m -1] result
	myreport destroy
	set result
    } {size: expected integer greater than or equal to zero, got "-1"}

    test report-$n.2 {captions} {
	report myreport 3
	catch [list myreport $m foo] result
	myreport destroy
	set result
    } {size: expected integer greater than or equal to zero, got "foo"}
}

test report-10.0 {column sizes} {
    report myreport 3
    catch {myreport size} result
    myreport destroy
    set result
} [tcltest::getErrorMessage "::report::_size" "name column ?size?" 1]

test report-10.1 {column sizes} {
    report myreport 3
    catch {myreport size -1} result
    myreport destroy
    set result
} {column: index "-1" out of range}

test report-10.2 {column sizes} {
    report myreport 3
    catch {myreport size foo} result
    myreport destroy
    set result
} {column: syntax error in index "foo"}

test report-10.3 {column sizes} {
    report myreport 3
    catch {myreport size 4} result
    myreport destroy
    set result
} {column: index "4" out of range}

test report-10.4 {column sizes} {
    report myreport 3
    catch {myreport size end-5} result
    myreport destroy
    set result
} {column: index "end-5" out of range}

test report-10.5 {column sizes} {
    report myreport 3
    catch {myreport size 0 foo} result
    myreport destroy
    set result
} {expected integer greater than zero, got "foo"}

test report-10.6 {column sizes} {
    report myreport 3
    catch {myreport size 0 0} result
    myreport destroy
    set result
} {expected integer greater than zero, got "0"}

test report-10.7 {column sizes} {
    report myreport 3
    catch {myreport size 0 -4} result
    myreport destroy
    set result
} {expected integer greater than zero, got "-4"}

test report-10.8 {column sizes} {
    report myreport 3
    set result [myreport size 0]
    myreport size 0 5
    lappend result [myreport size 0]
    myreport destroy
    set result
} {dyn 5}

test report-10.9 {column sizes} {
    report myreport 3
    set result [myreport size 0]
    myreport size 0 5
    lappend result [myreport size 0]
    myreport size 0 dyn
    lappend result [myreport size 0]
    myreport destroy
    set result
} {dyn 5 dyn}


test report-11.0 {column sizes} {
    report myreport 3
    catch {myreport sizes 1} result
    myreport destroy
    set result
} {Wrong # number of column sizes}

test report-11.1 {column sizes} {
    report myreport 3
    catch {myreport sizes {1 2 3 4}} result
    myreport destroy
    set result
} {Wrong # number of column sizes}

test report-11.2 {column sizes} {
    report myreport 3
    catch {myreport sizes {2 0 dyn}} result
    myreport destroy
    set result
} {expected integer greater than zero, got "0"}

test report-11.3 {column sizes} {
    report myreport 3
    catch {myreport sizes {2 foo dyn}} result
    myreport destroy
    set result
} {expected integer greater than zero, got "foo"}

test report-11.4 {column sizes} {
    report myreport 3
    catch {myreport sizes {2 -5 dyn}} result
    myreport destroy
    set result
} {expected integer greater than zero, got "-5"}

test report-11.5 {column sizes} {
    report myreport 3
    set result [list [myreport sizes]]
    myreport sizes {2 dyn 5}
    lappend result [myreport sizes]
    myreport destroy
    set result
} {{dyn dyn dyn} {2 dyn 5}}


test report-12.0 {padding} {
    report myreport 3
    catch {myreport pad} result
    myreport destroy
    set result
} [tcltest::getErrorMessage "::report::_pad" "name column ?where? ?string?" 1]

test report-12.1 {padding} {
    report myreport 3
    catch {myreport pad -1} result
    myreport destroy
    set result
} {column: index "-1" out of range}

test report-12.2 {padding} {
    report myreport 3
    catch {myreport pad foo} result
    myreport destroy
    set result
} {column: syntax error in index "foo"}

test report-12.3 {padding} {
    report myreport 3
    catch {myreport pad 4} result
    myreport destroy
    set result
} {column: index "4" out of range}

test report-12.4 {padding} {
    report myreport 3
    catch {myreport pad end-5} result
    myreport destroy
    set result
} {column: index "end-5" out of range}

test report-12.5 {padding} {
    report myreport 3
    catch {myreport pad 0 foo} result
    myreport destroy
    set result
} {where: expected left, right, or both, got "foo"}

test report-12.6 {padding} {
    report myreport 3
    set result [list [myreport pad 0]]
    myreport pad 0 left
    myreport pad 0 right =
    lappend result [myreport pad 0]
    myreport pad 0 both _
    lappend result [myreport pad 0]
    myreport destroy
    set result
} {{{} {}} {{ } =} {_ _}}


test report-13.0 {justification} {
    report myreport 3
    catch {myreport justify} result
    myreport destroy
    set result
} [tcltest::getErrorMessage "::report::_justify" "name column ?jvalue?" 1]

test report-13.1 {justification} {
    report myreport 3
    catch {myreport justify -1} result
    myreport destroy
    set result
} {column: index "-1" out of range}

test report-13.2 {justification} {
    report myreport 3
    catch {myreport justify foo} result
    myreport destroy
    set result
} {column: syntax error in index "foo"}

test report-13.3 {justification} {
    report myreport 3
    catch {myreport justify 4} result
    myreport destroy
    set result
} {column: index "4" out of range}

test report-13.4 {justification} {
    report myreport 3
    catch {myreport justify end-5} result
    myreport destroy
    set result
} {column: index "end-5" out of range}

test report-13.5 {justification} {
    report myreport 3
    catch {myreport justify 0 bla} result
    myreport destroy
    set result
} {justification: expected, left, right, or center, got "bla"}

test report-13.6 {justification} {
    report myreport 3
    set result [myreport justify 0]
    myreport justify 0 right
    lappend result [myreport justify 0]
    myreport justify 0 center
    lappend result [myreport justify 0]
    myreport destroy
    set result
} {left right center}


test report-14.0 {columns} {
    report myreport 3
    set result [myreport columns]
    myreport destroy
    set result
} 3

foreach {n template} {
    15 top
    16 topdatasep
    17 topcapsep
    18 datasep
    19 botcapsep
    20 botdatasep
    21 bottom
} {
    test report-$n.0 {separator templates} {
	report myreport 1
	catch [list myreport $template] result
	myreport destroy
	set result
    } [tcltest::getErrorMessage "::report::_tAction" "name template cmd args" 2]

    test report-$n.1 {separator templates} {
	report myreport 1
	set result [myreport $template enabled]
	myreport destroy
	set result
    } 0

    test report-$n.2 {separator templates} {
	report myreport 1
	myreport $template enable
	set result [myreport $template enabled]
	myreport $template disable
	lappend result [myreport $template enabled]
	myreport destroy
	set result
    } {1 0}

    test report-$n.3 {separator templates} {
	report myreport 3
	set result [list [myreport $template get]]
	myreport $template set {+ = + = + = +}
	lappend result [myreport $template get]
	myreport destroy
	set result
    } {{{} {} {} {} {} {} {}} {+ = + = + = +}}

    test report-$n.4 {consistency checking} {
	report myreport 3
	catch [list myreport $template set {}] result
	myreport destroy
	set result
    } {template to short for number of columns in report}

    test report-$n.5 {consistency checking} {
	report myreport 3
	catch [list myreport $template set {+ - + - + - + - +}] result
	myreport destroy
	set result
    } {template to long for number of columns in report}

    test report-$n.6 {templates} {
	report myreport 3
	catch [list myreport $template set] result
	myreport destroy
	set result
    } [list Wrong # args: myreport $template set template]

    test report-$n.7 {templates} {
	report myreport 3
	catch [list myreport $template get foo] result
	myreport destroy
	set result
    } [list Wrong # args: myreport $template get]

    test report-$n.8 {templates} {
	report myreport 3
	catch [list myreport $template bla] result
	myreport destroy
	set result
    } {Unknown template command "bla"}

    test report-$n.9 {consistency checking} {
	report myreport 3
	myreport top    set  {+ - + - + - +}
	catch {myreport top enable} result
	myreport destroy
	set result
    } {inconsistent verticals in report}
}

foreach {n template} {
    22 topdata
    23 data
    24 botdata
} {
    test report-$n.0 {data templates} {
	report myreport 1
	catch [list myreport $template] result
	myreport destroy
	set result
    } [tcltest::getErrorMessage "::report::_tAction" "name template cmd args" 2]

    test report-$n.1 {data templates} {
	report myreport 1
	catch [list myreport $template enabled] result
	myreport destroy
	set result
    } "Cannot query state of data template \"$template\""

    test report-$n.2 {data templates} {
	report myreport 1
	catch [list myreport $template enable] result
	myreport destroy
	set result
    } "Cannot enable data template \"$template\""

    test report-$n.3 {data templates} {
	report myreport 1
	catch [list myreport $template disable] result
	myreport destroy
	set result
    } "Cannot disable data template \"$template\""

    test report-$n.4 {data templates} {
	report myreport 3
	set result [list [myreport $template get]]
	myreport $template set {+ + + +}
	lappend result [myreport $template get]
	myreport destroy
	set result
    } {{{} {} {} {}} {+ + + +}}

    test report-$n.5 {consistency checking} {
	report myreport 3
	catch [list myreport $template set {}] result
	myreport destroy
	set result
    } {template to short for number of columns in report}

    test report-$n.6 {consistency checking} {
	report myreport 3
	catch [list myreport data set {+ + + + +}] result
	myreport destroy
	set result
    } {template to long for number of columns in report}

    test report-$n.7 {templates} {
	report myreport 3
	catch [list myreport $template set] result
	myreport destroy
	set result
    } [list Wrong # args: myreport $template set template]

    test report-$n.8 {templates} {
	report myreport 3
	catch [list myreport $template get foo] result
	myreport destroy
	set result
    } [list Wrong # args: myreport $template get]

    test report-$n.9 {templates} {
	report myreport 3
	catch [list myreport $template bla] result
	myreport destroy
	set result
    } {Unknown template command "bla"}

}

foreach {n template cap} {
    25 topdata tcaption
    26 botdata bcaption
} {
    test report-$n.0 {consistency checking} {
	report myreport 3
	myreport $template set {-+ + + +-}
	catch [list myreport $cap 1] result
	myreport destroy
	set result
    } {inconsistent verticals in report}
}

# report execution, i.e. the actual formatting of a matrix ............

test report-27.0 {formatting errors} {
    report           myreport 5
    catch {myreport printmatrix} result
    myreport destroy
    set result
} [tcltest::getErrorMessage "::report::_printmatrix" "name matrix" 1]

test report-27.1 {formatting errors} {
    report           myreport 5
    ::struct::matrix mymatrix
    mymatrix      add columns 3
    catch {myreport printmatrix mymatrix} result
    mymatrix destroy
    myreport destroy
    set result
} {report/matrix mismatch in number of columns}

test report-27.2 {formatting errors} {
    report myreport 5
    ::struct::matrix mymatrix
    mymatrix add columns 8
    catch {myreport printmatrix mymatrix} result
    mymatrix destroy
    myreport destroy
    set result
} {report/matrix mismatch in number of columns}

test report-27.3 {formatting errors} {
    report myreport 5
    myreport tcaption 3
    myreport bcaption 4
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add rows 6
    catch {myreport printmatrix mymatrix} result
    mymatrix destroy
    myreport destroy
    set result
} {matrix too small, top and bottom captions overlap}

test report-27.4 {formatting} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    report myreport 5 ; # style plain
    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy

    set result
} {000VERSIONS:             2:8.4a31:8.4a31:8.4a3%
001CATCH return ok       7      13     53.85   
002CATCH return error    68     91     74.73   
003CATCH no catch used   7      14     50.00   
004IF if true numeric    12     33     36.36   
005IF elseif true numeric15     47     31.91   
}

test report-27.5 {formatting} {

    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    report myreport 5 style simpletable
    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy

    set result
} {+---+----------------------+-------+-------+--------+
|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   |
+---+----------------------+-------+-------+--------+
}

test report-27.6 {formatting} {

    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    report myreport 5 style captionedtable 1
    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy


    set result
} {+---+----------------------+-------+-------+--------+
|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   |
+---+----------------------+-------+-------+--------+
}

test report-27.7 {formatting} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    report myreport 5 ; # plain
    myreport top       set  {-+ -/ + -/ + -/ + -/ + -/ +-}
    myreport topdata   set {{ |}   |    |    |    |   {| }}
    myreport topcapsep set  {=+ *= + *= + *= + *= + *= +=}
    myreport data      set {{ |}   |    |    |    |   {| }}
    myreport bottom    set  {-+ -  + -  + -  + -  + -  +-}
    myreport top       enable
    myreport topcapsep enable
    myreport bottom    enable
    myreport tcaption 1
    myreport sizes {5 dyn 7 7 5}
    myreport pad     0 right
    myreport pad     1 both
    myreport pad     2 both
    myreport pad     3 both
    myreport pad     4 both
    myreport justify 0 center
    myreport justify 1 right
    myreport justify 2 right
    myreport justify 3 right
    myreport justify 3 right

    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy

    set result
} {-+-/-/-/+-/-/-/-/-/-/-/-/-/-/-/-/+-/-/-/-/-+-/-/-/-/-+-/-/-/-+-
 | 000  |              VERSIONS: | 2:8.4a3 | 1:8.4a3 | .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 | 
-+------+------------------------+---------+---------+-------+-
}

test report-27.7.1 {formatting} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    report myreport 5 ; # plain
    myreport top       set  {-+ -/ + -/ + -/ + -/ + -/ +-}
    myreport topdata   set {{ |}   |    |    |    |   {| }}
    myreport topcapsep set  {=+ *= + *= + *= + *= + *= +=}
    myreport data      set {{ |}   |    |    |    |   {| }}
    myreport bottom    set  {-+ -  + -  + -  + -  + -  +-}
    myreport top       enable
    myreport topcapsep enable
    myreport bottom    enable
    myreport tcaption 1
    myreport sizes {2 5 7 7 5}
    myreport pad     0 right
    myreport pad     1 both
    myreport pad     2 both
    myreport pad     3 both
    myreport pad     4 both
    myreport justify 0 center
    myreport justify 1 right
    myreport justify 2 right
    myreport justify 3 right
    myreport justify 3 right

    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy

    set result
} {-+-/-+-/-/-/-+-/-/-/-/-+-/-/-/-/-+-/-/-/-+-
 |00 | VERSI | 2:8.4a3 | 1:8.4a3 | .4a3% | 
=+*=*+*=*=*=*+*=*=*=*=*+*=*=*=*=*+*=*=*=*+=
 |00 | CATCH |       7 |      13 | 53.85 | 
 |00 | CATCH |      68 |      91 | 74.73 | 
 |00 | CATCH |       7 |      14 | 50.00 | 
 |00 | IF if |      12 |      33 | 36.36 | 
 |00 | IF el |      15 |      47 | 31.91 | 
-+---+-------+---------+---------+-------+-
}

test report-27.8 {formatting, rowheight > 1} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif
true numeric}    15      47    31.91}

    report myreport 5 style captionedtable 1
    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy

    set result
} {+---+-------------------+-------+-------+--------+
|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          |15     |47     |31.91   |
|   |true numeric       |       |       |        |
+---+-------------------+-------+-------+--------+
}

# And now all of above again, for printing into a channel.

tcltest::makeFile {} dummy
tcltest::makeFile {} rep1
tcltest::makeFile {} rep2
tcltest::makeFile {} rep3
tcltest::makeFile {} rep4
tcltest::makeFile {} rep5

test report-28.0 {formatting errors} {
    report           myreport 5
    catch {myreport printmatrix2channel} result
    myreport destroy
    set result
} [tcltest::getErrorMessage "::report::_printmatrix2channel" "name matrix chan" 1]

test report-28.1 {formatting errors} {
    report           myreport 5
    ::struct::matrix mymatrix
    catch {myreport printmatrix2channel mymatrix} result
    mymatrix destroy
    myreport destroy
    set result
} [tcltest::getErrorMessage "::report::_printmatrix2channel" "name matrix chan" 2]

test report-28.2 {formatting errors} {
    report           myreport 5
    ::struct::matrix mymatrix
    mymatrix      add columns 3

    set f [open dummy w]
    catch {myreport printmatrix2channel mymatrix $f} result
    mymatrix destroy
    myreport destroy
    close $f
    set result
} {report/matrix mismatch in number of columns}

test report-28.3 {formatting errors} {
    report myreport 5
    ::struct::matrix mymatrix
    mymatrix add columns 8
    set f [open dummy w]
    catch {myreport printmatrix2channel mymatrix $f} result
    mymatrix destroy
    myreport destroy
    close $f
    set result
} {report/matrix mismatch in number of columns}

test report-28.4 {formatting errors} {
    report myreport 5
    myreport tcaption 3
    myreport bcaption 4
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add rows 6
    set f [open dummy w]
    catch {myreport printmatrix2channel mymatrix $f} result
    mymatrix destroy
    myreport destroy
    close $f
    set result
} {matrix too small, top and bottom captions overlap}

test report-28.5 {formatting} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    set f [open rep1 w]
    report myreport 5 ; # style plain
    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep1
} {000VERSIONS:             2:8.4a31:8.4a31:8.4a3%
001CATCH return ok       7      13     53.85   
002CATCH return error    68     91     74.73   
003CATCH no catch used   7      14     50.00   
004IF if true numeric    12     33     36.36   
005IF elseif true numeric15     47     31.91   }

test report-28.6 {formatting} {

    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    set f [open rep2 w]
    report myreport 5 style simpletable
    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep2
} {+---+----------------------+-------+-------+--------+
|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   |
+---+----------------------+-------+-------+--------+}

test report-28.7 {formatting} {

    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    set f [open rep3 w]
    report myreport 5 style captionedtable 1
    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep3
} {+---+----------------------+-------+-------+--------+
|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   |
+---+----------------------+-------+-------+--------+}

test report-28.8 {formatting} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif true numeric}    15      47    31.91}

    set f [open rep4 w]
    report myreport 5 ; # plain
    myreport top       set  {-+ -/ + -/ + -/ + -/ + -/ +-}
    myreport topdata   set {{ |}   |    |    |    |   {| }}
    myreport topcapsep set  {=+ *= + *= + *= + *= + *= +=}
    myreport data      set {{ |}   |    |    |    |   {| }}
    myreport bottom    set  {-+ -  + -  + -  + -  + -  +-}
    myreport top       enable
    myreport topcapsep enable
    myreport bottom    enable
    myreport tcaption 1
    myreport sizes {5 dyn 7 7 5}
    myreport pad     0 right
    myreport pad     1 both
    myreport pad     2 both
    myreport pad     3 both
    myreport pad     4 both
    myreport justify 0 center
    myreport justify 1 right
    myreport justify 2 right
    myreport justify 3 right
    myreport justify 3 right

    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep4
} {-+-/-/-/+-/-/-/-/-/-/-/-/-/-/-/-/+-/-/-/-/-+-/-/-/-/-+-/-/-/-+-
 | 000  |              VERSIONS: | 2:8.4a3 | 1:8.4a3 | .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 | 
-+------+------------------------+---------+---------+-------+-}

test report-28.9 {formatting, rowheight > 1} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif
true numeric}    15      47    31.91}

    set f [open rep5 w]
    report myreport 5 style captionedtable 1
    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep5
} {+---+-------------------+-------+-------+--------+
|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          |15     |47     |31.91   |
|   |true numeric       |       |       |        |
+---+-------------------+-------+-------+--------+}



test report-28.10 {formatting, rowheight > 1} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif
true numeric}    15      47    31.91}

    set f [open rep5 w]
    report myreport 5 style captionedtable 2
    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep5
} {+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
|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          |15     |47     |31.91   |
|   |true numeric       |       |       |        |
+---+-------------------+-------+-------+--------+}

test report-28.11 {formatting, rowheight > 1} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif
true numeric}    15      47    31.91}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}

    set f [open rep5 w]
    report myreport 5 style bdcaptionedtable 2
    myreport printmatrix2channel mymatrix $f
    myreport destroy
    mymatrix destroy
    close $f

    ::tcltest::viewFile rep5
} {+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
+---+-------------------+-------+-------+--------+
|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          |15     |47     |31.91   |
|   |true numeric       |       |       |        |
+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
+---+-------------------+-------+-------+--------+}

test report-28.12 {formatting, rowheight > 1} {
    ::struct::matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {001 {CATCH return ok}            7      13    53.85}
    mymatrix add row {002 {CATCH return error}        68      91    74.73}
    mymatrix add row {003 {CATCH no catch used}        7      14    50.00}
    mymatrix add row {004 {IF if true numeric}        12      33    36.36}
    mymatrix add row {005 {IF elseif
true numeric}    15      47    31.91}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}
    mymatrix add row {000 VERSIONS:              2:8.4a3 1:8.4a3 1:8.4a3%}

    report myreport 5 style bdcaptionedtable 2
    set result [myreport printmatrix mymatrix]
    myreport destroy
    mymatrix destroy

    set result
} {+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
+---+-------------------+-------+-------+--------+
|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          |15     |47     |31.91   |
|   |true numeric       |       |       |        |
+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
+---+-------------------+-------+-------+--------+
|000|VERSIONS:          |2:8.4a3|1:8.4a3|1:8.4a3%|
+---+-------------------+-------+-------+--------+
}

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/sha1/ChangeLog.

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

	* pkgIndex.tcl:
	* sha1.man:
	* sha1.tcl: Fixed bug #614591. Set version of the package to to
	  1.0.3

2003-03-24  Andreas Kupries  <[email protected]>

	* sha1.tcl (sha1::sha1): Applied patch #637770 submitted by Donal
	  Fellows to fix problems on Mac OS X machines. This possibly
	  related to 64/32 bit arithmetic. See changes by Don Porter
	  below.

2003-02-07  Pat Thoyts  <[email protected]>

	* sha1.tcl: Check that we have a _working_ C implementation.

2003-02-06  David N. Welton  <[email protected]>

	* sha1.tcl (sha1::time): Use 'lindex' instead of regexp to fetch
	  number from 'time' results.

2002-02-20  Don Porter  <[email protected]>

	* sha1.tcl (sha1): Force 32-bit register arithmetic so that
	the right answers are computed even on 64-bit platforms. [446997]

2002-02-20  Donal K. Fellows  <[email protected]>

	* sha1.tcl (initK,sha1): Force 32-bit interpretation of constants
	larger than INT_MAX on 32-bit processors, due to TIP#72.

2002-02-07  Andreas Kupries  <[email protected]>
	
	* Version up to 1.0.2 to differentiate development from the
	  version in the tcllib 1.2 release.

	* sha1.tcl: Adding -- to hex/sha1 commands to prevent
	  misinterpretation of data if starting with -.

2001-10-16  Andreas Kupries  <[email protected]>

	* sha1.n:
	* sha1.tcl:
	* pkgIndex.tcl: Version up to 1.0.1

2001-08-20  Andreas Kupries  <[email protected]>

	* sha1.test: Fixed broken error messages for 8.4. Using
	  [tcltest::getErrorMessage] now to get the correct message for
	  all versions of the core. Bug [440051] reported by Larry Virden.

2001-06-22  Andreas Kupries <[email protected]>

	* sha1.tcl: Fixed dubious code reported by frink.

2001-06-21  Andreas Kupries <[email protected]>

	* New module, 'sha1'. The code is Don Libes's <[email protected]>
	  sha1pure, with Donal K. Fellows's patches to speed it up, and
	  extended with a soft dependency on Trf to allow higher speed if
	  the environment is right.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































Deleted modules/sha1/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 sha1 1.0.3 [list source [file join $dir sha1.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/sha1/sha1.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
[manpage_begin sha1 n 1.0.3]
[moddesc   {sha1 hash}]
[titledesc {Perform sha1 hashing}]
[require Tcl 8.2]
[require sha1 [opt 1.0.3]]
[description]
[para]

This package provides commands to compute a SHA1 digests of arbitrary
messages.

[section COMMANDS]
[list_begin definitions]
[call [cmd ::sha1::sha1] [arg msg]]

The command takes a message and returns the SHA1 digest of this message
as a hexadecimal string.

[call [cmd ::sha1::hmac] [arg key] [arg text]]

The command takes a key string and a text and returns the hmac of the

[list_end]

[section EXAMPLES]

[para]
[example {
% sha1::sha1 "hello world"
2aae6c35c94fcfb415dbe95f408b9ce91ee846ed
}]

[para]
[example {
% sha1::hmac "our little secret" "hello world"
a7ed9d62819b9788e22171d9108a00c370104526
}]

[keywords sha1 hashing security]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted modules/sha1/sha1.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
'\" 
'\" Copyright (c) 2001 ActiveState Tool Corp.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: sha1.n,v 1.5 2002/02/08 06:05:20 andreas_kupries Exp $
'\" 
.so man.macros
.TH sha1 n 1.0.2 Sha1 "sha1 hash"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
::sha1::sha1 \- Perform sha1 hashing
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require sha1 ?1.0.2?\fR
.sp
\fB::sha1::sha1\fR \fImsg\fR?
.sp
\fB::sha1::hmac\fR \fIkey text\fR
.sp
.BE
.SH DESCRIPTION
.PP
This package provides commands to compute a SHA1 digests of arbitrary
messages.
.SH COMMANDS
.TP
\fB::sha1::sha1\fR \fImsg\fR
The command takes a message and returns the SHA1 digest of this message
as a hexadecimal string.
.TP
\fB::sha1::hmac\fR \fIkey text\fR
The command takes a key string and a text and returns the hmac of the
text under the chosen key as a hexadecimal string.
.SH EXAMPLES
.PP
.CS
% sha1::sha1 "hello world"
2aae6c35c94fcfb415dbe95f408b9ce91ee846ed
.CE
.PP
.CS
% sha1::hmac "our little secret" "hello world"
a7ed9d62819b9788e22171d9108a00c370104526
.CE
.SH KEYWORDS
sha1, hashing, security
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































Deleted modules/sha1/sha1.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
##################################################
#
# sha1.tcl - SHA1 in Tcl
# Author: Don Libes <[email protected]>, May 2001
# Version 1.0.3
#
# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm",
#          http://www.itl.nist.gov/fipspubs/fip180-1.htm
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication"
#
# Some of the comments below come right out of FIPS 180-1; That's why
# they have such peculiar numbers.  In addition, I have retained
# original syntax, etc. from the FIPS.  All remaining bugs are mine.
#
# HMAC implementation by D. J. Hagberg <[email protected]> and
# is based on C code in FIPS 2104.
#
# For more info, see: http://expect.nist.gov/sha1pure
#
# - Don
##################################################

### Code speedups by Donal Fellows <[email protected]> who may well
### have added some extra bugs of his own...  :^)

### Changed the code to use Trf if this package is present on the
### system requiring the sha1 package. Analogous to md5.

package require Tcl 8.2
namespace eval ::sha1 {
}

if {![catch {package require Trf 2.0}] && ![catch {::sha1 -- test}]} {
    # Trf is available, so implement the functionality provided here
    # in terms of calls to Trf for speed.

    proc ::sha1::sha1 {msg} {
	string tolower [::hex -mode encode -- [::sha1 -- $msg]]
    }

    # hmac: hash for message authentication

    # SHA1 of Trf and SHA1 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. (Not all, the first place must not the changed,
    # see [x]

    proc ::sha1::hmac {key text} {
	# if key is longer than 64 bytes, reset it to SHA1(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [sha1 $key]]
	    # [x] set key [::sha1 -- $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 sha1, appending its results to the outer key
	append k_ipad $text
	#append k_opad [binary format H* [sha1 $k_ipad]]
	append k_opad [::sha1 -- $k_ipad]

	# Perform outer sha1
	#sha1 $k_opad
	string tolower [::hex -mode encode -- [::sha1 -- $k_opad]]
    }

} else {
    # Without Trf use the all-tcl implementation by Don Libes.

    namespace eval ::sha1 {
	variable K

	proc initK {} {
	    variable K {}
	    foreach t {
		0x5A827999
		0x6ED9EBA1
		0x8F1BBCDC
		0xCA62C1D6
	    } {
		for {set i 0} {$i < 20} {incr i} {
		    lappend K [expr {int($t)}]
		}
	    }
	}
	initK
    }

    # test sha1
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::sha1::test {} {
	foreach {msg expected} {
	    "abc"
	    "a9993e364706816aba3e25717850c26c9cd0d89d"
	    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
	    "84983e441c3bd26ebaae4aa1f95129e5e54670f1"
	    "[string repeat a 1000000]"
	    "34aa973cd4c4daa4f61eeb2bdbad27316534016f"
	} {
	    puts "testing: sha1 \"$msg\""
	    set msg [subst $msg]
	    set msgLen [string length $msg]
	    if {$msgLen > 10000} {
		puts "warning: msg length = $msgLen; this may take a while . . ."
	    }
	    set computed [sha1 $msg]
	    puts "expected: $expected"
	    puts "computed: $computed"
	    if {0 != [string compare $computed $expected]} {
		puts "FAILED"
	    } else {
		puts "SUCCEEDED"
	    }
	}
    }

    # time sha1
    #
    # This proc is not necessary during runtime and may be omitted if you
    # are simply inserting this file into a production program.
    #
    proc ::sha1::time {} {
	foreach len {10 50 100 500 1000 5000 10000} {
	    set time [::time {sha1 [format %$len.0s ""]} 10]
	    set msec [lindex $time 0]
	    puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
	}
    }

    proc ::sha1::sha1 {msg} {
	variable K

	#
	# 4. MESSAGE PADDING
	#

	# pad to 512 bits (512/8 = 64 bytes)

	set msgLen [string length $msg]

	# last 8 bytes are reserved for msgLen
	# plus 1 for "1"

	set padLen [expr {56 - $msgLen%64}]
	if {$msgLen % 64 >= 56} {
	    incr padLen 64
	}

	# 4a. and b. append single 1b followed by 0b's
	append msg [binary format "a$padLen" \200]

	# 4c. append 64-bit length
	# Our implementation obviously limits string length to 32bits.
	append msg \0\0\0\0[binary format "I" [expr {8*$msgLen}]]
    
	#
	# 7. COMPUTING THE MESSAGE DIGEST
	#

	# initial H buffer

	set H0 [expr {int(0x67452301)}]
	set H1 [expr {int(0xEFCDAB89)}]
	set H2 [expr {int(0x98BADCFE)}]
	set H3 [expr {int(0x10325476)}]
	set H4 [expr {int(0xC3D2E1F0)}]

	#
	# process message in 16-word blocks (64-byte blocks)
	#

	# convert message to array of 32-bit integers
	# each block of 16-words is stored in M($i,0-16)

	binary scan $msg I* words
	set blockLen [llength $words]

	for {set i 0} {$i < $blockLen} {incr i 16} {
	    # 7a. Divide M[i] into 16 words W[0], W[1], ...
	    set W [lrange $words $i [expr {$i+15}]]

	    # 7b. For t = 16 to 79 let W[t] = ....
	    set t   16
	    set t3  12
	    set t8   7
	    set t14  1
	    set t16 -1
	    for {} {$t < 80} {incr t} {
		set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \
			[lindex $W [incr t14]] ^ [lindex $W [incr t16]]}]
		lappend W [expr {($x << 1) | (($x >> 31) & 1)}]
	    }

	    # 7c. Let A = H[0] ....
	    set A $H0
	    set B $H1
	    set C $H2
	    set D $H3
	    set E $H4

	    # 7d. For t = 0 to 79 do
	    for {set t 0} {$t < 20} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			(($B & $C) | ((~$B) & $D)) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }
	    for {} {$t<40} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			($B ^ $C ^ $D) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }
	    for {} {$t<60} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			(($B & $C) | ($B & $D) | ($C & $D)) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }
	    for {} {$t<80} {incr t} {
		set TEMP [expr {(($A << 5) | (($A >> 27) & 0x1f)) + \
			($B ^ $C ^ $D) \
			+ $E + [lindex $W $t] + [lindex $K $t]}]
		set E $D
		set D $C
		set C [expr {($B << 30) | (($B >> 2) & 0x3fffffff)}]
		set B $A
		set A $TEMP
	    }

	    set H0 [expr {int(($H0 + $A) & 0xffffffff)}]
	    set H1 [expr {int(($H1 + $B) & 0xffffffff)}]
	    set H2 [expr {int(($H2 + $C) & 0xffffffff)}]
	    set H3 [expr {int(($H3 + $D) & 0xffffffff)}]
	    set H4 [expr {int(($H4 + $E) & 0xffffffff)}]
	}

	return [format %0.8x%0.8x%0.8x%0.8x%0.8x $H0 $H1 $H2 $H3 $H4]
    }

    ### These procedures are either inlined or replaced with a normal [format]!
    #
    #proc ::sha1::f {t B C D} {
    #    switch [expr {$t/20}] {
    #	 0 {
    #	     expr {($B & $C) | ((~$B) & $D)}
    #	 } 1 - 3 {
    #	     expr {$B ^ $C ^ $D}
    #	 } 2 {
    #	     expr {($B & $C) | ($B & $D) | ($C & $D)}
    #	 }
    #    }
    #}
    #
    #proc ::sha1::byte0 {i} {expr {0xff & $i}}
    #proc ::sha1::byte1 {i} {expr {(0xff00 & $i) >> 8}}
    #proc ::sha1::byte2 {i} {expr {(0xff0000 & $i) >> 16}}
    #proc ::sha1::byte3 {i} {expr {((0xff000000 & $i) >> 24) & 0xff}}
    #
    #proc ::sha1::bytes {i} {
    #    format %0.2x%0.2x%0.2x%0.2x [byte3 $i] [byte2 $i] [byte1 $i] [byte0 $i]
    #}

    # hmac: hash for message authentication
    proc ::sha1::hmac {key text} {
	# if key is longer than 64 bytes, reset it to SHA1(key).  If shorter, 
	# pad it out with null (\x00) chars.
	set keyLen [string length $key]
	if {$keyLen > 64} {
	    set key [binary format H32 [sha1 $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 sha1, appending its results to the outer key
	append k_ipad $text
	append k_opad [binary format H* [sha1 $k_ipad]]

	# Perform outer sha1
	sha1 $k_opad
    }
}

package provide sha1 1.0.3
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































Deleted modules/sha1/sha1.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# -*- tcl -*-
# sha1.test:  tests for the sha1 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: sha1.test,v 1.2 2001/08/20 20:35:12 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require sha1
if {[catch {package present Trf}]} {
    puts "sha1 [package present sha1] (pure Tcl)"
} else {
    puts "sha1 [package present sha1] (Trf based)"
}


test sha1-1.0 {sha1} {
    catch {::sha1::sha1} result
    set result
} [tcltest::getErrorMessage "::sha1::sha1" "msg" 0]

test sha1-1.1 {sha1} {
    catch {::sha1::hmac} result
    set result
} [tcltest::getErrorMessage "::sha1::hmac" "key text" 0]

test sha1-1.2 {sha1} {
    catch {::sha1::hmac key} result
    set result
} [tcltest::getErrorMessage "::sha1::hmac" "key text" 1]


foreach {n msg expected} {
    1 "abc"
    "a9993e364706816aba3e25717850c26c9cd0d89d"
    2 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
    "84983e441c3bd26ebaae4aa1f95129e5e54670f1"
} {
    test sha1-2.$n {sha1} {
	::sha1::sha1 $msg
    } $expected ; # {}
}

foreach {n key text expected} {
    1 ""     ""      "fbdb1d1b18aa6c08324b7d64b71fb76370690e1d"
    2 "foo"  "hello" "4c883e9bc42763641bba04185d492de00de7ce2c"
    3 "bar"  "world" "a905e79f51faa446cb5a3888b577e34577ef7fce"
    4 "key"  "text"  "369e2959eb49450338b212748f77d8ded74847bb"
    5 "sha1" "hmac"  "2660aeeccf432596e56f8f8260de971322e8935b"
    6 "hmac" "sha1"  "170523fd610da92dd4b4fb948a01a8365d66511a"
    7 "sha1" "sha1"  "5154473317173f66212fc59365233ffd9cbaab94"
    8 "hmac" "hmac"  "9e08393f6ac829c4385930ea38567dad582d958f"
    9 "01234567abcdefgh01234567abcdefgh01234567abcdefgh01234567abcdefgh==" "hello world"
    "6541c34492618a052c12cb9f88fb795d97595b34"
} {
    test sha1-3.$n {hmac} {
	::sha1::hmac $key $text
    } $expected ; # {}
}

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































Deleted modules/smtpd/ChangeLog.

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

	* smtpd.tcl: Fixed bug #614591.

2003-01-25  Pat Thoyts <[email protected]>

	* smtpd.tcl: Fix bug #674333: require Tcl version 8.3+
	 (the mime package requires 8.3 therefore so do we.)
	
2003-01-16  Andreas Kupries  <[email protected]>

	* smtpd.man: More semantic markup, less visual one.

2003-01-02  Pat Thoyts  <[email protected]>

	* smtpd.tcl: Added exception catching to all channel comms.
	  Added some ESMTP option handling (rudimentary).
	  Added SMTP Transparency handling. (RFC 2821: 4.5.2)
	  Improved error messages for DATA command.

2002-10-25  Pat Thoyts  <[email protected]>

	* smtpd.tcl: Implemented request #627960 to propagate the network
	  interface name into the server messages. Added a catch around
	  the deliver call and permit the deliver code to return SMTP
	  failure codes via ::errorCode.
	
2002-10-08  Pat Thoyts  <[email protected]>

	* smtpd.tcl: Implemented feature request #531531. Added
	  -deliverMIME option to provide mail as a MIME token.
	* smtpd.man: Updated for the new delivery option.
	* tk_smtpdMIME: New example using the -deliverMIME option.
	
2002-09-25  David N. Welton  <[email protected]>

	* smtpd.man: Fixed documentation error in deliver example.

2002-09-19  David N. Welton  <[email protected]>

	* smtpd.tcl (smtpd::service): Added Andreas' suggested changes to
	  avoid a bgerror caused by a broken pipe.

2002-09-16  Pat Thoyts  <[email protected]>

	* smtpd.tcl: fixed bug #609835 to cope with multiple addresses in
	  MAIL and RCPT commands without raising exception.

2002-04-10  Andreas Kupries <[email protected]>

	* smtpd.man: Added doctools manpage.

2001-12-10  Pat Thoyts  <[email protected]>

	* smtpd.tcl (smtpd::gmtoffset): Fixed for cases where the hour
	  offset is invalid.

2001-11-19  Andreas Kupries <[email protected]>

	* Moved example.tcl to the standard location in
	  'tcllib/examples/smtpd'. Also renamed it to "tk_smtpd".

2001-11-06  Pat Thoyts  <[email protected]>

	* smtpd.tcl: Tcl SMTP server package.
	* smtpd.n: Manual page for the Tcl SMTP server.
	* example.tcl: Simple demo of server use and authentication.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































Deleted modules/smtpd/clients/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
These files are mail sending test scripts written in various scripting
languages. The purpose of these is to check that our SMTPd
inter-operates successfully with everyone else's SMTP client software.

Feel free to add a test script for your favourite other language - or to
improve the usage of any of the current languages.

mail-test.pl  - Perl test script
mail-test.py  - Python test
mail-test.rb  - Ruby test
mail-test.php - PHP test (requires some php.ini configuration)
php.ini       - PHP ini file (default for Windows installations) 
mail-test.tcl - and of course, a Tcl client!
<
<
<
<
<
<
<
<
<
<
<
<
<


























Deleted modules/smtpd/clients/mail-test.php.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
<?
  # Send a message from PHP (check the php.ini for the 
  # server, port and default sender details)

  $sndr = 'php-test-script@localhost';
  $rcpt = 'tcllib-test@localhost';

  $subject = "Testing from PHP";

  $hdrs  = "MIME-Version: 1.0\r\n";
  $hdrs .= "Content-type: text/plain; charset=iso-8859-1\r\n";
  $hdrs .= "From: PHP Script <" . $sndr . ">";

  $body  = "This is a sample message send from PHP.\r\n";
  $body .= "As always, let us check the transparency function:\r\n";
  $body .= ". <-- there should be a dot there.\r\n";
  $body .= "Bye";

  mail($rcpt, $subject, $body, $hdrs);

?>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted modules/smtpd/clients/mail-test.pl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
# mail-test.pl - Copyright (C) 2003 Pat Thoyts <[email protected]>
#
# Send some mail from Perl.
#
# This sends two messages, one valid and one without a recipient using the
# SMTP protocol.
#
# usage: ./mail-test.pl smtpd-host ?smtpd-port?
#
# -------------------------------------------------------------------------

use diagnostics;
use strict;

use Net::SMTP;
use Sys::Hostname;

my ($smtp_smart_host, $smtp_smart_port) = (shift, shift);

$smtp_smart_host = 'localhost' if (!$smtp_smart_host);
$smtp_smart_port = 25 if (!$smtp_smart_port);

my $smtp_default_from = 'postmaster@' . hostname();
my $smtp_timeout = 120;
my $smtp_log_mail = 0;
my $smtp_debug = 1;

my $sender_address = 'Perl Test Script <perl-test-script@' . hostname() . '>';
my $recipient_address = 'Tcl Server <tcl-smtpd@' . $smtp_smart_host . '>';

print "Sending valid message\n";
test_ok();
print "Sending invalid message\n";
test_no_rcpt();

sub test_no_rcpt {
  my $header = 'From: ' . $sender_address . "\n";
  $header .= 'Subject: perl test' . "\n";
  my $message = <<EOF;
This is a sample message in no particular format, sent by Perl's
Net::SMTP package.
Let's check the transparency code with a sentance ending on the next line
. Like this!
EOF

  Sendmail($header . "\n" . $message . "\n");
}

sub test_ok {
  my $header = 'From: ' . $sender_address . "\n";
  $header .= 'To: ' . $recipient_address . "\n";
  $header .= 'Subject: perl test' . "\n";
  my $message = <<EOF;
This is a sample message in no particular format, sent by Perl's
Net::SMTP package.
Let's check the transparency code with a sentance ending on the next line
. Like this!
EOF

  Sendmail($header . "\n" . $message . "\n");
}

# -------------------------------------------------------------------------
# Sendmail replacement (replaces exec'ing /usr/lib/sendmail...)
#
# Just call this function with the entire mail (headers and body together).
# The recipient and sender addresses are extracted from the mail text.
# -------------------------------------------------------------------------

sub Sendmail {
    my ($msg) = (@_);
    my @rcpts = ();
    my $from = $smtp_default_from;
    
    # Process the message headers to identify the recipient list.
    my @msg = split(/^$/m, $msg);
    my $header = $msg[0];
    $header =~ s/\n\s+/ /g;  # fix continuation lines
    
    my @lines = split(/^/m, $header);
    chomp(@lines);
    foreach my $line (@lines) {
        my ($key, $value) = split(/:\s*/, $line, 2);
        if ($key =~ /To|CC|BCC/i ) {
            push(@rcpts, $value);
        }
        if ($key =~ /From/i) {
            $from = $value;
        }
    }
    
    my $smtp = Net::SMTP->new($smtp_smart_host,
                              Hello => hostname(),
                              Port  => $smtp_smart_port,
                              Timeout => $smtp_timeout,
                              Debug => $smtp_debug)
        || die "SMTP failed to connect: $!";

    $smtp->mail($from, (Size=>length($msg), Bits=>'8'));
    $smtp->to(@rcpts);
    if ($smtp->data()) {        # start sending data;
      $smtp->datasend($msg);    # send the message
      $smtp->dataend();         # finished sending data
    } else {
      $smtp->reset();
    }
    $smtp->quit;                # end of session

    if ( $smtp_log_mail ) {
        if ( open(MAILLOG, ">> data/maillog") ) {
            print MAILLOG "From $from at ", localtime() . "\n";
            print MAILLOG "To: " . join(@rcpts, ',') . "\n";
            print MAILLOG $msg . "\n\n";
            close(MAILLOG);
        }
    }
}

# -------------------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































Deleted modules/smtpd/clients/mail-test.py.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
# Python mail sample

import sys, smtplib


class SMTPTest:
    def __init__(self, interface='localhost', port=25):
        self.svr = smtplib.SMTP(interface, port)
        self.svr.set_debuglevel(1)

    def sendmail(self, sender, recipient, message):
        try:
            self.svr.sendmail(sender, recipient, message)
        except:
            print "oops"

    def quit(self):
        self.svr.quit()

def test():
    sndr = "python-script-test@localhost"
    rcpt = "tcllib-test@localhost"
    mesg = """From: Python Mailer <python-script@localhost>
To: Tcllib Tester <tcllib-test@localhost>
Date: Fri Dec 20 14:20:49 2002
Subject: test from python

This is a sample message from Python.
Hope it's OK
Check transparency:
. <- there should be one dot here.
Done
"""
    # Connect
    svr = SMTPTest('localhost')

    # Try normal message
    svr.sendmail(sndr, rcpt, mesg)
    
    # should fail: invalid recipient.
    svr.sendmail(sndr, "", mesg)
    
    # should fail: NULL recipient only valid for sender
    svr.sendmail(sndr, "<>", mesg)

    # should be ok: null sender (permitted for daemon responses)
    svr.sendmail("<>", rcpt, mesg)

    svr.quit()


if __name__ == '__main__':
    test()
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































Deleted modules/smtpd/clients/mail-test.rb.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
require 'net/smtp'

sndr = 'ruby-test-script@localhost'
rcpt = 'tcllib-test@localhost'
msg = 'From: Ruby <ruby-test-script@localhost>
To: SMTPD <tcllib-test@localhost>
Subject: Testing from Ruby

This is a sample message send from Ruby.
As always, let us check the transparency function:
. <-- there should be a dot there.
Bye'

Net::SMTP.start('localhost', 25) do |smtp|
  smtp.send_mail msg, sndr, rcpt
end
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted modules/smtpd/clients/mail-test.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
package require mime
package require smtp

set sndr "tcl-test-script@localhost"
set rcpt "tcllib-test@localhost"
set msg "This is a sample message send from Tcl.\nAs\
always, let us check the transparency function:\n. <-- there\
should be a dot there.\nBye"

set tok [mime::initialize -canonical text/plain -encoding 7bit -string $msg]
mime::setheader $tok Subject "Testing from Tcl"
smtp::sendmessage $tok -servers localhost \
    -header [list To $rcpt] \
    -header [list From $sndr]

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























Deleted modules/smtpd/clients/php.ini.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
[PHP]
engine = On
short_open_tag = On
asp_tags = Off
precision    =  14
y2k_compliance = Off
output_buffering = 4096
output_handler =
zlib.output_compression = Off
implicit_flush = Off
allow_call_time_pass_reference = Off
safe_mode = Off
safe_mode_gid = Off
safe_mode_include_dir =								
safe_mode_exec_dir =
safe_mode_allowed_env_vars = PHP_
safe_mode_protected_env_vars = LD_LIBRARY_PATH
disable_functions =
expose_php = On
max_execution_time = 30     ; Maximum execution time of each script, in seconds
memory_limit = 8M      ; Maximum amount of memory a script may consume (8MB)
error_reporting  =  E_ALL
display_errors = Off
display_startup_errors = Off
log_errors = On
track_errors = Off
warn_plus_overloading = Off
variables_order = "GPCS"
register_globals = Off
register_argc_argv = Off
post_max_size = 8M
gpc_order = "GPC"
magic_quotes_gpc = Off
magic_quotes_runtime = Off    
magic_quotes_sybase = Off
auto_prepend_file =
auto_append_file =
default_mimetype = "text/html"
doc_root =
user_dir =
extension_dir = ./
enable_dl = On
file_uploads = On
upload_max_filesize = 2M
allow_url_fopen = On
[mail function]
; Win32 only
SMTP = localhost
sendmail_from = postmaster@localhost

; For Unix only.  You may supply arguments as well (default: "sendmail -t -i").
;sendmail_path =

; Local Variables:
; tab-width: 4
; End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































Deleted modules/smtpd/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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.3]} {return}
package ifneeded smtpd 1.2.1 [list source [file join $dir smtpd.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/smtpd/smtpd.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin smtpd n 1.2.1]
[copyright {Pat Thoyts <[email protected]>}]
[moddesc   {Tcl SMTP Server Package}]
[titledesc {Tcl SMTP server implementation}]
[require Tcl 8.3]
[require smtpd [opt 1.2.1]]
[description]
[para]

The [package smtpd] package provides a simple Tcl-only server library
for the Simple Mail Transfer Protocol as described in RFC 821 and RFC
2821.  By default the server will bind to the default network address
and the standard SMTP port (25).

[para]

This package was designed to permit testing of Mail User Agent code
from a developers workstation. [emph "It does not attempt to deliver \
mail to your mailbox." ] Instead users of this package are expected to
write a procedure that will be called when mail arrives. Once this
procedure returns, the server has nothing further to do with the mail.

[section SECURITY]

On Unix platforms binding to the SMTP port requires root privileges. I
would not recommend running any script-based server as root unless
there is some method for dropping root privileges immediately after
the socket is bound. Under Windows platforms, it is not necessary to
have root or administrator privileges to bind low numbered
sockets. However, security on these platforms is weak anyway.

[para]

In short, this code should probably not be used as a permanently
running Mail Transfer Agent on an Internet connected server, even
though we are careful not to evaluate remote user input. There are
many other well tested and security audited programs that can be used
as mail servers for internet connected hosts.

[section COMMANDS]

[list_begin definitions]

[call [cmd ::smtpd::start] [opt [arg myaddr]] [opt [arg port]]]

Start the service listening on [arg port] or the default port 25. If
[arg myaddr] is given as a domain-style name or numerical
dotted-quad IP address then the server socket will be bound to that
network interface. By default the server is bound to all network
interfaces. For example:

[nl]

[example {
  set sock [::smtpd::start [info hostname] 0]
}]

[nl]

will bind to the hosts internet interface on the first available port.

[nl]

At present the package only supports a single instance of a SMTP
server. This could be changed if required at the cost of making the
package a little more complicated to read. If there is a good reason
for running multiple SMTP services then it will only be necessary to
fix the [var options] array and the [var ::smtpd::stopped] variable
usage.

[nl]

As the server code uses [cmd fileevent](n) handlers to process the
input on sockets you will need to run the event loop. This means
either you should be running from within [syscmd wish](1) or you
should [cmd vwait](n) on the [var ::smtpd::stopped] variable which is
set when the server is stopped.

[call [cmd ::smtpd::stop]]

Halt the server and release the listening socket. If the server has
not been started then this command does nothing.

The [var ::smtpd::stopped] variable is set for use with

[cmd vwait](n).

[nl]

It should be noted that stopping the server does not disconnect any
currently active sessions as these are operating over an independent
channel. Only explicitly tracking and closing these sessions, or
exiting the server process will close down all the running
sessions. This is similar to the usual unix daemon practice where the
server performs a [syscmd fork](2) and the client session continues on
the child process.

[call [cmd ::smptd::configure] [opt "[arg option] [arg value]"] [opt "[arg option] [arg value] [arg ...]"]]

Set configuration options for the SMTP server. Most values are the
name of a callback procedure to be called at various points in the
SMTP protocol. See the [sectref CALLBACKS] section for details of the
procedures.

[list_begin definitions]

[lst_item "[option -validate_host] [arg proc]"]

Callback to authenticate new connections based on the ip-address of
the client.

[lst_item "[option -validate_sender] [arg proc]"]

Callback to authenticate new connections based on the senders email
address.

[lst_item "[option -validate_recipient] [arg proc]"]

Callback to validate and authorize a recipient email address

[lst_item "[option -deliverMIME] [arg proc]"]

Callback used to deliver mail as a mime token created by the tcllib
[package mime] package.

[lst_item "[option -deliver] [arg proc]"]

Callback used to deliver email. This option has no effect if
the [option -deliverMIME] option has been set.

[list_end]

[call [cmd ::smtpd::cget] [opt [arg option]]]

If no [arg option] is specified the command will return a list of all
options and their current values. If an option is specified it will
return the value of that option.

[list_end]

[section CALLBACKS]

[list_begin definitions]
[lst_item "[cmd validate_host] callback"]]

This procedure is called with the clients ip address as soon as a
connection request has been accepted and before any protocol commands
are processed. If you wish to deny access to a specific host then an
error should be returned by this callback. For example:

[nl]
[example {
 proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
       error "go away!"
    }
 }
}]
[nl]

If access is denied the client will receive a standard message that
includes the text of your error, such as:

[nl]
[example {
 550 Access denied: I hate you.
}]
[nl]

As per the SMTP protocol, the connection is not closed but we wait for
the client to send a QUIT command. Any other commands cause a

[const {503 Bad Sequence}] error.

[lst_item "[cmd validate_sender] callback"]]

The validate_sender callback is called with the senders mail address
during processing of a MAIL command to allow you to accept or reject
mail based upon the declared sender. To reject mail you should throw
an error. For example, to reject mail from user "denied":

[nl]
[example {
 proc validate_sender {address} {
    eval array set addr \\
         [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
         error "mailbox $addr(local) denied"
    }
    return    
 }
}]

[nl]

The content of any error message will not be passed back to the client.

[lst_item "[cmd validate_recipient] callback"]]

The validate_recipient callback is similar to the validate_sender
callback and permits you to verify a local mailbox and accept mail for
a local user address during RCPT command handling. To reject mail,
throw an error as above. The error message is ignored.

[lst_item "[cmd deliverMIME] callback"]]

The deliverMIME callback is called once a mail message has been
successfully passed to the server. A mime token is constructed from
the sender, recipients and data and the users procedure it called with
this single argument. When the call returns, the mime token is cleaned
up so if the user wishes to preserve the data she must make a copy.

[nl]
[example {
 proc deliverMIME {token} {
     set sender [lindex [mime::getheader $token From] 0]
     set recipients [lindex [mime::getheader $token To] 0]
     set mail "From $sender [clock format [clock seconds]]"
     append mail "\n" [mime::buildmessage $token]
     puts $mail
 }
}]

[lst_item "[cmd deliver] callback"]]

The deliver callback is called once a mail message has been
successfully passed to the server and there is no -deliverMIME option
set. The procedure is called with the sender, a list of recipients and
the text of the mail as a list of lines. For example:

[nl]
[example {
 proc deliver {sender recipients data} {
    set mail "From $sender \
               [clock format [clock seconds]]"
    append mail "\n" [join $data "\n"]
    puts "$mail"
 }
}]
[nl]

Note that the DATA command will return an error if no sender or
recipient has yet been defined.

[list_end]

[section VARIABLES]

[list_begin definitions]

[lst_item [var ::smtpd::stopped]]

This variable is set to [const true] during the [cmd ::smtpd::stop]
command to permit the use of the [cmd vwait](n) command.

[comment ::smtpd::postmaster]
[comment {The e-mail address of the person that is the contact for the server.}]

[list_end]

[section AUTHOR]

Written by Pat Thoyts [uri mailto:[email protected]].

[section LICENSE]

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
[file license.terms] for more details.

[keywords smtpd smtp services {RFC 821} {RFC 2821} vwait socket]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































Deleted modules/smtpd/smtpd.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
'\"
'\" Generated from smtpd.man by mpexpand with fmt.nroff
'\"
.so man.macros
.TH "smtpd" n 1.2.1 smtpd "Tcl SMTP Server Package"
.BS
.SH NAME
smtpd \- Tcl SMTP server implementation
'\" -*- tcl -*- doctools manpage
.SH "SYNOPSIS"
package require \fBTcl 8.3\fR
.sp
package require \fBsmtpd ?1.2?\fR
.sp
\fB::smtpd::start\fR ?\fImyaddr\fR? ?\fIport\fR?\fR
.sp
\fB::smtpd::stop\fR \fR
.sp
\fB::smptd::configure\fR ?\fIoption\fR \fIvalue\fR? ?\fIoption\fR \fIvalue\fR \fI...\fR?\fR
.sp
\fB::smtpd::cget\fR ?\fIoption\fR?\fR
.sp
.BE
.SH "DESCRIPTION"
.PP
The \fBsmtpd\fR package provides a simple Tcl-only server library
for the Simple Mail Transfer Protocol as described in RFC 821 and RFC
2821.  By default the server will bind to the default network address
and the standard SMTP port (25).
.PP
This package was designed to permit testing of Mail User Agent code
from a developers workstation. \fIIt does not attempt to deliver  mail to your mailbox.\fR Instead users of this package are expected to
write a procedure that will be called when mail arrives. Once this
procedure returns, the server has nothing further to do with the mail.
.SH "SECURITY"
On Unix platforms binding to the SMTP port requires root privileges. I
would not recommend running any script-based server as root unless
there is some method for dropping root privileges immediately after
the socket is bound. Under Windows platforms, it is not necessary to
have root or administrator privileges to bind low numbered
sockets. However, security on these platforms is weak anyway.
.PP
In short, this code should probably not be used as a permanently
running Mail Transfer Agent on an Internet connected server, even
though we are careful not to evaluate remote user input. There are
many other well tested and security audited programs that can be used
as mail servers for internet connected hosts.
.SH "COMMANDS"
.TP
\fB::smtpd::start\fR ?\fImyaddr\fR? ?\fIport\fR?\fR
Start the service listening on \fIport\fR or the default port 25. If
\fImyaddr\fR is given as a domain-style name or numerical
dotted-quad IP address then the server socket will be bound to that
network interface. By default the server is bound to all network
interfaces. For example:
.sp
.nf
  set sock [::smtpd::start [info hostname] 0]
.fi
.sp
will bind to the hosts internet interface on the first available port.
.sp
At present the package only supports a single instance of a SMTP
server. This could be changed if required at the cost of making the
package a little more complicated to read. If there is a good reason
for running multiple SMTP services then it will only be necessary to
fix the \fBoptions\fR array and the \fB::smtpd::stopped\fR variable
usage.
.sp
As the server code uses \fBfileevent\fR(n) handlers to process the
input on sockets you will need to run the event loop. This means
either you should be running from within \fBwish\fR(1) or you
should \fBvwait\fR(n) on the \fB::smtpd::stopped\fR variable which is
set when the server is stopped.
.TP
\fB::smtpd::stop\fR \fR
Halt the server and release the listening socket. If the server has
not been started then this command does nothing.
The \fB::smtpd::stopped\fR variable is set for use with
\fBvwait\fR(n).
.sp
It should be noted that stopping the server does not disconnect any
currently active sessions as these are operating over an independent
channel. Only explicitly tracking and closing these sessions, or
exiting the server process will close down all the running
sessions. This is similar to the usual unix daemon practice where the
server performs a \fBfork\fR(2) and the client session continues on
the child process.
.TP
\fB::smptd::configure\fR ?\fIoption\fR \fIvalue\fR? ?\fIoption\fR \fIvalue\fR \fI...\fR?\fR
Set configuration options for the SMTP server. Most values are the
name of a callback procedure to be called at various points in the
SMTP protocol. See the \fBCALLBACKS\fR section for details of the
procedures.
.RS
.TP
\fB-validate_host\fR \fIproc\fR
Callback to authenticate new connections based on the ip-address of
the client.
.TP
\fB-validate_sender\fR \fIproc\fR
Callback to authenticate new connections based on the senders email
address.
.TP
\fB-validate_recipient\fR \fIproc\fR
Callback to validate and authorize a recipient email address
.TP
\fB-deliverMIME\fR \fIproc\fR
Callback used to deliver mail as a mime token created by the tcllib
\fBmime\fR package.
.TP
\fB-deliver\fR \fIproc\fR
Callback used to deliver email. This option has no effect if
the \fB-deliverMIME\fR option has been set.
.RE
.TP
\fB::smtpd::cget\fR ?\fIoption\fR?\fR
If no \fIoption\fR is specified the command will return a list of all
options and their current values. If an option is specified it will
return the value of that option.
.SH "CALLBACKS"
.TP
\fBvalidate_host callback\fR
This procedure is called with the clients ip address as soon as a
connection request has been accepted and before any protocol commands
are processed. If you wish to deny access to a specific host then an
error should be returned by this callback. For example:
.sp
.nf
 proc validate_host {ipnum} {
    if {[string match "192.168.1.*" $ipnum]} {
       error "go away!"
    }
 }
.fi
.sp
If access is denied the client will receive a standard message that
includes the text of your error, such as:
.sp
.nf
 550 Access denied: I hate you.
.fi
.sp
As per the SMTP protocol, the connection is not closed but we wait for
the client to send a QUIT command. Any other commands cause a
\fB503 Bad Sequence\fR error.
.TP
\fBvalidate_sender callback\fR
The validate_sender callback is called with the senders mail address
during processing of a MAIL command to allow you to accept or reject
mail based upon the declared sender. To reject mail you should throw
an error. For example, to reject mail from user "denied":
.sp
.nf
 proc validate_sender {address} {
    eval array set addr \\
         [mime::parseaddress $address]
    if {[string match "denied" $addr(local)]} {
         error "mailbox $addr(local) denied"
    }
    return    
 }
.fi
.sp
The content of any error message will not be passed back to the client.
.TP
\fBvalidate_recipient callback\fR
The validate_recipient callback is similar to the validate_sender
callback and permits you to verify a local mailbox and accept mail for
a local user address during RCPT command handling. To reject mail,
throw an error as above. The error message is ignored.
.TP
\fBdeliverMIME callback\fR
The deliverMIME callback is called once a mail message has been
successfully passed to the server. A mime token is constructed from
the sender, recipients and data and the users procedure it called with
this single argument. When the call returns, the mime token is cleaned
up so if the user wishes to preserve the data she must make a copy.
.sp
.nf
 proc deliverMIME {token} {
     set sender [lindex [mime::getheader $token From] 0]
     set recipients [lindex [mime::getheader $token To] 0]
     set mail "From $sender [clock format [clock seconds]]"
     append mail "\n" [mime::buildmessage $token]
     puts $mail
 }
.fi
.TP
\fBdeliver callback\fR
The deliver callback is called once a mail message has been
successfully passed to the server and there is no -deliverMIME option
set. The procedure is called with the sender, a list of recipients and
the text of the mail as a list of lines. For example:
.sp
.nf
 proc deliver {sender recipients data} {
    set mail "From $sender  [clock format [clock seconds]]"
    append mail "\n" [join $data "\n"]
    puts "$mail"
 }
.fi
.sp
Note that the DATA command will return an error if no sender or
recipient has yet been defined.
.SH "VARIABLES"
.TP
\fB::smtpd::stopped\fR
This variable is set to \fBtrue\fR during the \fB::smtpd::stop\fR
command to permit the use of the \fBvwait\fR(n) command.
'\" ::smtpd::postmaster
'\" The e-mail address of the person that is the contact for the server.
.SH "AUTHOR"
Written by Pat Thoyts \fImailto:[email protected]\fR.
.SH "COPYRIGHT"
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
"\fIlicense.terms\fR" for more details.
.SH "KEYWORDS"
smtpd, smtp, services, RFC 821, RFC 2821, vwait, socket
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































Deleted modules/smtpd/smtpd.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
# smtpd.tcl - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# This provides a minimal implementation of the Simple Mail Tranfer Protocol
# as per RFC821 and RFC2821 (http://www.normos.org/ietf/rfc/rfc821.txt) and
# is designed for use during local testing of SMTP client software.
#
# -------------------------------------------------------------------------
# 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.
# -------------------------------------------------------------------------

package require Tcl 8.3;                # tcl minimum version
package require log;                    # tcllib
package require mime;                   # tcllib

namespace eval ::smtpd {
    variable rcsid {$Id: smtpd.tcl,v 1.9 2003/04/11 01:08:03 andreas_kupries Exp $}
    variable version 1.2.1
    variable stopped

    namespace export start stop

    variable commands {EHLO HELO MAIL RCPT DATA RSET NOOP QUIT}
    # non-minimal commands HELP VRFY EXPN VERB ETRN DSN 

    variable options
    if {! [info exists options]} {
        array set options {
            serveraddr         {}
            deliverMIME        {}
            deliver            {}
            validate_host      {}
            validate_sender    {}
            validate_recipient {}
        }
    }

    variable extensions
    if {! [info exists extensions]} {
        array set extensions {
            8BITMIME {}
            SIZE     0
        }
    }
}

# -------------------------------------------------------------------------
# Description:
#   Obtain configuration options for the server.
#
proc ::smtpd::cget {option} {
    variable options
    set optname [string trimleft $option -]
    if { [info exists options($optname)] } {
        return $options($optname)
    } else {
        return -code error "unknown option: must be one of \
                            \"[array names options]\""
    }
}

# -------------------------------------------------------------------------
# Description:
#   Configure server options. These include validation of hosts or users
#   and a procedure to handle delivery of incoming mail. The -deliver
#   procedure must handle mail because the server may release all session
#   resources once the deliver proc has completed.
#   An example might be to exec procmail to deliver the mail to users.
#
proc ::smtpd::configure {args} {
    variable options

    if {[llength $args] == 0} {
        foreach {opt value} [array get options] {
            lappend r -$opt $value

        }
        return $r
    }

    foreach {opt value} $args {
        switch -- $opt {
            -deliverMIME        {set options(deliverMIME) $value}
            -deliver            {set options(deliver) $value}
            -validate_host      {set options(validate_host) $value}
            -validate_sender    {set options(validate_sender) $value}
            -validate_recipient {set options(validate_recipient) $value}
            default {
                error "unknown option: \"$opt\": must be one of \
                       -deliverMIME, -deliver,\
                       -validate_host, -validate_recipient \
                       or -validate_sender"
            }
        }
    }
    return {}
}

# -------------------------------------------------------------------------
# Description:
#   Start the server on the given interface and port.
#
proc ::smtpd::start {{myaddr {}} {port 25}} {
    variable options
    variable stopped
    
    if {[info exists options(socket)]} {
        error "smtpd service already running on socket $options(socket)"
    }

    if {$myaddr != {}} {
        set options(serveraddr) $myaddr
        set myaddr "-myaddr $myaddr"
    } else {
        if {$options(serveraddr) == {}} {
            set options(serveraddr) [info hostname]
        }
    }

    set options(socket) [eval socket \
                             -server [namespace current]::accept $myaddr $port]
    set stopped 0
    log::log notice "smtpd service started on $options(socket)"
    return $options(socket)
}

# -------------------------------------------------------------------------
# Description:
#  Stop a running server. Do nothing if the server isn't running.
#
proc ::smtpd::stop {} {
    variable options
    variable stopped
    if {[info exists options(socket)]} {
        close $options(socket)
        set stopped 1
        log::log notice "smtpd service stopped"
        unset options(socket)
    }
}

# -------------------------------------------------------------------------
# Description:
#   Accept a new connection and setup a fileevent handler to process the new
#   session. Performs a host id validation step before allowing access.
#
proc ::smtpd::accept {channel client_addr client_port} {
    variable options
    variable version
    upvar [namespace current]::state_$channel State

    # init state array
    catch {unset State}
    initializeState $channel
    set State(access) allowed
    set State(client_addr) $client_addr
    set State(client_port) $client_port
    set accepted true

    # configure the data channel
    fconfigure $channel -buffering line -translation crlf -encoding ascii
    fileevent $channel readable [list [namespace current]::service $channel]

    # check host access permissions
    if {[cget -validate_host] != {}} {
        if {[catch {eval [cget -validate_host] $client_addr} msg] } {
            log::log notice "access denied for $client_addr:$client_port: $msg"
            Puts $channel "550 Access denied: $msg"
            set State(access) denied
            set accepted false
        }
    }
    
    if {$accepted} {
        # Accept the connection
        log::log notice "connect from $client_addr:$client_port on $channel"
        Puts $channel "220 $options(serveraddr) tcllib smtpd $version; [timestamp]"
    }
    
    return
}

# -------------------------------------------------------------------------
# Description:
#   Initialize the channel state array. Called by accept and RSET.
#
proc ::smtpd::initializeState {channel} {
    upvar [namespace current]::state_$channel State
    set State(indata) 0
    set State(to) {}
    set State(from) {}
    set State(data) {}
    set State(options) {}
}

# -------------------------------------------------------------------------
# Description:
#   Access the state of a connected session using the channel name as part
#   of the state array name. Called with no value, it returns the current
#   value of the item (or {} if not defined).
#
proc ::smtpd::state {channel args} {
    if {[llength $args] == 0} {
        return [array get [namespace current]::state_$channel]
    }

    set arrname [namespace current]::[subst state_$channel]

    if {[llength $args] == 1} {
        set r {}
        if {[info exists [subst $arrname]($args)]} {
            # FRINK: nocheck
            set r [set [subst $arrname]($args)]
        }
        return $r
    }

    foreach {name value} $args {
        # FRINK: nocheck
        set [namespace current]::[subst state_$channel]($name) $value
    }
    return {}
}

# -------------------------------------------------------------------------
# Description:
#   Safe puts.
#   If the client closes the channel, then puts will throw an error. Lets
#   terminate the session if this occurs.
proc ::smtpd::Puts {channel args} {
    if {[catch {uplevel puts $channel $args} msg]} {
        log::log error $msg
        catch {
            close $channel
            # FRINK: nocheck
            unset -- [namespace current]::state_$channel
        }
    }
    return $msg
}

# -------------------------------------------------------------------------
# Description:
#   Perform the chat with a connected client. This procedure accepts input on
#   the connected socket and executes commands according to the state of the
#   session.
#
proc ::smtpd::service {channel} {
    variable commands
    variable options
    upvar [namespace current]::state_$channel State

    if {[eof $channel]} {
        close $channel
        return
    }

    if {[catch {gets $channel cmdline} msg]} {
        close $channel
        log::log error $msg
        return
    }

    if { $cmdline == "" && [eof $channel] } {
        log::log warning "client has closed the channel"
        return
    }

    log::log debug "received: $cmdline"

    # If we are handling a DATA section, keep looking for the end of data.
    if {$State(indata)} {
        if {$cmdline == "."} {
            set State(indata) 0
            fconfigure $channel -translation crlf
            if {[catch {deliver $channel} err]} {
                # permit delivery handler to return SMTP errors in errorCode
                if {[regexp {\d{3}} $::errorCode]} {
                    Puts $channel "$::errorCode $err"
                } else {
                    Puts $channel "554 Transaction failed: $err"
                }
            } else {
                Puts $channel "250 [state $channel id]\
                        Message accepted for delivery"
            }
        } else {
            # RFC 2821 section 4.5.2: Transparency
            if {[string match {..*} $cmdline]} {
                set cmdline [string range $cmdline 1 end]
            }
            lappend State(data) $cmdline
        }
        return
    }

    # Process SMTP commands (case insensitive)
    set cmd [string toupper [lindex [split $cmdline] 0]]
    if {[lsearch $commands $cmd] != -1} {
        if {[info proc $cmd] == {}} {
            Puts $channel "500 $cmd not implemented"
        } else {
            # If access denied then client can only issue QUIT.
            if {$State(access) == "denied" && $cmd != "QUIT" } {
                Puts $channel "503 bad sequence of commands"
            } else {
                set r [eval $cmd $channel [list $cmdline]]
            }
        }
    } else {
        Puts $channel "500 Invalid command"
    }

    return
}

# -------------------------------------------------------------------------
# Description:
#  Generate a random ASCII character for use in mail identifiers.
#
proc ::smtpd::uidchar {} {
    set c .
    while {! [string is alnum $c]} {
        set n [expr {int(rand() * 74 + 48)}]
        set c [format %c $n]
    }
    return $c
}

# Description:
#  Generate a unique random identifier using only ASCII alphanumeric chars.
#
proc ::smtpd::uid {} {
    set r {}
    for {set cn 0} {$cn < 12} {incr cn} {
        append r [uidchar]
    }
    return $r
}

# -------------------------------------------------------------------------
# Description:
#   Calculate the local offset from GMT in hours for use in the timestamp
#
proc ::smtpd::gmtoffset {} {
    set now [clock seconds]
    set lh [string trimleft [clock format $now -format "%H" -gmt false] 0]
    set zh [string trimleft [clock format $now -format "%H" -gmt true] 0]
    if {$lh == "" || $zh == ""} {
        set off 0
    } else {
        set off [expr {$zh - $lh}]
    }
    if {$off > 0} {
        set off [format "+%02d00" $off]
    } else {
        set off [format "-%02d00" [expr {abs($off)}]]
    }
    return $off
}

# -------------------------------------------------------------------------
# Description:
#   Generate a standard SMTP compliant timestamp. That is a local time but with
#   the timezone represented as an offset.
#
proc ::smtpd::timestamp {} {
    set ts [clock format [clock seconds] \
                -format "%a, %d %b %Y %H:%M:%S" -gmt false]
    append ts " " [gmtoffset]
    return $ts
}

# -------------------------------------------------------------------------
# Description:
#   Get the servers ip address (from http://purl.org/mini/tcl/526.html)
#
proc ::smtpd::server_ip {} {
    set me [socket -server xxx -myaddr [info hostname] 0]
    set ip [lindex [fconfigure $me -sockname] 0]
    close $me
    return $ip
}

# -------------------------------------------------------------------------
# Description:
#   deliver is called once a mail transaction is completed and there is
#   no deliver procedure defined
#   The configured -deliverMIME procedure is called with a MIME token.
#   If no such callback is defined then try the -deliver option and use
#   the old API.
#
proc ::smtpd::deliver {channel} {
    set deliverMIME [cget deliverMIME]
    if { $deliverMIME != {} \
            && [state $channel from] != {} \
            && [state $channel to] != {} \
            && [state $channel data] != {} } {
        
        # create a MIME token from the mail message.        
        set tok [mime::initialize -string \
                [join [state $channel data] "\n"]]
#        mime::setheader $tok "From" [state $channel from]
#        foreach recipient [state $channel to] {
#            mime::setheader $tok "To" $recipient -mode append
#        }
        
        # catch and rethrow any errors.
        set err [catch {$deliverMIME $tok} msg]
        mime::finalize $tok -subordinates all
        if {$err} {
            log::log debug "error in deliver: $msg"
            return -code error -errorcode $::errorCode \
                    -errorinfo $::errorInfo $msg
        }        
        
    } else {
        # Try the old interface
        deliver_old $channel
    }
}

# -------------------------------------------------------------------------
# Description:
#   Deliver is called once a mail transaction is completed (defined as the
#   completion of a DATA command). The configured -deliver procedure is called
#   with the sender, list of recipients and the text of the mail.
#
proc ::smtpd::deliver_old {channel} {
    set deliver [cget deliver]
    if { $deliver != {} \
             && [state $channel from] != {} \
             && [state $channel to] != {} \
             && [state $channel data] != {} } {
        if {[catch {$deliver [state $channel from] \
                        [state $channel to] \
                        [state $channel data]} msg]} {
            log::log debug "error in deliver: $msg"
            return -code error -errorcode $::errorCode \
                    -errorinfo $::errorInfo $msg
        }
    }
}

# -------------------------------------------------------------------------
proc ::smtpd::split_address {address} {
    set start [string first < $address]
    set end [string last > $address]
    set addr [string range $address $start $end]
    incr end
    set opts [string trim [string range $address $end end]]
    return [list $addr $opts]
}

# -------------------------------------------------------------------------
# The SMTP Commands
# -------------------------------------------------------------------------
# Description:
#   Initiate an SMTP session
# Reference:
#   RFC2821 4.1.1.1
#
proc ::smtpd::HELO {channel line} {
    variable options

    if {[state $channel domain] != {}} {
        Puts $channel "503 bad sequence of commands"
        log::log debug "HELO received out of sequence."
        return
    }

    set r [regexp -nocase {^HELO\s+([-\w\.]+)\s*$} $line -> domain]
    if {$r == 0} {
        Puts $channel "501 Syntax error in parameters or arguments"
        log::log debug "HELO received \"$line\""
        return
    }
    Puts $channel "250-$options(serveraddr) Hello $domain\
                     \[[state $channel client_addr]\], pleased to meet you"
    Puts $channel "250 Ready for mail."
    state $channel domain $domain
    log::log debug "HELO on $channel from $domain"
    return
}

# -------------------------------------------------------------------------
# Description:
#   Initiate an ESMTP session
# Reference:
#   RFC2821 4.1.1.1
proc ::smtpd::EHLO {channel line} {
    variable options
    variable extensions

    if {[state $channel domain] != {}} {
        Puts $channel "503 bad sequence of commands"
        log::log debug "EHLO received out of sequence."
        return
    }

    set r [regexp -nocase {^EHLO\s+([-\w\.]+)\s*$} $line -> domain]
    if {$r == 0} {
        Puts $channel "501 Syntax error in parameters or arguments"
        log::log debug "EHLO received \"$line\""
        return
    }
    Puts $channel "250-$options(serveraddr) Hello $domain\
                     \[[state $channel client_addr]\], pleased to meet you"
    foreach {extn opts} [array get extensions] {
        Puts $channel [string trimright "250-$extn $opts"]
    }
    Puts $channel "250 Ready for mail."
    state $channel domain $domain
    log::log debug "EHLO on $channel from $domain"
    return
}

# -------------------------------------------------------------------------
# Description:
# Reference:
#   RFC2821 4.1.1.2
#
proc ::smtpd::MAIL {channel line} {
    set r [regexp -nocase {^MAIL FROM:\s*(.*)} $line -> from]
    if {$r == 0} {
        Puts $channel "501 Syntax error in parameters or arguments"
        log::log debug "MAIL received \"$line\""
        return
    }
    if {[catch {
        set from [split_address $from]
        set opts [lindex $from 1]
        set from [lindex $from 0]
        eval array set addr [mime::parseaddress $from]
    } msg]} {
        set addr(error) $msg
    }
    if {$addr(error) != {} } {
        log::log debug "MAIL failed $addr(error)"
        Puts $channel "501 Syntax error in parameters or arguments"
        return
    }

    if {[cget -validate_sender] != {}} {
        if {[catch {eval [cget -validate_sender] $addr(address)}]} {
            # this user has been denied
            log::log info "MAIL denied user $addr(address)"
            Puts $channel "553 Requested action not taken:\
                            mailbox name not allowed"
            return
        }
    }

    log::log debug "MAIL FROM: $addr(address)"
    state $channel from $from
    state $channel options $opts
    Puts $channel "250 OK"
    return
}

# -------------------------------------------------------------------------
# Description:
#   Specify a recipient for this mail. This command may be executed multiple
#   times to contruct a list of recipients. If a -validate_recipient 
#   procedure is configured then this is used. An error from the validation
#   procedure indicates an invalid or unacceptable mailbox.
# Reference:
#   RFC2821 4.1.1.3
# Notes:
#   The postmaster mailbox MUST be supported. (RFC2821: 4.5.1)
#
proc ::smtpd::RCPT {channel line} {
    set r [regexp -nocase {^RCPT TO:\s*(.*)} $line -> to]
    if {$r == 0} {
        Puts $channel "501 Syntax error in parameters or arguments"
        log::log debug "RCPT received \"$line\""
        return
    }
    if {[catch {
        set to [split_address $to]
        set opts [lindex $to 1]
        set to [lindex $to 0]
        eval array set addr [mime::parseaddress $to]
    } msg]} {
        set addr(error) $msg
    }

    if {$addr(error) != {}} {
        log::log debug "RCPT failed $addr(error)"
        Puts $channel "501 Syntax error in parameters or arguments"
        return
    }

    if {[string match -nocase "postmaster" $addr(local)]} {
        # we MUST support this recipient somehow as mail.
        log::log notice "RCPT to postmaster"
    } else {
        if {[cget -validate_recipient] != {}} {
            if {[catch {eval [cget -validate_recipient] $addr(address)}]} {
                # this recipient has been denied
                log::log info "RCPT denied mailbox $addr(address)"
                Puts $channel "553 Requested action not taken:\
                            mailbox name not allowed"
                return
            }
        }
    }

    log::log debug "RCPT TO: $addr(address)"
    set recipients {}
    catch {set recipients [state $channel to]}
    lappend recipients $to
    state $channel to $recipients
    Puts $channel "250 OK"
    return
}

# -------------------------------------------------------------------------
# Description:
#   Begin accepting data for the mail payload. A line containing a single 
#   period marks the end of the data and the server will then deliver the
#   mail. RCPT and MAIL commands must have been executed before the DATA
#   command.
# Reference:
#   RFC2821 4.1.1.4
# Notes:
#   The DATA section is the only part of the protocol permitted to use non-
#   ASCII characters and non-CRLF line endings and some clients take
#   advantage of this. Therefore we change the translation option on the
#   channel and reset it once the DATA command is completed. See the
#   'service' procedure for the handling of DATA lines.
#   We also insert trace information as per RFC2821:4.4
#
proc ::smtpd::DATA {channel line} {
    variable version
    upvar [namespace current]::state_$channel State
    log::log debug "DATA"
    if { $State(from) == {}} {
        Puts $channel "503 bad sequence: no sender specified"
    } elseif { $State(to) == {}} {
        Puts $channel "503 bad sequence: no recipient specified"
    } else {
        Puts $channel "354 Enter mail, end with \".\" on a line by itself"
        set State(id) [uid]
        set State(indata) 1

        lappend trace "Return-Path: $State(from)"
        lappend trace "Received: from [state $channel domain]\
                   \[[state $channel client_addr]\]"
        lappend trace "\tby [info hostname] with tcllib smtpd ($version)\
                   id $State(id); [timestamp]"
        set State(data) $trace
        fconfigure $channel -translation auto ;# naughty: RFC2821:2.3.7
    }
    return
}

# -------------------------------------------------------------------------
# Description:
#   Reset the server state for this connection.
# Reference:
#   RFC2821 4.1.1.5
#
proc ::smtpd::RSET {channel line} {
    upvar [namespace current]::state_$channel State
    log::log debug "RSET on $channel"
    if {[catch {initializeState $channel} msg]} {
        log::log warning "RSET: $msg"
    }
    Puts $channel "250 OK"
    return
}

# -------------------------------------------------------------------------
# Description:
#   Verify the existence of a mailbox on the server
# Reference:
#   RFC2821 4.1.1.6
#
#proc ::smtpd::VRFY {channel line} {
#    # VRFY SP String CRLF
#}

# -------------------------------------------------------------------------
# Description:
#   Expand a mailing list.
# Reference:
#   RFC2821 4.1.1.7
#
#proc ::smtpd::EXPN {channel line} {
#    # EXPN SP String CRLF
#}

# -------------------------------------------------------------------------
# Description:
#   Return a help message.
# Reference:
#   RFC2821 4.1.1.8
#
#proc ::smtpd::HELP {channel line} {
#    # HELP SP String CRLF
#}

# -------------------------------------------------------------------------
# Description:
#   Perform no action.
# Reference:
#   RFC2821 4.1.1.9
#
proc ::smtpd::NOOP {channel line} {
    set str {}
    regexp -nocase {^NOOP (.*)$} -> str
    log::log debug "NOOP: $str"
    Puts $channel "250 OK"
    return
}

# -------------------------------------------------------------------------
# Description:
#   Terminate a session and close the transmission channel.
# Reference:
#   RFC2821 4.1.1.10
# Notes:
#   The server is only permitted to close the channel once it has received 
#   a QUIT message.
#
proc ::smtpd::QUIT {channel line} {
    variable options
    upvar [namespace current]::state_$channel State

    log::log debug "QUIT on $channel"
    Puts $channel "221 $options(serveraddr) Service closing transmission channel"
    close $channel
        
    # cleanup the session state array.
    unset State
    return
}

package provide smtpd $smtpd::version

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
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/soundex/ChangeLog.

1
2
3
4
5
6
2003-04-01  Andreas Kupries  <[email protected]>

	* soundex.tcl: New module for soundex algorithms.
	* soundex.man:
	* soundex.test:
	* pkgIndex.tcl:
<
<
<
<
<
<












Deleted modules/soundex/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 soundex 1.0 [list source [file join $dir soundex.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/soundex/soundex.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin soundex n 1.0]
[copyright {????, Algorithm: Donald E. Knuth}]
[copyright {2003, Documentation: Andreas Kupries <[email protected]>}]
[copyright {1998, Tcl port: Evan Rempel <[email protected]>}]
[moddesc   {Soundex}]
[titledesc {Soundex}]
[require Tcl 8.2]
[require soundex [opt 1.0]]
[description]
[para]

This package provides soundex algorithms which allow the
comparison of words based on their phonetic likeness.

[para]

Currently only an algorithm by Knuth is provided, which
is tuned to english names and words.

[list_begin definitions]

[call [cmd ::soundex::knuth] [arg string]]

Computes the soundex code of the input [arg string] using
Knuth's algorithm and returns it as the result of the
command.

[list_end]


[section EXAMPLES]

[example {
    % ::soundex::knuth Knuth
    K530
}]

[keywords soundex knuth {text comparison} {text likeness}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































Deleted modules/soundex/soundex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
# soundex.tcl --
#
#	Implementation of soundex in Tcl
#
# Copyright (c) 2003 by Andreas Kupries <[email protected]>
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# RCS: @(#) $Id: soundex.tcl,v 1.2 2003/04/11 19:21:16 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::soundex {}

## ------------------------------------------------------------
##
## I. Soundex by Knuth.

# This implementation of the Soundex algorithm is released to the public
# domain: anyone may use it for any purpose.  See if I care.

# N. Dean Pentcheff 1/13/89 Dept. of Zoology University of California Berkeley,
#    CA  94720 [email protected]
# TCL port by Evan Rempel 2/10/98 Dept Comp Services University of Victoria.
# [email protected]

# proc ::soundex::knuth ( string )
#
#   Given as argument: a character string. Returns: a static string, 4 characters long
#   This string is the Soundex key for the argument string.
#   Side effects and limitations:
#   Does not clobber the string passed in as the argument. No limit on
#   argument string length. Assumes a character set with continuously
#   ascending and contiguous letters within each case and within the digits
#   (e.g. this works for ASCII and bombs in EBCDIC. But then, most things
#   do.). Reference: Adapted from Knuth, D.E. (1973) The art of computer
#   programming; Volume 3: Sorting and searching.  Addison-Wesley Publishing
#   Company: Reading, Mass. Page 392.
#   Special cases: Leading or embedded spaces, numerals, or punctuation are squeezed
#   out before encoding begins.
#
#   Null strings or those with no encodable letters return the code 'Z000'.
#
#   Test data from Knuth (1973):
#   Euler   Gauss   Hilbert Knuth   Lloyd   Lukasiewicz
#   E460    G200    H416    K530    L300    L222

namespace eval ::soundex {
    variable  soundexKnuthCode
    array set soundexKnuthCode {
	a 0 b 1 c 2 d 3 e 0 f 1 g 2 h 0 i 0 j 2 k 2 l 4 m 5
	n 5 o 0 p 1 q 2 r 6 s 2 t 3 u 0 v 1 w 0 x 2 y 0 z 2
    }
}
proc ::soundex::knuth {in} {
    variable soundexKnuthCode
    set key ""

    # Remove the leading/trailing white space punctuation etc.

    set TempIn [string trim $in "\t\n\r .,'-"]

    # Only use alphabetic characters, so strip out all others
    # also, soundex index uses only lower case chars, so force to lower

    regsub -all {[^a-z]} [string tolower $TempIn] {} TempIn
    if {[string length $TempIn] == 0} {
	return Z000
    }
    set last [string index $TempIn 0]
    set key  [string toupper $last]
    set last $soundexKnuthCode($last)

    # Scan rest of string, stop at end of string or when the key is
    # full

    set count    1
    set MaxIndex [string length $TempIn]

    for {set index 1} {(($count < 4) && ($index < $MaxIndex))} {incr index } {
	set chcode $soundexKnuthCode([string index $TempIn $index])
	# Fold together adjacent letters sharing the same code
	if {![string equal $last $chcode]} {
	    set last $chcode
	    # Ignore code==0 letters except as separators
	    if {$last != 0} then {
		set key $key$last
		incr count
	    }
	}
    }
    return [string range ${key}0000 0 3]
}

package provide soundex 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































Deleted modules/soundex/soundex.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
# -*- tcl -*-
# soundex.test:  tests for the soundex 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) 2003 by Andreas Kupries <[email protected]>
#
# RCS: @(#) $Id: soundex.test,v 1.1 2003/04/01 21:24:21 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

package require soundex
puts "soundex [package present soundex]"

namespace import ::soundex::knuth

foreach {n in out} {
    1.0 Euler       E460
    1.1 Gauss       G200
    1.2 Hilbert     H416
    1.3 Knuth       K530
    1.4 Lloyd       L300
    1.5 Lukasiewicz L222
} {
    test soundex-$n {knuth soundex} {
	::soundex::knuth $in
    } $out
}

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































Deleted modules/stats/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
2002-04-16  Andreas Kupries  <[email protected]>

	* According to Brent Welch this module is DEPRECATED. Use
	  'counter' instead.

2001-09-05  Andreas Kupries  <[email protected]>

	* stats.tcl: Restricted export list to public API.
	  [456255]. Patch by Hemang Lavana
	  <[email protected]>

2001-07-10  Andreas Kupries <[email protected]>

	* stats.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* stats.tcl: Fixed dubious code reported by frink.

2000-10-02  Brent Welch <[email protected]>

	* modules/stats/stats.tcl: Added stats::htmlHistDisplayRow
	so that the calling page could define the overall table structure.

2000-10-01  Brent Welch <[email protected]>

	* modules/stats/stats.tcl: Fixed calculation of hourBase
	and minuteBase when secsPerMinute was not 60.

2000-09-23  Brent Welch <[email protected]>

	* modules/stats/stats.tcl: Time-based histograms were
	not displaying the 23rd hour nor the 59th minute.

2000-09-22  Brent Welch <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* 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 <[email protected]>

	* Created this module.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































Deleted modules/stats/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 stats 1.0 [list error "The stats package is deprecated, use counter instead"]
## package ifneeded stats 1.0 [list source [file join $dir stats.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/stats/stats.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: stats.n,v 1.3 2001/07/06 18:30:52 andreas_kupries Exp $
'\" 
.so man.macros
.TH stats n 1.0 Stats "Statistics and Counters"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::stats \- Procedures for counters, histograms, and statistics.
.SH SYNOPSIS
.BS
.sp
\fBstats::countInit\fR \fItag\fR \fIargs\fR
.sp
\fBstats::count\fR \fItag {delta 1} args\fR
.sp
\fBstats::countReset\fR \fItag\fR
.sp
\fBstats::countGet\fR \fItag args\fR
.sp
\fBstats::countStart\fR \fItag\fR
.sp
\fBstats::countStop\fR \fItag\fR
.sp
\fBstats::countExists\fR \fItag\fR
.sp
\fBstats::countNames\fR \fItag\fR
.sp
\fBstats::histHtmlDisplay\fR \fItag args\fR
.BE
.SH DESCRIPTION
.PP
The \fB::stats\fR package provides a counter facility and
can compute statistics and histograms over the collected data.

.TP
\fBstats::countInit\fR \fItag args\fR
This defines a counter with the name \fItag\fP.
The \fIargs\fP determines the characteristics of the counter.
The \fIargs\fP are

.TP
\fB-group\fR \fIname\fR
Keep a grouped counter where the name of the histogram bucket
is passed into \fBstats::count\fP.

.TP
\fB-hist\fR \fIbucketsize\fR
Accumulate the counter into histogram buckets of size
\fIbucketsize\fP.  For example, if the samples are millisecond
time values and \fIbucketsize\fP 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.

.TP
\fB-hist2x\fR \fIbucketsize\fR
Accumulate the statistic into histogram buckets.
The size of the first bucket is 
\fIbucketsize\fP, each other bucket holds values
2 times the size of the previous bucket.
For example, if \fIbucketsize\fP 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.

.TP
\fB-hist10x\fR \fIbucketsize\fR
Accumulate the statistic into histogram buckets.
The size of the first bucket is 
\fIbucketsize\fP, each other bucket holds values
10 times the size of the previous bucket.
For example, if \fIbucketsize\fP 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.

.TP
\fB-lastn\fR \fIN\fR
Save the last \fIN\fP values of the counter to maintain
a "running average" over the last \fIN\fP values.

.TP
\fB-timehist\fR \fIsecsPerMinute\fR
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
\fIsecsPerMinute\fP, 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 stats package keeps all time-based histograms in sync, so the first
\fIsecsPerMinute\fP value seen by the package is used for all subsequent
time-based histograms.

.TP
\fBstats::count\fR \fItag {delta 1} {instance {}}\fR
Increment the counter identified by \fItag\fP.
The default increment is 1, although you can increment
by any value, integer or real, by specifying \fIdelta\fP.
You must declare each counter with \fBstats::countInit\fP to define
the characteristics of counter before you start to use it.
If the counter type is \fB-group\fP, then the counter
identified by \fIinstance\fP is incremented.

.TP
\fBstats::countStart\fR \fItag instance\fR
Record the starting time of an interval.
The \fItag\fP is the name of the counter defined as
a \fB-hist\fP value-based histogram.
The \fIinstance\fP is used to distinguish this interval from
any other intervals that might be overlapping this one.

.TP
\fBstats::countStop\fR \fItag instance\fR
Record the ending time of an interval.
The delta time since the corresponding \fBcountStart\fP call
for \fIinstance\fP is recorded in the histogram
identified by \fItag\fP.

.TP
\fBstats::countGet\fR \fItag args\fR
Return statistics about a counter
identified by \fItag\fP.
The \fIargs\fP determine what value to return:
.TP
\fB-total\fP
Return the total value of the counter.  This is the default
if \fIargs\fP is not specified.
.TP
\fB-totalVar\fP
Return the name of the total variable.  Useful for
specifying with -textvariable in a Tk widget.
.TP
\fB-N\fP
Return the number of samples accumulated into the counter.
.TP
\fB-avg\fP
Return the average of samples accumulated into the counter.
.TP
\fB-avgn\fP
Return the average over the last \fIN\fP samples taken.
The \fIN\fP value is set in the \fBstats::countInit\fP call.
.TP
\fB-hist\fP \fIbucket\fP
If \fIbucket\fP 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.
.TP
\fB-histVar\fP
Return the name of the histogram array variable.
.TP
\fB-histHour\fP
Return the complete hourly histogram
in array get format sorted by bucket.
.TP
\fB-histHourVar\fP
Return the name of the hourly histogram array variable.
.TP
\fB-histDay\fP
Return the complete daily histogram
in array get format sorted by bucket.
.TP
\fB-histDayVar\fP
Return the name of the daily histogram array variable.
.TP
\fB-resetDate\fP
Return the clock seconds value recorded when the
counter was last reset.
.TP
\fB-all\fP
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.

.TP
\fBstats::countExists\fR \fItag\fR
Returns 1 if the counter is defined.

.TP
\fBstats::countNames\fR
Returns a list of all counters defined.

.TP
\fBstats::histHtmlDisplay\fR \fItag args\fR
Generate HTML to display a histogram for a counter.
The \fIargs\fP control the format of the display.
They are:

.TP
\fB-title\fI string\fP
Label to display above bar chart
.TP
\fB-unit\fI unit\fP
Specify \fBminutes\fP, \fBhours\fP, or \fBdays\fP for the time-base histograms.
For value-based histograms, the \fIunit\fP is used in the title.
.TP
\fB-images\fI url\fP
URL of /images directory.
.TP
\fB-gif\fI filename\fP
Image for normal histogram bars.
The \fIfilename\fP is relative to the \fP-images\fP directory.
.TP
\fB-ongif\fI filename\fP
Image for the active histogram bar.
The \fIfilename\fP is relative to the \fP-images\fP directory.
.TP
\fB-max\fI N\fP
Maximum number of value-based buckets to display.
.TP
\fB-height\fI N\fP
Pixel height of the highest bar.
.TP
\fB-width\fI N\fP
Pixel width of each bar.
.TP
\fB-skip\fI N\fP
Buckets to skip when labeling value-based histograms.
.TP
\fB-format\fI string\fP
Format used to display labels of buckets.
.TP
\fB-text\fI boolean\fP
If 1, a text version of the histogram is dumped,
otherwise a graphical one is generated.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































Deleted modules/stats/stats.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
# stats.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: stats.tcl,v 1.18 2002/08/31 06:27:47 andreas_kupries Exp $

package provide stats 1.0

namespace eval stats:: {

    # Variables of name stats::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 countInit countReset count countExists countGet countNames
    namespace export histHtmlDisplay histHtmlDisplayRow histHtmlDisplayBarChart
    namespace export countStart countStop
}

# stats::countInit --
#
#	Set up a counter.
#
# Arguments:
#	tag	The identifier for the counter.  Pass this to stats::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 stats::countInit {tag args} {
    upvar #0 stats::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 stats::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 stats::H-$tag histogram
		upvar #0 stats::Hour-$tag hourhist
		upvar #0 stats::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 stats::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 stats::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 stats::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 stats::H-$tag histogram
		if {[info exists histogram]} {
		    unset histogram
		}
		set counter(bucketsize) $value
		set counter(mult) 1
	    }
	    -hist2x {
		upvar #0 stats::H-$tag histogram
		if {[info exists histogram]} {
		    unset histogram
		}
		set counter(bucketsize) $value
		set counter(mult) 2
	    }
	    -hist10x {
		upvar #0 stats::H-$tag histogram
		if {[info exists histogram]} {
		    unset histogram
		}
		set counter(bucketsize) $value
		set counter(mult) 10
	    }
	    -histlog {
		upvar #0 stats::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 ""
}

# stats::countReset --
#
#	Reset a counter.
#
# Arguments:
#	tag	The identifier for the counter.
#
# Results:
#	None.
#
# Side Effects:
#	Deletes the counter and calls stats::countInit again for it.

proc stats::countReset {tag args} {
    upvar #0 stats::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 stats::H-$tag histogram
	    if {[info exists histogram]} {
		unset histogram
	    }
	    set args [list -group $counter(group)]
	}
	-lastn {
	    upvar #0 stats::V-$tag vector
	    if {[info exists vector]} {
		unset vector
	    }
	    set args [list -lastn $counter(lastn)]
	}
	-hist -
	-hist10x -
	-histlog -
	-hist2x {
	    upvar #0 stats::H-$tag histogram
	    if {[info exists histogram]} {
		unset histogram
	    }
	    set args [list $counter(type) $counter(bucketsize)]
	}
	-timehist {
	    foreach h [list stats::H-$tag stats::Hour-$tag stats::Day-$tag] {
		upvar #0 $h histogram
		if {[info exists histogram]} {
		    unset histogram
		}
	    }
	    set args [list -timehist $stats::secsPerMinute]
	}
	default {
	    error "Unknown counter type \"$counter(type)\""
	}
    }
    unset counter
    eval {stats::countInit $tag} $args
    set counter(resetDate) [clock seconds]
    return ""
}

# stats::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 stats::count {tag {delta 1} args} {
    upvar #0 stats::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 stats::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 stats::V-$tag vector
		set vector($counter(index)) $delta
		set counter(index) [expr {($counter(index) +1)%$counter(lastn)}]
	    }
	    -hist {
		upvar #0 stats::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 stats::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 stats::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 stats::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 {
		error "Unknown counter type \"$counter(type)\""
	    }
	}
#   }
    return
}

# stats::countExists --
#
#	Return true if the counter exists.
#
# Arguments:
#	tag	The counter identifier.
#
# Results:
#	1 if it has been defined.
#
# Side Effects:
#	None.

proc stats::countExists {tag} {
    upvar #0 stats::T-$tag counter
    return [info exists counter]
}

# stats::countGet --
#
#	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 stats::countGet {tag {option -total} args} {
    upvar #0 stats::T-$tag counter
    switch -- $option {
	-total {
	    return $counter(total)
	}
	-totalVar {
	    return ::stats::T-$tag\(total)
	}
	-N {
	    return $counter(N)
	}
	-avg {
	    if {$counter(N) == 0} {
		return 0
	    } else {
		return [expr {$counter(total) / double($counter(N))}]
	    }
	}
	-avgn {
	    upvar #0 stats::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 stats::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 ::stats::H-$tag
	}
	-histHour {
	    upvar #0 stats::Hour-$tag histogram
	    set result {}
	    foreach x [lsort -integer [array names histogram]] {
		lappend result $x $histogram($x)
	    }
	    return $result
	}
	-histHourVar {
	    return ::stats::Hour-$tag
	}
	-histDay {
	    upvar #0 stats::Day-$tag histogram
	    set result {}
	    foreach x [lsort -integer [array names histogram]] {
		lappend result $x $histogram($x)
	    }
	    return $result
	}
	-histDayVar {
	    return ::stats::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."
	}
    }
}

# stats::countNames --
#
#	Return the list of defined counters.
#
# Arguments:
#	none
#
# Results:
#	A list of counter tags.
#
# Side Effects:
#	None.

proc stats::countNames {} {
    set result {}
    foreach v [info vars ::stats::T-*] {
	if {[info exists $v]} {
	    # Declared arrays might not exist, yet
	    regsub -- ::stats::T- $v {} v
	    lappend result $v
	}
    }
    return $result
}

# stats::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 stats::MergeHour {interval} {
    variable hourIndex
    variable minuteBase
    variable hourBase
    variable tagsToMerge
    variable secsPerMinute

    after $interval [list stats::MergeHour $interval]
    if {![info exists hourBase] || $hourIndex == 0} {
	set hourBase $minuteBase
    }
    set minuteBase [clock seconds]

    foreach tag $tagsToMerge {
	upvar #0 stats::T-$tag counter
	upvar #0 stats::H-$tag histogram
	upvar #0 stats::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} {
	stats::MergeDay
    }

}
# stats::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 stats::MergeDay {} {
    variable dayIndex
    variable dayBase
    variable hourBase
    variable tagsToMerge

    # 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 stats::T-$tag counter
	upvar #0 stats::Day-$tag dayhist
	upvar #0 stats::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 mx $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
}

# stats::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 stats::histHtmlDisplay {tag args} {
    append result "<p>\n<table border=0 cellpadding=0 cellspacing=0>\n"
    append result [eval {stats::histHtmlDisplayRow $tag} $args]
    append result </table>
    return $result
}

# stats::histHtmlDisplayRow --
#
#	Create an html display of the histogram.
#
# Arguments:
#	See stats::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 stats::histHtmlDisplayRow {tag args} {
    upvar #0 stats::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} {
	stats::countReset $tag
	return "<!-- Reset $tag counter -->"
    }

    switch -glob -- $options(-unit) {
	min* {
	    upvar #0 stats::H-$tag histogram
	    set histname stats::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 stats::Hour-$tag histogram
	    set histname stats::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 stats::Day-$tag histogram
	    set histname stats::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 stats::H-$tag histogram
	    set histname stats::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 {
		error "Unknown unit of time \"$options(-unit)\""
	    }
	}

    } 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) [countGet $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>Maxmum</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 \
	    {stats::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
}

# stats::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 stats::histHtmlDisplayBarChart {tag histVar max curIndex time args} {
    upvar #0 ::stats::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) 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.

    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)} {
		append result "<td colspan=$skip><font size=1>$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 {
		error "Unknown unit of time \"$options(-unit)\""
	    }
	}
	# 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)} {
		append result "<td colspan=$skip><font size=1>$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
}

# stats::countStart --
#
#	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 stats::countStart {tag instance} {
    upvar #0 stats::Time-$tag time
    set time($instance) [list [clock clicks] \
	    [clock seconds]]
}

# stats::countStop --
#
#	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 stats::countStop {tag instance {func ::stats::countIdentity}} {
    upvar #0 stats::Time-$tag time

    if {![info exists time($instance)]} {
	# Extra call. Ignore so we can debug error cases.
	return
    }
    set now [list [clock clicks] \
	    [clock seconds]]
    set delMicros [expr {[lindex $now 0] - [lindex $time($instance) 0]}]
    set delSecond [expr {[lindex $now 1] - [lindex $time($instance) 1]}]
    unset time($instance)

    if {$delMicros < 0} {
	set delMicros [expr {1000000 + $delMicros}]
	incr delSecond -1
	if {$delSecond < 0} {
	    set delSecond 0
	}
    }
    stats::count $tag [$func $delSecond.[format %06d $delMicros]]
}

# stats::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 stats::countIdentity {x} {
    return $x
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/stats/stats.test.

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

package require tcltest
namespace import -force ::tcltest::*

catch {namespace delete stats}

proc Stamp {tag} {
    puts stderr "[clock format [clock seconds]] [clock clicks -milliseconds] $tag"
}

set myFile [file join [file dirname [info script]] stats.tcl]
source $myFile
package require stats 1.0

test stats-1.1 {stats::countInit} {
    catch {stats::countInit} err
} {1}

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 stats-simple {stats::count} {
    stats::countInit simple
    stats::count simple
    stats::count simple
    stats::count simple
    stats::countGet simple
} {3}
puts "simple [time {stats::count simple} 100]"

test stats-avg {stats::count} {
    stats::countInit avg
    stats::count avg 2.2
    stats::count avg 3.3
    stats::count avg 9.8
    stats::countGet avg -avg
} {5.1}

test stats-avg {stats::count} {
    stats::countInit avg
    stats::countGet avg -avg
} {0}

test stats-lastn {averge over lastn} {
    stats::countInit lastn -lastn 4
    stats::count lastn 2.2
    stats::count lastn 4.6
    stats::countGet lastn -avgn
} {3.4}

test stats-lastn {averge over lastn} {
    stats::countInit lastn -lastn 4
    stats::count lastn 2.2
    stats::count lastn 3.3
    stats::count lastn 8.6
    stats::count lastn 4.1
    stats::count lastn 6.9
    stats::count lastn 0.4
    stats::countGet lastn -avgn
} {5.0}
puts "lastn [time {stats::count lastn 2.4} 100]"

test stats-lastn {lifetime average} {
    stats::countInit lastn -lastn 4
    stats::count lastn 2.2
    stats::count lastn 3.3
    stats::count lastn 8.6
    stats::count lastn 4.1
    stats::count lastn 6.9
    stats::count lastn 0.4
    stats::countGet lastn -avg
} {4.25}
puts "lastn [time {stats::count lastn 2.4} 100]"

test stats-hist {basic histogram} {
    stats::countInit hist -hist 10
    stats::count hist 2.2
    stats::count hist 18.6
    stats::count hist 14.1
    stats::count hist 26.9
    stats::count hist 20.4
    stats::count hist 23.3
    stats::count hist 53.3
    stats::countGet hist -hist
} {0 1 1 2 2 3 5 1}
test stats-hist {histogram average} {
    stats::countInit hist -hist 10
    stats::count hist 2.2
    stats::count hist 18.6
    stats::count hist 14.1
    stats::count hist 26.9
    stats::count hist 20.4
    stats::count hist 23.3
    stats::count hist 53.3
    stats::countGet hist -avg
} {22.6857142857}
puts "hist [time {stats::count hist 2.4} 100]"

test stats-hist2x {stats::count} {
    stats::countInit hist -hist2x 10
    stats::count hist 8
    stats::count hist 18
    stats::count hist 28
    stats::count hist 38
    stats::count hist 48
    stats::count hist 58
    stats::count hist 68
    stats::count hist 78
    stats::count hist 178
    stats::count hist 478
    stats::countGet hist -hist
} {0 1 1 1 2 2 3 4 5 1 6 1}
puts "hist2x [time {stats::count hist 50} 100]"

test stats-hist10x {stats::count} {
    stats::countInit hist -hist10x 10
    stats::count hist 8
    stats::count hist 18
    stats::count hist 28
    stats::count hist 38
    stats::count hist 48
    stats::count hist 58
    stats::count hist 68
    stats::count hist 78
    stats::count hist 178
    stats::count hist 478
    stats::count hist 1478
    stats::count hist 1478000
    stats::countGet hist -hist
} {0 1 1 7 2 2 3 1 6 1}

test stats-histlog {stats::count} {
    stats::countInit histlog -histlog 10
    stats::count histlog 0.1
    stats::count histlog 0.5
    stats::count histlog 0.9
    stats::count histlog 1.0
    stats::count histlog 2
    stats::count histlog 3
    stats::count histlog 5
    stats::count histlog 10
    stats::count histlog 30
    stats::count histlog 50
    stats::count histlog 100
    stats::count histlog 300
    stats::count histlog 500
    stats::count histlog 1000
    stats::countGet histlog -hist
} {0 1 1 7 2 2 3 1 6 1}

test stats-timehist {stats::count} {
    stats::countInit hits -timehist 4
    catch {puts stderr "Pausing during timehist tests"}
    stats::count hits 2
    # We need to reach in and find out what bucket was used
    array set info [stats::countGet hits -all]
    set min0 $info(lastMinute)
    after [expr 4000]
    stats::count hits 4
    after [expr 4000]
    stats::count hits 8
    foreach {n v} [stats::countGet hits -hist] {
	if {$v > 0} {
	    lappend result [expr {$n - $min0}] $v
	}
    }
    set result
} {0 2 1 4 2 8}

puts "timehist [time {stats::count hits} 100]"

test stats-countNames {stats::countNames} {
    stats::countInit simple
    stats::countInit avg
    stats::countInit lastn -lastn 4
    stats::countInit hist -hist 10
    stats::countInit hits -timehist 4
    lsort [stats::countNames]
} {avg hist hits lastn simple}

test stats-countExists {stats::countExist} {
    stats::countInit simple
    stats::countInit lastn -lastn 4
    unset stats::T-lastn 
    list [stats::countExists simple] [stats::countExists lastn]
} {1 0}

test stats-countReset {stats::countReset} {
    stats::countInit simple
    stats::count simple 1
    stats::count simple 1
    stats::count simple 1
    stats::countReset simple
    stats::countGet simple
} {0}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































Deleted modules/stooop/ChangeLog.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
2003-04-11  Andreas Kupries  <[email protected]>

	* stooop.tcl:
	* stooop.man:
	* pkgIndex.tcl: Set version of the package to to 4.4.1 throughout.

2003-04-01  Andreas Kupries  <[email protected]>

	* stooop.man:
	* stooop.htm: Renamed to 'stoop_man.html'. Updated doctools
	  documentation to refer to manual under the new name. This
	  resolves the circular link reported in Tcllib SF bug #687923.

2003-01-16  Andreas Kupries  <[email protected]>

	* stooop.man: More semantic markup, less visual one.

2002-04-15  Andreas Kupries  <[email protected]>

	* stooop.man: Added doctools manpage.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted modules/stooop/README.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
This is stooop (a Simple Tcl Only Object Oriented Programming scheme)
version 4.2. Stooop is implemented in a single sourceable file and
uses simple techniques to provide object orientation to the great Tcl
language.

If you know C++ or Java, stooop will be easy to use for you. Using the
familiar class, new, delete and virtual keywords and a few coding
conventions, you can start object oriented Tcl code right away, as the
following simple example shows:


source stooop.tcl
namespace import stooop::*

class circle {
    proc circle {this canvas diameter} {
        set ($this,diameter) $diameter
        set ($this,canvas) $canvas
        set ($this,id) [$canvas create oval 0 0 $diameter $diameter]
    }
    proc ~circle {this} {
        $($this,canvas) delete $($this,id)
    }
    proc move {this x y} {
        $($this,canvas) move $($this,id) $x $y
    }
}

pack [canvas .canvas]
set c [new circle .canvas 50]
update; after 1000
circle::move $c 10 10
update; after 1000
delete $c


Stooop supports single and multiple inheritance, data encapsulation
(all member data is public), dynamic binding, nested classes, object
copy, runtime type identification, optional runtime procedure and data
access checking as well as tracing.

As stooop is entirely written in Tcl, it will run on all Tcl supported
platforms, including Windows and the Mac Intosh, if you have Tcl
version 8.3 or above.

The class, new, delete, virtual and classof commands are implemented
as Tcl procedures.

Stooop was implemented with a constant concern for performance. Member
data is stored in Tcl associative arrays, which are best for random
data access. Classes are implemented as namespaces to improve
encapsulation and reduce naming interferences. Object oriented helper
code is kept as small and as efficient as possible. Typically, only a
couple of Tcl lines are added to a member procedure definition.
Program startup time will be slightly increased due to some class and
member procedures preprocessing, but runtime overhead is kept to a
strict minimum. Use of object oriented techniques may actually improve
the performance of your code.

A full HTML documentation, simple demonstration script, graphical
demonstration with composite pattern and test files are provided. You
may also run the test suite and look at the test scripts for
examples. There is also a utility for creating packages (in the Tcl
sense) from stooop compatible class files.

There is a companion package to stooop: scwoop (a Simple Composite
Widget Object Oriented Package). Scwoop is implemented in a single
sourceable file and uses simple techniques to provide composite widget
(also known as mega widget) support to the great Tk widget library.
Moodss (a Modular Object Oriented Dynamic SpreadSheet) implemented
with stooop, scwoop, tkTable and BLT is also available on my website
(at http://jfontain.free.fr/).

Whether you like it (or hate it), please let me know. I would like to
hear about bugs and improvements you would like to see. I will correct
the bugs quickly, especially if you send me a test script.

Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
This code may be distributed under the same terms as Tcl.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































Deleted modules/stooop/mkpkgidx.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
# command line:
# $ interpreter mkpkgidx.tcl -p package1.n.n -p package2 -p package3.n ...
#     packageName file1 file2 ...
# use wish as interpreter instead of tclsh in order to handle graphical packages

# Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: mkpkgidx.tcl,v 1.2 2001/11/27 11:46:52 jfontain Exp $

# this utility must be used to create the package index file for a package that
# uses stooop.
# it differs from the tcl pkg_mkIndex procedure in the way it sources files.
# since base classes can usually be found in files separate from the derived
# class source file, sourcing each file in a different interpreter (as is done
# in the pkg_mkIndex procedure) results in an error for stooop that catches the
# fact that the base class is not defined. the solution is to use a single
# interpreter which will source the class files in order (base classes first at
# the user's responsibility). since stooop is loaded in that single interpreter,
# inheritance problems and others are automatically caught in the process.
# the generated package index file is fully compatible with the tcl generated
# ones.
# the stooop library makes sure that base classes source files are automatically
# sourced when a derived class is defined (see the stooop.tcl source file for
# more information).
# if your software requires one or more packages, you may force their loading
# by using the -p arguments. each package version number is optionally appended
# to the package name and follows the same rules as the Tcl package require
# command
# example: $ tclsh -p switched.1 -p scwoop foo bar.tcl barfoo.tcl foobar.tcl ...

if {[catch {package require stooop 4}]} {
    # in case stooop package is not installed
    source stooop.tcl
}
namespace import stooop::*

proc indexData {packageName files} {
    global auto_index

    set index "# Package index file created with stooop version [package provide stooop] for stooop packages\n"
    set data {}

    foreach command [info commands] {
        set defined($command) {}
    }

    foreach file $files {
        # source at global level to avoid variable names collisions:
        uplevel #0 source [list $file]

        catch {unset newCommands}                    ;# empty new commands array
        foreach command [info commands] {
            # check new commands at the global level
            # filter out tk widget commands and ignore commands eventually
            # loaded from a package required by the new commands
            if {
                [string match .* $command]||[info exists defined($command)]||
                [info exists auto_index($command)]||\
                [info exists auto_index(::$command)]
            } continue
            set newCommands($command) {}
            set defined($command) {}
        }
        # check new classes, which actually are namespaces:
        foreach class [array name stooop::declared] {
            if {![info exists declared($class)]} {
                # check new commands at the class namespace level:
                foreach command [info commands ::${class}::*] {
                    # ignore commands eventually loaded from a package required
                    # by the new commands
                    if {\
                        [info exists defined($command)]||\
                        [info exists auto_index($command)]||\
                        [info exists auto_index(::$command)]\
                    } continue
                    set newCommands($command) {}
                    set defined($command) {}
                }
                set declared($class) {}
            }
        }
        # so far only sourceable file, not shared libraries, are handled
        lappend data [list $file source [lsort [array names newCommands]]]
    }
    set version [package provide $packageName]
    append index "\npackage ifneeded $packageName $version \[list tclPkgSetup \$dir $packageName $version [list $data]\]"
    return $index
}

proc printUsage {exitCode} {
    global argv0

    puts stderr "usage: $argv0 \[\[-p package.n.n\] \[-p package.n.n\] ...\] moduleName tclFile tclFile ..."
    exit $exitCode
}

# first gather eventual packages:
for {set index 0} {$index<[llength $argv]} {incr index} {
    if {[string compare [lindex $argv $index] -p]!=0} break
    set version {}
    scan [lindex $argv [incr index]] {%[^.].%s} name version
    eval package require $name $version
}

set argv [lrange $argv $index end]                   ;# keep remaining arguments
if {[llength $argv]<2} {
    printUsage 1
}

puts [open pkgIndex.tcl w] [indexData [lindex $argv 0] [lrange $argv 1 end]]
exit                                                     ;# in case wish is used
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































Deleted modules/stooop/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
# Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: pkgIndex.tcl,v 1.5 2003/04/11 20:18:45 andreas_kupries Exp $

# Since stooop redefines the proc command and the default package facility will
# only load the stooop package at the first unknown command, proc being
# obviously known by default, forcing the loading of stooop is mandatory prior
# to the first proc declaration.

package ifneeded stooop 4.4.1 [list source [file join $dir stooop.tcl]]

# the following package index instruction was generated using:
#   "tclsh mkpkgidx.tcl switched switched.tcl"
# (comment out the following line if you do not want to use the switched class
# as a package)
package ifneeded switched 2.2 [list tclPkgSetup $dir switched 2.2 {{switched.tcl source {::switched::_copy ::switched::cget ::switched::complete ::switched::configure ::switched::description ::switched::descriptions ::switched::options ::switched::switched ::switched::~switched}}}]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































Deleted modules/stooop/stooop.man.

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

This package provides commands to extend Tcl in an object oriented
manner, using a familiar C++ like syntax and behaviour. Stooop only
introduces a few new commands: [cmd class], [cmd new], [cmd delete],
[cmd virtual] and [cmd classof]. Along with a few coding conventions,
that is basically all you need to know to use stooop. Stooop is meant
to be as simple to use as possible.

[para]

This manual is very succinct and is to be used as a quick reminder for
the programmer, who should have read the thorough [uri stooop_man.html]
HTML documentation at this point.

[list_begin definitions]


[call [cmd ::stooop::class] [arg {name body}]]

This command creates a class. The body, similar in contents to a Tcl
namespace (which a class actually also is), contains member procedure
definitions. Member procedures can also be defined outside the class
body, by prefixing their name with [const class::], as you would
proceed with namespace procedures.

[list_begin definitions]

[lst_item "[cmd proc] [arg class] \{[const this] [opt [arg {arg arg ...}]]\} [opt "[arg base] \{[opt [arg {arg arg ...}]]\} ..."] [arg body]"]

This is the constructor procedure for the class. It is invoked
following a [cmd new] invocation on the class. It must have the same
name as the class and a first argument named [const this]. Any number
of base classes specifications, including arguments to be passed to
their constructor, are allowed before the actual body of the
procedure.

[lst_item "[cmd proc] ~[arg class] \{[const this]\} [arg body]"]

This is the destructor procedure for the class. It is invoked
following a [cmd delete] invocation. Its name must be the
concatenation of a single [const ~] character followed by the class
name (as in C++). It must have a single argument named [const this].

[lst_item "[cmd proc] [arg name] \{[const this] [opt [arg {arg arg ...}]]\} [arg body]"]

This is a member procedure of the class, as its first argument is
named [const this]. It allows a simple access of member data for the
object referenced by [const this] inside the procedure. For example:

[example {
   set ($this,data) 0
}]

[lst_item "[cmd proc] [arg name] \{[opt [arg {arg arg ...}]]\} [arg body]"]

This is a static (as in C++) member procedure of the class, as its
first argument is not named [const this]. Static (global) class data
can be accessed as in:

[example {
   set (data) 0
}]

[lst_item "[cmd proc] [arg class] \{[const {this copy}]\} [arg body]"]

This is the optional copy procedure for the class. It must have the
same name as the class and exactly 2 arguments named [const this] and
[const copy]. It is invoked following a [cmd new] invocation on an
existing object of the class.

[list_end]


[call [cmd ::stooop::new] [arg class] [opt [arg {arg arg ...}]]]

This command is used to create an object. The first argument is the
class name and is followed by the arguments needed by the
corresponding class constructor. A unique identifier for the object
just created is returned.

[call [cmd ::stooop::delete] [arg object] [opt [arg {object ...}]]]

This command is used to delete one or several objects. It takes one or
more object identifiers as argument(s).

[call [cmd ::stooop::virtual] [const proc] [arg name] \{[const this] [opt [arg {arg arg ...}]]\} [opt [arg {body}]]]

The [cmd virtual] specifier may be used on member procedures to
achieve dynamic binding. A procedure in a base class can then be
redefined (overloaded) in the derived class(es). If the base class
procedure is invoked on an object, it is actually the derived class
procedure which is invoked, if it exists. If the base class procedure
has no body, then it is considered to be a pure virtual and the
derived class procedure is always invoked.

[call [cmd ::stooop::classof] [arg object]]

This command returns the class of the existing object passed as single
parameter.

[call [cmd ::stooop::new] [arg object]]

This command is used to create an object by copying an existing
object. The copy constructor of the corresponding class is invoked if
it exists, otherwise a simple copy of the copied object data members
is performed.

[list_end]

[section DEBUGGING]

[list_begin definitions]

[lst_item {Environment variables}]


[list_begin definitions]

[lst_item [var STOOOPCHECKDATA]]

Setting this variable to any true value will cause stooop to check for
invalid member or class data access.

[lst_item [var STOOOPCHECKPROCEDURES]]

Setting this variable to any true value will cause stooop to check for
invalid member procedure arguments and pure interface classes
instanciation.

[lst_item [var STOOOPCHECKALL]]

Setting this variable to any true value will cause stooop to activate
both procedure and data member checking.

[lst_item [var STOOOPCHECKOBJECTS]]

Setting this variable to any true value will cause stooop to activate
object checking. The following stooop namespace procedures then become
available for debugging: [cmd printObjects], [cmd record] and
[cmd report].

[lst_item [var STOOOPTRACEPROCEDURES]]

Setting this environment variable to either [const stdout],

[const stderr] or a file name, activates procedure tracing. The
stooop library will then output to the specified channel 1 line of
informational text for each member procedure invocation.

[lst_item [var STOOOPTRACEPROCEDURESFORMAT]]

Defines the trace procedures output format. Defaults to
[const {"class: %C, procedure: %p, object: %O, arguments: %a"}].

[lst_item [var STOOOPTRACEDATA]]

Setting this environment variable to either [const stdout],

[const stderr] or a file name, activates data tracing. The stooop
library will then output to the specified channel 1 line of
informational text for each member data access.

[lst_item [var STOOOPTRACEDATAFORMAT]]

Defines the trace data output format. Defaults to 
[const {"class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v"}].

[lst_item [var STOOOPTRACEDATAOPERATIONS]]

When tracing data output, by default, all read, write and unsetting
accesses are reported, but the user can set this variable to any
combination of the letters [const r], [const w], and [const u] for
more specific tracing (please refer to the [cmd trace] Tcl manual page
for more information).

[lst_item [var STOOOPTRACEALL]]

Setting this environment variable to either [const stdout],

[const stderr] or a file name, enables both procedure and data
tracing.

[list_end]


[call [cmd ::stooop::printObjects] [opt [arg pattern]]]

Prints an ordered list of existing objects, in creation order, oldest
first. Each output line contains the class name, object identifier and
the procedure within which the creation occurred. The optional pattern
argument (as in the Tcl [cmd {string match}] command) can be used to
limit the output to matching class names.

[call [cmd ::stooop::record]]

When invoked, a snapshot of all existing stooop objects is
taken. Reporting can then be used at a later time to see which objects
were created or deleted in the interval.

[call [cmd ::stooop::report] [opt [arg pattern]]]

Prints the created and deleted objects since the [cmd ::stooop::record]
procedure was invoked last. If present, the pattern argument limits
the output to matching class names.

[list_end]

[section EXAMPLES]

Please see the full HTML documentation in [uri stooop_man.html].

[keywords class {object oriented} object C++]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































Deleted modules/stooop/stooop.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
'\"
'\" Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
'\" This code may be distributed under the same terms as Tcl.
'\"
'\" $Id: stooop.n,v 1.2 2001/12/10 09:07:31 jfontain Exp $
.so man.macros
.TH stooop n 1.0 Stooop "Simple Tcl Only Object Oriented Programming"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
::stooop \- Object oriented extension.
.SH SYNOPSIS
\fBpackage require Tcl 8.3\fR
.sp
\fBpackage require stooop 4.2\fR
.br
\fBnamespace import stooop::*\fR
.sp
\fBclass\fR \fIname body\fR
.sp
\fBnew\fR \fIclass ?arg arg ...?\fR
.sp
\fBdelete\fR \fIobject ?object ...?\fR
.sp
\fBvirtual\fR \fIproc name {\fR\fBthis\fR \fI?arg arg ...?} ?body?\fR
.sp
\fBclassof\fR \fIobject\fR
.sp
\fBnew\fR \fIobject\fR
.BE
.SH DESCRIPTION
.PP
This package provides commands to extend Tcl in an object oriented manner, using a familiar C++ like syntax and behaviour. Stooop only introduces a few new commands: \fBclass\fR, \fBnew\fR, \fBdelete\fR, \fBvirtual\fR and \fBclassof\fR. Along with a few coding conventions, that is basically all you need to know to use stooop. Stooop is meant to be as simple to use as possible. 
.sp
This manual is very succinct and is to be used as a quick reminder for the programmer, who should have read the thorough \fIstooop.html\fR HTML documentation at this point.
.TP
\fBclass\fR \fIname body\fR
This command creates a class. The body, similar in contents to a Tcl namespace (which a class actually also is), contains member procedure definitions. Member procedures can also be defined outside the class body, by prefixing their name with \fIclass::\fR, as you would proceed with namespace procedures.
.RS
.TP
\fIproc class {\fR\fBthis\fR \fI?arg arg ...?} ?base {?arg arg ...?} ...? body\fR
This is the constructor procedure for the class. It is invoked following a \fInew\fR invocation on the class. It must have the same name as the class and a first argument named \fIthis\fR. Any number of base classes specifications, including arguments to be passed to their constructor, are allowed before the actual body of the procedure.
.TP
\fIproc ~class {\fR\fBthis\fR\fI} body\fR
This is the destructor procedure for the class. It is invoked following a \fIdelete\fR invocation. Its name must be the concatenation of a single \fI~\fR character followed by the class name (as in C++). It must have a single argument named \fIthis\fR.
.TP
\fIproc name {\fR\fBthis\fR \fI?arg arg ...?} body\fR
This is a member procedure of the class, as its first argument is named \fIthis\fR. It allows a simple access of member data for the object referenced by \fIthis\fR inside the procedure. For example: \fIset ($this,data) 0\fR.
.TP
\fIproc name {?arg arg ...?} body\fR
This is a static (as in C++) member procedure of the class, as its first argument is not named \fIthis\fR. Static (global) class data can be accessed as in: \fIset (data) 0\fR.
.TP
\fIproc class {\fR\fBthis copy\fI} body\fR
This is the optional copy procedure for the class. It must have the same name as the class and exactly 2 arguments named \fIthis\fR and \fIcopy\fR. It is invoked following a \fInew\fR invocation on an existing object of the class.
.RE
.TP
\fBnew\fR \fIclass ?arg arg ...?\fR
This command is used to create an object. The first argument is the class name and is followed by the arguments needed by the corresponding class constructor. A unique identifier for the object just created is returned.
.TP
\fBdelete\fR \fIobject ?object ...?\fR
This command is used to delete one or several objects. It takes one or more object identifiers as argument(s).
.TP
\fBvirtual\fR \fIproc name {\fR\fBthis\fR \fI?arg arg ...?} ?body?\fR
The \fIvirtual\fR specifier may be used on member procedures to achieve dynamic binding. A procedure in a base class can then be redefined (overloaded) in the derived class(es). If the base class procedure is invoked on an object, it is actually the derived class procedure which is invoked, if it exists. If the base class procedure has no body, then it is considered to be a pure virtual and the derived class procedure is always invoked. 
.TP
\fBclassof\fR \fIobject\fR
This command returns the class of the existing object passed as single parameter.
.TP
\fBnew\fR \fIobject\fR
This command is used to create an object by copying an existing object. The copy constructor of the corresponding class is invoked if it exists, otherwise a simple copy of the copied object data members is performed.
.SH DEBUGGING
.TP
Environment variables
.RS
.TP
STOOOPCHECKDATA
Setting this variable to any true value will cause stooop to check for invalid member or class data access.
.TP
STOOOPCHECKPROCEDURES
Setting this variable to any true value will cause stooop to check for invalid member procedure arguments and pure interface classes instanciation.
.TP
STOOOPCHECKALL
Setting this variable to any true value will cause stooop to activate both procedure and data member checking.
.TP
STOOOPCHECKOBJECTS
Setting this variable to any true value will cause stooop to activate object checking. The following stooop namespace procedures then become available for debugging: \fIprintObjects\fR, \fIrecord\fR and \fIreport\fR.
.TP
STOOOPTRACEPROCEDURES
Setting this environment variable to either \fIstdout\fR, \fIstderr\fR or a file name, activates procedure tracing. The stooop library will then output to the specified channel 1 line of informational text for each member procedure invocation.
.TP
STOOOPTRACEPROCEDURESFORMAT
Defines the trace procedures output format. Defaults to \fI"class: %C, procedure: %p, object: %O, arguments: %a"\fR.
.TP
STOOOPTRACEDATA
Setting this environment variable to either \fIstdout\fR, \fIstderr\fR or a file name, activates data tracing. The stooop library will then output to the specified channel 1 line of informational text for each member data access.
.TP
STOOOPTRACEDATAFORMAT
Defines the trace data output format. Defaults to \fI"class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v"\fR.
.TP
STOOOPTRACEDATAOPERATIONS
When tracing data output, by default, all read, write and unsetting accesses are reported, but the user can set this variable to any combination of the \fIr\fR, \fIw\fR and \fIu\fR letters for more specific tracing (please refer to the \fItrace\fR Tcl manual page for more information).
.TP
STOOOPTRACEALL
Setting this environment variable to either \fIstdout\fR, \fIstderr\fR or a file name, enables both procedure and data tracing.
.RE
.TP
\fB::stooop::printObjects\fR \fI?pattern?\fR
Prints an ordered list of existing objects, in creation order, oldest first. Each output line contains the class name, object identifier and the procedure within which the creation occured. The optional pattern argument (as in the Tcl \fIstring match\fR command) can be used to limit the output to matching class names.
.TP
\fB::stooop::record\fR
When invoked, a snapshot of all existing stooop objects is taken. Reporting can then be used at a later time to see which objects were created or deleted in the interval.
.TP
\fB::stooop::report\fR \fI?pattern?\fR
Prints the created and deleted objects since the \fIstooop::record\fR procedure was invoked last. If present, the pattern argument limits the output to matching class names.
.SH EXAMPLES
Please see the \fIstooop.html\fR HTML documentation.
.SH KEYWORDS
class object oriented C++
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































Deleted modules/stooop/stooop.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
# stooop
# Simple Tcl Only Object Oriented Programming
# An object oriented extension to the Tcl programming language
#
# Copyright (c) 2002 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: stooop.tcl,v 1.7 2003/04/19 09:47:47 jfontain Exp $


# check whether empty named arrays and array unset are supported:
package require Tcl 8.3

package provide stooop 4.4

# rename proc before it is overloaded, ignore error in case of multiple
# inclusion of this file:
catch {rename proc _proc}

namespace eval ::stooop {
    variable check
    variable trace

    # no checking by default: use an empty instruction to avoid any performance
    # hit:
    set check(code) {}
    if {[info exists ::env(STOOOPCHECKALL)]&&$::env(STOOOPCHECKALL)} {
        array set ::env\
            {STOOOPCHECKPROCEDURES 1 STOOOPCHECKDATA 1 STOOOPCHECKOBJECTS 1}
    }
    set check(procedures) [expr {\
        [info exists ::env(STOOOPCHECKPROCEDURES)]&&\
        $::env(STOOOPCHECKPROCEDURES)\
    }]
    set check(data) [expr {\
        [info exists ::env(STOOOPCHECKDATA)]&&$::env(STOOOPCHECKDATA)\
    }]
    set check(objects) [expr {\
        [info exists ::env(STOOOPCHECKOBJECTS)]&&$::env(STOOOPCHECKOBJECTS)\
    }]
    if {$check(procedures)} {
        append check(code) {::stooop::checkProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEALL)]} {
        # use same channel for both traces
        set ::env(STOOOPTRACEPROCEDURES) $::env(STOOOPTRACEALL)
        set ::env(STOOOPTRACEDATA) $::env(STOOOPTRACEALL)
    }
    if {[info exists ::env(STOOOPTRACEPROCEDURES)]} {
        set trace(procedureChannel) $::env(STOOOPTRACEPROCEDURES)
        switch $trace(procedureChannel) {
            stdout - stderr {}
            default {
                # eventually truncate output file if it exists:
                set trace(procedureChannel) [open $::env(STOOOPTRACEPROCEDURES) w+]
            }
        }
        # default format:
        set trace(procedureFormat)\
            {class: %C, procedure: %p, object: %O, arguments: %a}
        # eventually override with user defined format:
        catch {set trace(procedureFormat) $::env(STOOOPTRACEPROCEDURESFORMAT)}
        append check(code) {::stooop::traceProcedure;}
    }
    if {[info exists ::env(STOOOPTRACEDATA)]} {
        set trace(dataChannel) $::env(STOOOPTRACEDATA)
        switch $trace(dataChannel) {
            stdout - stderr {}
            default {
                # eventually truncate output file if it exists
                set trace(dataChannel) [open $::env(STOOOPTRACEDATA) w+]
            }
        }
        # default format:
        set trace(dataFormat) {class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v}
        # eventually override with user defined format:
        catch {set trace(dataFormat) $::env(STOOOPTRACEDATAFORMAT)}
        # trace all operations by default:
        set trace(dataOperations) rwu
        # eventually override with user defined operations:
        catch {set trace(dataOperations) $::env(STOOOPTRACEDATAOPERATIONS)}
    }

    namespace export class virtual new delete classof  ;# export public commands

    if {![info exists newId]} {
        # initialize object id counter only once even if this file is sourced
        # several times:
        variable newId 0
    }

    # create an object of specified class or copy an existing object:
    _proc new {classOrId args} {
        variable newId
        variable fullClass

        # use local variable for identifier because new can be invoked
        # recursively:
        if {[string is integer $classOrId]} {
            # first argument is an object identifier (unsigned integer), copy
            # source object to new object of identical class
            if {[catch {\
                set fullClass([set id [incr newId]]) $fullClass($classOrId)\
            }]} {
                error "invalid object identifier $classOrId"
            }
            # invoke the copy constructor for the class in caller's variable
            # context so that object copy is transparent (see above):
            uplevel 1 $fullClass($classOrId)::_copy $id $classOrId
        } else {                                    ;# first argument is a class
            # generate constructor name:
            set constructor ${classOrId}::[namespace tail $classOrId]
            # we could detect here whether class was ever declared but that
            # would prevent stooop packages to load properly, because
            # constructor would not be invoked and thus class source file never
            # sourced
            # invoke the constructor for the class with optional arguments in
            # caller's variable context so that object creation is transparent
            # and that array names as constructor parameters work with a simple
            # upvar
            # note: if class is in a package, the class namespace code is loaded
            # here, as the first object of the class is created
            uplevel 1 $constructor [set id [incr newId]] $args
            # generate fully qualified class namespace name now that we are sure
            # that class namespace code has been invoked:
            set fullClass($id) [namespace qualifiers\
                [uplevel 1 namespace which -command $constructor]\
            ]
        }
        return $id                          ;# return a unique object identifier
    }

    _proc delete {args} {                          ;# delete one or more objects
        variable fullClass

        foreach id $args {
            # destruct in caller's variable context so that object deletion is
            # transparent:
            uplevel 1 ::stooop::deleteObject $fullClass($id) $id
            unset fullClass($id)
        }
    }

    # delete object data starting at specified class layer and going up the base
    # class hierarchy if any
    # invoke the destructor for the object class and unset all the object data
    # members for the class
    # the destructor will in turn delete the base classes layers
    _proc deleteObject {fullClass id} {
        # invoke the destructor for the class in caller's variable context so
        # that object deletion is transparent:
        uplevel 1 ${fullClass}::~[namespace tail $fullClass] $id
        # delete all this object data members if any (assume that they were
        # stored as ${class}::($id,memberName)):
        array unset ${fullClass}:: $id,*
        # data member arrays deletion is left to the user
    }

    _proc classof {id} {
        variable fullClass

        return $fullClass($id)                         ;# return class of object
    }

    # copy object data members from one object to another:
    _proc copy {fullClass from to} {
        set index [string length $from]
        # copy regular data members:
        foreach {name value} [array get ${fullClass}:: $from,*] {
            set ${fullClass}::($to[string range $name $index end]) $value
        }
        # if any, array data members copy is left to the class programmer
        # through the then mandatory copy constructor
    }
}

_proc ::stooop::class {args} {
    variable declared

    set class [lindex $args 0]
    # register class using its fully qualified name:
    set declared([uplevel 1 namespace eval $class {namespace current}]) {}
    # create the empty name array used to hold all class objects so that static
    # members can be directly initialized within the class declaration but
    # outside member procedures
    uplevel 1 namespace eval $class [list "::variable {}\n[lindex $args end]"]
}

# if procedure is a member of a known class, class and procedure names are set
# and true is returned, otherwise false is returned:
_proc ::stooop::parseProcedureName {\
    namespace name fullClassVariable procedureVariable messageVariable\
} {
    # namespace argument is the current namespace (fully qualified) in which the
    # procedure is defined
    variable declared
    upvar 1 $fullClassVariable fullClass $procedureVariable procedure\
        $messageVariable message

    if {\
        [info exists declared($namespace)]&&\
        ([string length [namespace qualifiers $name]]==0)\
    } {
        # a member procedure is being defined inside a class namespace
        set fullClass $namespace
        set procedure $name                ;# member procedure name is full name
        return 1
    } else {
        # procedure is either a member of a known class or a regular procedure
        if {![string match ::* $name]} {
            # eventually fully qualify procedure name
            if {[string equal $namespace ::]} { ;# global namespace special case
                set name ::$name
            } else {
                set name ${namespace}::$name
            }
        }
        # eventual class name is leading part:
        set fullClass [namespace qualifiers $name]
        if {[info exists declared($fullClass)]} {           ;# if class is known
            set procedure [namespace tail $name] ;# procedure always is the tail
            return 1
        } else {                                       ;# not a member procedure
            if {[string length $fullClass]==0} {
                set message "procedure $name class name is empty"
            } else {
                set message "procedure $name class $fullClass is unknown"
            }
            return 0
        }
    }
}

# virtual operator, to be placed before proc
# virtualize a member procedure, determine whether it is a pure virtual, check
# for procedures that cannot be virtualized
_proc ::stooop::virtual {keyword name arguments args} {
    # set a flag so that proc knows it is acting upon a virtual procedure, also
    # serves as a pure indicator:
    variable pureVirtual

    if {![string equal [uplevel 1 namespace which -command $keyword] ::proc]} {
        error "virtual operator works only on proc, not $keyword"
    }
    if {![parseProcedureName\
        [uplevel 1 namespace current] $name fullClass procedure message\
    ]} {
        error $message                   ;# not in a member procedure definition
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {
        error "cannot make class $fullClass constructor virtual"
    }
    if {[string equal ~$class $procedure]} {
        error "cannot make class $fullClass destructor virtual"
    }
    if {![string equal [lindex $arguments 0] this]} {
        error "cannot make static procedure $procedure of class $fullClass virtual"
    }
    # no procedure body means pure virtual:
    set pureVirtual [expr {[llength $args]==0}]
    # process procedure declaration, body being empty for pure virtual procedure
    # make virtual transparent by using uplevel:
    uplevel 1 ::proc [list $name $arguments [lindex $args 0]]
    unset pureVirtual
}

_proc proc {name arguments args} {
    if {![::stooop::parseProcedureName\
        [uplevel 1 namespace current] $name fullClass procedure message\
    ]} {
        # not in a member procedure definition, fall back to normal procedure
        # declaration
        # uplevel is required instead of eval here otherwise tcl seems to forget
        # the procedure namespace if it exists
        uplevel 1 _proc [list $name $arguments] $args
        return
    }
    if {[llength $args]==0} {               ;# check for procedure body presence
        error "missing body for ${fullClass}::$procedure"
    }
    set class [namespace tail $fullClass]
    if {[string equal $class $procedure]} {      ;# class constructor definition
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass constructor first argument must be this"
        }
        if {[string equal [lindex $arguments 1] copy]} {
            # user defined copy constructor definition
            if {[llength $arguments]!=2} {
                error "class $fullClass copy constructor must have 2 arguments exactly"
            }
            # make sure of proper declaration order:
            if {[catch {info body ::${fullClass}::$class}]} {
                error "class $fullClass copy constructor defined before constructor"
            }
            eval ::stooop::constructorDeclaration\
                $fullClass $class 1 \{$arguments\} $args
        } else {                                             ;# main constructor
            eval ::stooop::constructorDeclaration\
                $fullClass $class 0 \{$arguments\} $args
            # always generate default copy constructor:
            ::stooop::generateDefaultCopyConstructor $fullClass
        }
    } elseif {[string equal ~$class $procedure]} {
        # class destructor declaration
        if {[llength $arguments]!=1} {
            error "class $fullClass destructor must have 1 argument exactly"
        }
        if {![string equal [lindex $arguments 0] this]} {
            error "class $fullClass destructor argument must be this"
        }
        # make sure of proper declaration order
        # (use fastest method for testing procedure existence):
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass destructor defined before constructor"
        }
        ::stooop::destructorDeclaration\
            $fullClass $class $arguments [lindex $args 0]
    } else {
        # regular member procedure, may be static if there is no this first
        # argument
        # make sure of proper declaration order:
        if {[catch {info body ::${fullClass}::$class}]} {
            error "class $fullClass member procedure $procedure defined before constructor"
        }
        ::stooop::memberProcedureDeclaration\
            $fullClass $class $procedure $arguments [lindex $args 0]
    }
}

# copy flag is set for user defined copy constructor:
_proc ::stooop::constructorDeclaration {fullClass class copy arguments args} {
    variable check
    variable fullBases
    variable variable

    set number [llength $args]
    # check that each base class constructor has arguments:
    if {($number%2)==0} {
        error "bad class $fullClass constructor declaration, a base class, contructor arguments or body may be missing"
    }
    if {[string equal [lindex $arguments end] args]} {
        # remember that there is a variable number of arguments in class
        # constructor
        set variable($fullClass) {}
    }
    if {!$copy} {
        # do not initialize (or reinitialize in case of multiple class file
        # source statements) base classes for copy constructor
        set fullBases($fullClass) {}
    }
    # check base classes and their constructor arguments:
    foreach {base baseArguments} [lrange $args 0 [expr {$number-2}]] {
        # fully qualify base class namespace by looking up constructor, which
        # must exist
        set constructor ${base}::[namespace tail $base]
        # in case base class is defined in a file that is part of a package,
        # make sure that file is sourced through the tcl package auto-loading
        # mechanism by directly invoking the base class constructor while
        # ignoring the resulting error
        catch {$constructor}
        # determine fully qualified base class name in user invocation level
        # (up 2 levels from here since this procedure is invoked exclusively by
        # proc)
        set fullBase [namespace qualifiers\
            [uplevel 2 namespace which -command $constructor]\
        ]
        if {[string length $fullBase]==0} {   ;# base constructor is not defined
            if {[string match *$base $fullClass]} {
                # if the specified base class name is included last in the fully
                # qualified class name, assume that it was meant to be the same
                error "class $fullClass cannot be derived from itself"
            } else {
                error "class $fullClass constructor defined before base class $base constructor"
            }
        }
        # check and save base classes only for main constructor that defines
        # them:
        if {!$copy} {
            if {[lsearch -exact $fullBases($fullClass) $fullBase]>=0} {
                error "class $fullClass directly inherits from class $fullBase more than once"
            }
            lappend fullBases($fullClass) $fullBase
        }
        # replace new lines with blanks in base arguments part in case user has
        # formatted long declarations with new lines
        regsub -all {\n} $baseArguments { } constructorArguments($fullBase)
    }
    # setup access to class data (an empty named array)
    # fully qualify tcl variable command for it may have been redefined within
    # the class namespace
    # since constructor is directly invoked by new, the object identifier must
    # be valid, so debugging the procedure is pointless
    set constructorBody \
"::variable {}
$check(code)
"
    # base class(es) derivation specified:
    if {[llength $fullBases($fullClass)]>0} {
        # invoke base class constructors before evaluating constructor body
        # then set base part hidden derived member so that virtual procedures
        # are invoked at base class level as in C++
        if {[info exists variable($fullClass)]} {
            # variable number of arguments in derived class constructor
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                if {\
                    [info exists variable($fullBase)]&&\
                    ([string first {$args} $constructorArguments($fullBase)]>=0)\
                } {
                    # variable number of arguments in base class constructor and
                    # in derived class base class constructor arguments
                    # use eval so that base class constructor sees arguments
                    # instead of a list
                    # only the last argument of the base class constructor
                    # arguments is considered as a variable list
                    # (it usually is $args but could be a procedure invocation,
                    # such as [filter $args])
                    # fully qualify tcl commands such as set, for they may have
                    #  been redefined within the class namespace
                    append constructorBody \
"::set _list \[::list $constructorArguments($fullBase)\]
::eval $baseConstructor \$this \[::lrange \$_list 0 \[::expr {\[::llength \$_list\]-2}\]\] \[::lindex \$_list end\]
::unset _list
::set ${fullBase}::(\$this,_derived) $fullClass
"
                } else {
                    # no special processing needed
                    # variable number of arguments in base class constructor or
                    # variable arguments list passed as is to base class
                    #  constructor
                    append constructorBody \
"$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
                }
            }
        } else {                                 ;# constant number of arguments
            foreach fullBase $fullBases($fullClass) {
                if {![info exists constructorArguments($fullBase)]} {
                    error "missing base class $fullBase constructor arguments from class $fullClass constructor"
                }
                set baseConstructor ${fullBase}::[namespace tail $fullBase]
                append constructorBody \
"$baseConstructor \$this $constructorArguments($fullBase)
::set ${fullBase}::(\$this,_derived) $fullClass
"
            }
        }
    }                                 ;# else no base class derivation specified
    if {$copy} {
        # for user defined copy constructor, copy derived class member if it
        # exists
        append constructorBody \
"::catch {::set (\$this,_derived) \$(\$[::lindex $arguments 1],_derived)}
"
    }
    # finally append user defined procedure body:
    append constructorBody [lindex $args end]
    if {$copy} {
        _proc ${fullClass}::_copy $arguments $constructorBody
    } else {
        _proc ${fullClass}::$class $arguments $constructorBody
    }
}

_proc ::stooop::destructorDeclaration {fullClass class arguments body} {
    variable check
    variable fullBases

    # setup access to class data
    # since the object identifier is always valid at this point, debugging the
    # procedure is pointless
    set body \
"::variable {}
$check(code)
$body
"
    # if there are any, delete base classes parts in reverse order of
    # construction
    for {set index [expr {[llength $fullBases($fullClass)]-1}]} {$index>=0}\
        {incr index -1}\
    {
        set fullBase [lindex $fullBases($fullClass) $index]
        append body \
"::stooop::deleteObject $fullBase \$this
"
    }
    _proc ${fullClass}::~$class $arguments $body
}

_proc ::stooop::memberProcedureDeclaration {\
    fullClass class procedure arguments body\
} {
    variable check
    variable pureVirtual

    if {[info exists pureVirtual]} {                      ;# virtual declaration
        if {$pureVirtual} {                          ;# pure virtual declaration
            # setup access to class data
            # evaluate derived procedure which must exists. derived procedure
            # return value is automatically returned
            _proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]
"
        } else {                                  ;# regular virtual declaration
            # setup access to class data
            # evaluate derived procedure and return if it exists
            # else evaluate the base class procedure which can be invoked from
            # derived class procedure by prepending _
            _proc ${fullClass}::_$procedure $arguments \
"::variable {}
$check(code)
$body
"
            _proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
if {!\[::catch {::info body \$(\$this,_derived)::$procedure}\]} {
::return \[::uplevel 1 \$(\$this,_derived)::$procedure \[::lrange \[::info level 0\] 1 end\]\]
}
::uplevel 1 ${fullClass}::_$procedure \[::lrange \[::info level 0\] 1 end\]
"
        }
    } else {                                          ;# non virtual declaration
        # setup access to class data:
        _proc ${fullClass}::$procedure $arguments \
"::variable {}
$check(code)
$body
"
    }
}

# generate default copy procedure which may be overriden by the user for any
# class layer:
_proc ::stooop::generateDefaultCopyConstructor {fullClass} {
    variable fullBases

    # generate code for cloning base classes layers if there is at least one
    # base class
    foreach fullBase $fullBases($fullClass) {
        append body \
"${fullBase}::_copy \$this \$sibling
"
    }
    append body \
"::stooop::copy $fullClass \$sibling \$this
"
    _proc ${fullClass}::_copy {this sibling} $body
}


if {[llength [array names ::env STOOOP*]]>0} {
    # if one or more environment variables are set, we are in debugging mode

    # gracefully handle multiple sourcing of this file:
    catch {rename ::stooop::class ::stooop::_class}
    # use a new class procedure instead of adding debugging code to existing one
    _proc ::stooop::class {args} {
        variable trace
        variable check

        set class [lindex $args 0]
        if {$check(data)} {
            # check write and unset operations on empty named array holding
            # class data
            uplevel 1 namespace eval $class\
                [list {::trace variable {} wu ::stooop::checkData}]
        }
        if {[info exists ::env(STOOOPTRACEDATA)]} {
            # trace write and unset operations on empty named array holding
            # class data
            uplevel 1 namespace eval $class [list\
                "::trace variable {} $trace(dataOperations) ::stooop::traceData"\
            ]
        }
        uplevel 1 ::stooop::_class $args
    }

    if {$::stooop::check(procedures)} {
        # prevent the creation of any object of a pure interface class
        # use a new virtual procedure instead of adding debugging code to
        # existing one
        # gracefully handle multiple sourcing of this file:
        catch {rename ::stooop::virtual ::stooop::_virtual}
        # keep track of interface classes (which have at least 1 pure virtual
        # procedure):
        _proc ::stooop::virtual {keyword name arguments args} {
            variable interface

            uplevel 1 ::stooop::_virtual [list $keyword $name $arguments] $args
            parseProcedureName [uplevel 1 namespace current] $name\
                fullClass procedure message
            if {[llength $args]==0} {    ;# no procedure body means pure virtual
                set interface($fullClass) {}
            }
        }
    }

    if {$::stooop::check(objects)} {
        _proc invokingProcedure {} {
            if {[catch {set procedure [lindex [info level -2] 0]}]} {
                # no invoking procedure
                return {top level}
            } elseif {\
                ([string length $procedure]==0)||\
                [string equal $procedure namespace]\
            } {                                 ;# invoked from a namespace body
                return "namespace [uplevel 2 namespace current]"
            } else {
                # store fully qualified name, visible from creator procedure
                # invoking procedure
                return [uplevel 3 namespace which -command $procedure]
            }
        }
    }

    if {$::stooop::check(procedures)||$::stooop::check(objects)} {
        # gracefully handle multiple sourcing of this file:
        catch {rename ::stooop::new ::stooop::_new}
        # use a new new procedure instead of adding debugging code to existing
        # one:
        _proc ::stooop::new {classOrId args} {
            variable newId
            variable check

            if {$check(procedures)} {
                variable fullClass
                variable interface
            }
            if {$check(objects)} {
                variable creator
            }
            if {$check(procedures)} {
                if {[string is integer $classOrId]} {
                    # first argument is an object identifier
                    # class code, if from a package, must already be loaded
                    set fullName $fullClass($classOrId)
                } else {                            ;# first argument is a class
                    # generate constructor name:
                    set constructor ${classOrId}::[namespace tail $classOrId]
                    # force loading in case class is in a package so namespace
                    # commands work properly:
                    catch {$constructor}
                    set fullName [namespace qualifiers\
                        [uplevel 1 namespace which -command $constructor]\
                    ]
                    # anticipate full class name storage in original new{} in
                    # order to avoid invalid object identifier error in
                    # checkProcedure{} when member procedure is invoked from
                    # within contructor, in which case full class name would
                    # have yet to be stored.
                    set fullClass([expr {$newId+1}]) $fullName
                    # new identifier is really incremented in original new{}
                }
                if {[info exists interface($fullName)]} {
                    error "class $fullName with pure virtual procedures should not be instanciated"
                }
            }
            if {$check(objects)} {
                # keep track of procedure in which creation occured (new
                # identifier is really incremented in original new{})
                set creator([expr {$newId+1}]) [invokingProcedure]
            }
            return [uplevel 1 ::stooop::_new $classOrId $args]
        }
    }

    if {$::stooop::check(objects)} {
        _proc ::stooop::delete {args} {
            variable fullClass
            variable deleter

            # keep track of procedure in which deletion occured:
            set procedure [invokingProcedure]
            foreach id $args {
                uplevel 1 ::stooop::deleteObject $fullClass($id) $id
                unset fullClass($id)
                set deleter($id) $procedure
            }
        }
    }

    # return the unsorted list of ancestors in class hierarchy:
    _proc ::stooop::ancestors {fullClass} {
        variable ancestors                         ;# use a cache for efficiency
        variable fullBases

        if {[info exists ancestors($fullClass)]} {
            return $ancestors($fullClass)                  ;# found in the cache
        }
        set list {}
        foreach class $fullBases($fullClass) {
            set list [concat $list [list $class] [ancestors $class]]
        }
        set ancestors($fullClass) $list                         ;# save in cache
        return $list
    }

    # since this procedure is always invoked from a debug procedure, take the
    # extra level in the stack frame into account
    # parameters (passed as references) that cannot be determined are not set
    _proc ::stooop::debugInformation {\
        className fullClassName procedureName fullProcedureName\
        thisParameterName\
    } {
        upvar 1 $className class $fullClassName fullClass\
            $procedureName procedure $fullProcedureName fullProcedure\
            $thisParameterName thisParameter
        variable declared

        set namespace [uplevel 2 namespace current]
        # not in a class namespace:
        if {[lsearch -exact [array names declared] $namespace]<0} return
        # remove redundant global qualifier:
        set fullClass [string trimleft $namespace :]
        set class [namespace tail $fullClass]                      ;# class name
        set list [info level -2]
        set first [lindex $list 0]
        if {([llength $list]==0)||[string equal $first namespace]}\
            return                     ;# not in a procedure, nothing else to do
        set procedure $first
        # procedure must be known at the invoker level:
        set fullProcedure [uplevel 3 namespace which -command $procedure]
        set procedure [namespace tail $procedure]        ;# strip procedure name
        if {[string equal $class $procedure]} {                   ;# constructor
            set procedure constructor
        } elseif {[string equal ~$class $procedure]} {             ;# destructor
            set procedure destructor
        }
        if {[string equal [lindex [info args $fullProcedure] 0] this]} {
            # non static procedure
            # object identifier is first argument:
            set thisParameter [lindex $list 1]
        }
    }

    # check that member procedure is valid for object passed as parameter:
    _proc ::stooop::checkProcedure {} {
        variable fullClass

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        # static procedure, no checking possible:
        if {![info exists this]} return
        # in constructor, checking useless since object is not yet created:
        if {[string equal $procedure constructor]} return
        if {![info exists fullClass($this)]} {
            error "$this is not a valid object identifier"
        }
        set fullName [string trimleft $fullClass($this) :]
        # procedure and object classes match:
        if {[string equal $fullName $qualifiedClass]} return
        # restore global qualifiers to compare with internal full class array
        # data
        if {[lsearch -exact [ancestors ::$fullName] ::$qualifiedClass]<0} {
            error "class $qualifiedClass of $qualifiedProcedure procedure not an ancestor of object $this class $fullName"
        }
    }

    # gather current procedure data, perform substitutions and output to trace
    # channel:
    _proc ::stooop::traceProcedure {} {
        variable trace

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        # all debug data is available since we are for sure in a class procedure
        set text $trace(procedureFormat)
        regsub -all %C $text $qualifiedClass text  ;# fully qualified class name
        regsub -all %c $text $class text
        # fully qualified procedure name:
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        if {[info exists this]} {                        ;# non static procedure
            regsub -all %O $text $this text
            # remaining arguments:
            regsub -all %a $text [lrange [info level -1] 2 end] text
        } else {                                             ;# static procedure
            regsub -all %O $text {} text
            # remaining arguments:
            regsub -all %a $text [lrange [info level -1] 1 end] text
        }
        puts $trace(procedureChannel) $text
    }

    # check that class data member is accessed within procedure of identical
    # class
    # then if procedure is not static, check that only data belonging to the
    # object passed as parameter is accessed
    _proc ::stooop::checkData {array name operation} {
        scan $name %u,%s identifier member
        # ignore internally defined members:
        if {[info exists member]&&[string equal $member _derived]} return

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        # no checking can be done outside of a class namespace:
        if {![info exists class]} return
        # determine array full name:
        set array [uplevel 1 [list namespace which -variable $array]]
        if {![info exists procedure]} {              ;# inside a class namespace
            # compare with empty named array fully qualified name:
            if {![string equal $array ::${qualifiedClass}::]} {
                # trace command error message is automatically prepended and
                # indicates operation
                error\
                    "class access violation in class $qualifiedClass namespace"
            }
            return                                                       ;# done
        }
        # ignore internal copy procedure:
        if {[string equal $qualifiedProcedure ::stooop::copy]} return
        if {![string equal $array ::${qualifiedClass}::]} {
            # compare with empty named array fully qualified name
            # trace command error message is automatically prepended and
            # indicates operation
            error "class access violation in procedure $qualifiedProcedure"
        }
        # static procedure, all objects can be accessed:
        if {![info exists this]} return
        # static data members can be accessed:
        if {![info exists identifier]} return
        # check that accessed data belongs to this object:
        if {$this!=$identifier} {
            error "object $identifier access violation in procedure $qualifiedProcedure acting on object $this"
        }
    }

    # gather accessed data member information, perform substitutions and output
    # to trace channel
    _proc ::stooop::traceData {array name operation} {
        variable trace

        scan $name %u,%s identifier member
        # ignore internally defined members:
        if {[info exists member]&&[string equal $member _derived]} return

        # ignore internal destruction:
        if {\
            ![catch {lindex [info level -1] 0} procedure]&&\
            [string equal ::stooop::deleteObject $procedure]\
        } return
        set class {}                           ;# in case we are outside a class
        set qualifiedClass {}
        set procedure {}             ;# in case we are outside a class procedure
        set qualifiedProcedure {}

        debugInformation class qualifiedClass procedure qualifiedProcedure this
        set text $trace(dataFormat)
        regsub -all %C $text $qualifiedClass text  ;# fully qualified class name
        regsub -all %c $text $class text
        if {[info exists member]} {
            regsub -all %m $text $member text
        } else {
            regsub -all %m $text $name text                     ;# static member
        }
        # fully qualified procedure name:
        regsub -all %P $text $qualifiedProcedure text
        regsub -all %p $text $procedure text
        # fully qualified array name with global qualifiers stripped:
        regsub -all %A $text [string trimleft\
            [uplevel 1 [list namespace which -variable $array]] :\
        ] text
        if {[info exists this]} {                        ;# non static procedure
            regsub -all %O $text $this text
        } else {                                             ;# static procedure
            regsub -all %O $text {} text
        }
        array set string {r read w write u unset}
        regsub -all %o $text $string($operation) text
        if {[string equal $operation u]} {
            regsub -all %v $text {} text              ;# no value when unsetting
        } else {
            regsub -all %v $text [uplevel 1 set ${array}($name)] text
        }
        puts $trace(dataChannel) $text
    }

    if {$::stooop::check(objects)} {
        # print existing objects along with creation procedure, with optional
        # class pattern (see the string Tcl command manual)
        _proc ::stooop::printObjects {{pattern *}} {
            variable fullClass
            variable creator

            puts "stooop::printObjects invoked from [invokingProcedure]:"
            foreach id [lsort -integer [array names fullClass]] {
                if {[string match $pattern $fullClass($id)]} {
                    puts "$fullClass($id)\($id\) + $creator($id)"
                }
            }
        }

        # record all existing objects for later report:
        _proc ::stooop::record {} {
            variable fullClass
            variable checkpointFullClass

            puts "stooop::record invoked from [invokingProcedure]"
            catch {unset checkpointFullClass}
            array set checkpointFullClass [array get fullClass]
        }

        # print all new or deleted object since last record, with optional class
        # pattern:
        _proc ::stooop::report {{pattern *}} {
            variable fullClass
            variable checkpointFullClass
            variable creator
            variable deleter

            puts "stooop::report invoked from [invokingProcedure]:"
            set checkpointIds [lsort -integer [array names checkpointFullClass]]
            set currentIds [lsort -integer [array names fullClass]]
            foreach id $currentIds {
                if {\
                    [string match $pattern $fullClass($id)]&&\
                    ([lsearch -exact $checkpointIds $id]<0)\
                } {
                    puts "+ $fullClass($id)\($id\) + $creator($id)"
                }
            }
            foreach id $checkpointIds {
                if {\
                    [string match $pattern $checkpointFullClass($id)]&&\
                    ([lsearch -exact $currentIds $id]<0)\
                } {
                    puts "- $checkpointFullClass($id)\($id\) - $deleter($id) + $creator($id)"
                }
            }
        }
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/stooop/stooop.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
4052
4053
4054
4055
4056
4057
4058
4059
4060
4061
4062
4063
4064
4065
4066
4067
4068
4069
4070
4071
4072
4073
4074
4075
4076
4077
4078
4079
4080
4081
4082
4083
4084
4085
4086
4087
4088
4089
4090
4091
4092
4093
4094
4095
4096
4097
4098
4099
4100
4101
4102
4103
4104
4105
4106
4107
4108
4109
4110
4111
4112
4113
4114
4115
4116
4117
4118
4119
4120
4121
4122
4123
4124
4125
4126
4127
4128
4129
4130
4131
4132
4133
4134
4135
4136
4137
4138
4139
4140
4141
4142
4143
4144
4145
4146
4147
4148
4149
4150
4151
4152
4153
4154
4155
4156
4157
4158
4159
4160
4161
4162
4163
4164
4165
4166
4167
4168
4169
4170
4171
4172
4173
4174
4175
4176
4177
4178
4179
4180
4181
4182
4183
4184
4185
4186
4187
4188
4189
4190
4191
4192
4193
4194
4195
4196
4197
4198
4199
4200
4201
4202
4203
4204
4205
4206
4207
4208
4209
4210
4211
4212
4213
4214
4215
4216
4217
4218
4219
4220
4221
4222
4223
4224
4225
4226
4227
4228
4229
4230
4231
4232
4233
4234
4235
4236
4237
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248
4249
4250
4251
4252
4253
4254
4255
4256
4257
4258
4259
4260
4261
4262
4263
4264
4265
4266
4267
4268
4269
4270
4271
4272
4273
4274
4275
4276
4277
4278
4279
4280
4281
4282
4283
4284
4285
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
4310
4311
4312
4313
4314
4315
4316
4317
4318
4319
4320
4321
4322
4323
4324
4325
4326
4327
4328
4329
4330
4331
4332
4333
4334
4335
4336
4337
4338
4339
4340
4341
4342
4343
4344
4345
4346
4347
4348
4349
4350
4351
4352
4353
4354
4355
4356
4357
4358
4359
4360
4361
4362
4363
4364
4365
4366
4367
4368
4369
4370
4371
4372
4373
4374
4375
4376
4377
4378
4379
4380
4381
4382
4383
4384
4385
4386
4387
4388
4389
4390
4391
4392
4393
4394
4395
4396
4397
4398
4399
4400
4401
4402
4403
4404
4405
4406
4407
4408
4409
4410
4411
4412
4413
4414
4415
4416
4417
4418
4419
4420
4421
4422
4423
4424
4425
4426
4427
4428
4429
4430
4431
4432
4433
4434
4435
4436
4437
4438
4439
4440
4441
4442
4443
4444
4445
4446
4447
4448
4449
4450
4451
4452
4453
4454
4455
4456
4457
4458
4459
4460
4461
4462
4463
4464
4465
4466
4467
4468
4469
4470
4471
4472
4473
4474
4475
4476
4477
4478
4479
4480
4481
4482
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509
4510
4511
4512
4513
4514
4515
4516
4517
4518
4519
4520
4521
4522
4523
4524
4525
4526
4527
4528
4529
4530
4531
4532
4533
4534
4535
4536
4537
4538
4539
4540
4541
4542
4543
4544
4545
4546
4547
4548
4549
4550
4551
4552
4553
4554
4555
4556
4557
4558
4559
4560
4561
4562
4563
4564
4565
4566
4567
4568
4569
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581
4582
4583
4584
4585
4586
4587
4588
4589
4590
4591
4592
4593
4594
4595
4596
4597
4598
4599
4600
4601
4602
4603
4604
4605
4606
4607
4608
4609
4610
4611
4612
4613
4614
4615
4616
4617
4618
4619
4620
4621
4622
4623
4624
4625
4626
4627
4628
4629
4630
4631
4632
4633
4634
4635
4636
4637
4638
4639
4640
4641
4642
4643
4644
4645
4646
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734
4735
4736
4737
4738
4739
4740
4741
4742
4743
4744
4745
4746
4747
4748
4749
4750
4751
4752
4753
4754
4755
4756
4757
4758
4759
4760
4761
4762
4763
4764
4765
4766
4767
4768
4769
4770
4771
4772
4773
4774
4775
4776
4777
4778
4779
4780
4781
4782
4783
4784
4785
4786
4787
4788
4789
4790
4791
4792
4793
4794
4795
4796
4797
4798
4799
4800
4801
4802
4803
4804
4805
4806
4807
4808
4809
4810
4811
4812
4813
4814
4815
4816
4817
4818
4819
4820
4821
4822
4823
4824
4825
4826
4827
4828
4829
4830
4831
4832
4833
4834
4835
4836
4837
4838
4839
4840
4841
4842
4843
4844
4845
4846
4847
4848
4849
4850
4851
4852
4853
4854
4855
4856
4857
4858
4859
4860
4861
4862
4863
4864
4865
4866
4867
4868
4869
4870
4871
4872
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934
4935
4936
4937
4938
4939
4940
4941
4942
4943
4944
4945
4946
4947
4948
4949
4950
4951
4952
4953
4954
4955
4956
4957
4958
4959
4960
4961
4962
4963
4964
4965
4966
4967
4968
4969
4970
4971
4972
4973
4974
4975
4976
4977
4978
4979
4980
4981
4982
4983
4984
4985
4986
4987
4988
4989
4990
4991
4992
4993
4994
4995
4996
4997
4998
4999
5000
5001
5002
5003
5004
5005
5006
5007
5008
5009
5010
5011
5012
5013
5014
5015
5016
5017
5018
5019
5020
5021
5022
5023
5024
5025
5026
5027
5028
5029
5030
5031
5032
5033
5034
5035
5036
5037
5038
5039
5040
5041
5042
5043
5044
5045
5046
5047
5048
5049
5050
5051
5052
5053
5054
5055
5056
5057
5058
5059
5060
5061
5062
5063
5064
5065
5066
5067
5068
5069
5070
5071
5072
5073
5074
5075
5076
5077
5078
5079
5080
5081
5082
5083
5084
5085
5086
5087
5088
5089
5090
5091
5092
5093
5094
5095
5096
5097
5098
5099
5100
5101
5102
5103
5104
5105
5106
5107
5108
5109
5110
5111
5112
5113
5114
5115
5116
5117
5118
5119
5120
5121
5122
5123
5124
5125
5126
5127
5128
5129
5130
5131
5132
5133
5134
5135
5136
5137
5138
5139
5140
5141
5142
5143
5144
5145
5146
5147
5148
5149
5150
5151
5152
5153
5154
5155
5156
5157
5158
5159
5160
5161
5162
5163
5164
5165
5166
5167
5168
5169
5170
5171
5172
5173
5174
5175
5176
5177
5178
5179
5180
5181
5182
5183
5184
5185
5186
5187
5188
5189
5190
5191
5192
5193
5194
5195
5196
5197
5198
5199
5200
5201
5202
5203
5204
5205
5206
5207
5208
5209
5210
5211
5212
5213
5214
5215
5216
5217
5218
5219
5220
5221
5222
5223
5224
5225
5226
5227
5228
5229
5230
5231
5232
5233
5234
5235
5236
5237
5238
5239
5240
5241
5242
5243
5244
5245
5246
5247
5248
5249
5250
5251
5252
5253
5254
5255
5256
5257
5258
5259
5260
5261
5262
5263
5264
5265
5266
5267
5268
5269
5270
5271
5272
5273
5274
5275
5276
5277
5278
5279
5280
5281
5282
5283
5284
5285
5286
5287
5288
5289
5290
5291
5292
5293
5294
5295
5296
5297
5298
5299
5300
5301
5302
5303
5304
5305
5306
5307
5308
5309
5310
5311
5312
5313
5314
5315
5316
5317
5318
5319
5320
5321
5322
5323
5324
5325
5326
5327
5328
5329
5330
5331
5332
5333
5334
5335
5336
5337
5338
5339
5340
5341
5342
5343
5344
5345
5346
5347
5348
5349
5350
5351
5352
5353
5354
5355
5356
5357
5358
5359
5360
5361
5362
5363
5364
5365
5366
5367
5368
5369
5370
5371
5372
5373
5374
5375
5376
5377
5378
5379
5380
5381
5382
5383
5384
5385
5386
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401
5402
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416
5417
5418
5419
5420
5421
5422
5423
5424
5425
5426
5427
5428
5429
5430
5431
5432
5433
5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447
5448
5449
5450
5451
5452
5453
5454
5455
5456
5457
5458
5459
5460
5461
5462
5463
5464
5465
5466
5467
5468
5469
5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483
5484
5485
5486
5487
5488
5489
5490
5491
5492
5493
5494
5495
5496
5497
5498
5499
5500
5501
5502
5503
5504
5505
5506
5507
5508
5509
5510
5511
5512
5513
5514
5515
5516
5517
5518
5519
5520
5521
5522
5523
5524
5525
5526
5527
5528
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544
5545
5546
5547
5548
5549
5550
5551
5552
5553
5554
5555
5556
5557
5558
5559
5560
5561
5562
5563
5564
5565
5566
5567
5568
5569
5570
5571
5572
5573
5574
5575
5576
5577
5578
5579
5580
5581
5582
5583
5584
5585
5586
5587
5588
5589
5590
5591
5592
5593
5594
5595
5596
5597
5598
5599
5600
5601
5602
5603
5604
5605
5606
5607
5608
5609
5610
5611
5612
5613
5614
5615
5616
5617
5618
5619
5620
5621
5622
5623
5624
5625
5626
5627
5628
5629
5630
5631
5632
5633
5634
5635
5636
5637
5638
5639
5640
5641
5642
5643
5644
5645
5646
5647
5648
5649
5650
5651
5652
5653
5654
5655
5656
5657
5658
5659
5660
5661
5662
5663
5664
5665
5666
5667
5668
5669
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681
5682
5683
5684
5685
5686
5687
5688
5689
5690
5691
5692
5693
5694
5695
5696
5697
5698
5699
5700
5701
5702
5703
5704
5705
5706
5707
5708
5709
5710
5711
5712
5713
5714
5715
5716
5717
5718
5719
5720
5721
5722
5723
5724
5725
5726
5727
5728
5729
5730
5731
5732
5733
5734
5735
5736
5737
5738
5739
5740
5741
5742
5743
5744
5745
5746
5747
5748
5749
5750
5751
5752
5753
5754
5755
5756
5757
5758
5759
5760
5761
5762
5763
5764
5765
5766
5767
5768
5769
5770
5771
5772
5773
5774
5775
5776
5777
5778
5779
5780
5781
5782
5783
5784
5785
5786
5787
5788
5789
5790
5791
5792
5793
5794
5795
5796
5797
5798
5799
5800
5801
5802
5803
5804
5805
5806
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816
5817
5818
5819
5820
5821
5822
5823
5824
5825
5826
5827
5828
5829
5830
5831
5832
5833
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844
5845
5846
5847
5848
5849
5850
5851
5852
5853
5854
5855
5856
5857
5858
5859
5860
5861
5862
5863
5864
5865
5866
5867
5868
5869
5870
5871
5872
5873
5874
5875
5876
5877
5878
5879
5880
5881
5882
5883
5884
5885
5886
5887
5888
5889
5890
5891
5892
5893
5894
5895
5896
5897
5898
5899
5900
5901
5902
5903
5904
5905
5906
5907
5908
5909
5910
5911
5912
5913
5914
5915
5916
5917
5918
5919
5920
5921
5922
5923
5924
5925
5926
5927
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953
5954
5955
5956
5957
5958
5959
5960
5961
5962
5963
5964
5965
5966
5967
5968
5969
5970
5971
5972
5973
5974
5975
5976
5977
5978
5979
5980
5981
5982
5983
5984
5985
5986
5987
5988
5989
5990
5991
5992
5993
5994
5995
5996
5997
5998
5999
6000
6001
6002
6003
6004
6005
6006
6007
6008
6009
6010
6011
6012
6013
6014
6015
6016
6017
6018
6019
6020
6021
6022
6023
6024
6025
6026
6027
6028
6029
6030
6031
6032
6033
6034
6035
6036
6037
6038
6039
6040
6041
6042
6043
6044
6045
6046
6047
6048
6049
6050
6051
6052
6053
6054
6055
6056
6057
6058
6059
6060
6061
6062
6063
6064
6065
6066
6067
6068
6069
6070
6071
6072
6073
6074
6075
6076
6077
6078
6079
6080
6081
6082
6083
6084
6085
6086
6087
6088
6089
6090
6091
6092
6093
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
6119
6120
6121
6122
6123
6124
6125
6126
6127
6128
6129
6130
6131
6132
6133
6134
6135
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192
6193
6194
6195
6196
6197
6198
6199
6200
6201
6202
6203
6204
6205
6206
6207
6208
6209
6210
6211
6212
6213
6214
6215
6216
6217
6218
6219
6220
6221
6222
6223
6224
6225
6226
6227
6228
6229
6230
6231
6232
6233
6234
6235
6236
6237
6238
6239
6240
6241
6242
6243
6244
6245
6246
6247
6248
6249
6250
6251
6252
6253
6254
6255
6256
6257
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287
6288
6289
6290
6291
6292
6293
6294
6295
6296
6297
6298
6299
6300
6301
6302
6303
6304
6305
6306
6307
6308
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
6325
6326
6327
6328
6329
6330
6331
6332
6333
6334
6335
6336
6337
6338
6339
6340
6341
6342
6343
6344
6345
6346
6347
6348
6349
6350
6351
6352
6353
6354
6355
6356
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367
6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380
6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469
6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484
6485
6486
6487
6488
6489
6490
6491
6492
6493
6494
6495
6496
6497
6498
6499
6500
6501
6502
6503
6504
6505
6506
6507
6508
6509
6510
6511
6512
6513
6514
6515
6516
6517
6518
6519
6520
6521
6522
6523
6524
6525
6526
6527
6528
6529
6530
6531
6532
6533
6534
6535
6536
6537
6538
6539
6540
6541
6542
6543
6544
6545
6546
6547
6548
6549
6550
6551
6552
6553
6554
6555
6556
6557
6558
6559
6560
6561
6562
6563
6564
6565
6566
6567
6568
6569
6570
6571
6572
6573
6574
6575
6576
6577
6578
6579
6580
6581
6582
6583
6584
6585
6586
6587
6588
6589
6590
6591
6592
6593
6594
6595
6596
6597
6598
6599
6600
6601
6602
6603
6604
6605
6606
6607
6608
6609
6610
6611
6612
6613
6614
6615
6616
6617
6618
6619
6620
6621
6622
6623
6624
6625
6626
6627
6628
6629
6630
6631
6632
6633
6634
6635
6636
6637
6638
6639
6640
6641
6642
6643
6644
6645
6646
6647
6648
6649
6650
6651
6652
6653
6654
6655
6656
6657
6658
6659
6660
6661
6662
6663
6664
6665
6666
6667
6668
6669
6670
6671
6672
6673
6674
6675
6676
6677
6678
6679
6680
6681
6682
6683
6684
6685
6686
6687
6688
6689
6690
6691
6692
6693
6694
6695
6696
6697
6698
6699
6700
6701
6702
6703
6704
6705
6706
6707
6708
6709
6710
6711
6712
6713
6714
6715
6716
6717
6718
6719
6720
6721
6722
6723
6724
6725
6726
6727
6728
6729
6730
6731
6732
6733
6734
6735
6736
6737
6738
6739
6740
6741
6742
6743
6744
6745
6746
6747
6748
6749
6750
6751
6752
6753
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764
6765
6766
6767
6768
6769
6770
6771
6772
6773
6774
6775
6776
6777
6778
6779
6780
6781
6782
6783
6784
6785
6786
6787
6788
6789
6790
6791
6792
6793
6794
6795
6796
6797
6798
6799
6800
6801
6802
6803
6804
6805
6806
6807
6808
6809
6810
6811
6812
6813
6814
6815
6816
6817
6818
6819
6820
6821
6822
6823
6824
6825
6826
6827
6828
6829
6830
6831
6832
6833
6834
6835
6836
6837
6838
6839
6840
6841
6842
6843
6844
6845
6846
6847
6848
6849
6850
6851
6852
6853
6854
6855
6856
6857
6858
6859
6860
6861
6862
6863
6864
6865
6866
6867
6868
6869
6870
6871
6872
6873
6874
6875
6876
6877
6878
6879
6880
6881
6882
6883
6884
6885
6886
6887
6888
6889
6890
6891
6892
6893
6894
6895
6896
6897
6898
6899
6900
6901
6902
6903
6904
6905
6906
6907
6908
6909
6910
6911
6912
6913
6914
6915
6916
6917
6918
6919
6920
6921
6922
6923
6924
6925
6926
6927
6928
6929
6930
6931
6932
6933
6934
6935
6936
6937
6938
6939
6940
6941
6942
6943
6944
6945
6946
6947
6948
6949
6950
6951
6952
6953
6954
6955
6956
6957
6958
6959
6960
6961
6962
6963
6964
6965
6966
6967
6968
6969
6970
6971
6972
6973
6974
6975
6976
6977
6978
6979
6980
6981
6982
6983
6984
6985
6986
6987
6988
6989
6990
6991
6992
6993
6994
6995
6996
6997
6998
6999
7000
7001
7002
7003
7004
7005
7006
7007
7008
7009
7010
7011
7012
7013
7014
7015
7016
7017
7018
7019
7020
7021
7022
7023
7024
7025
7026
7027
7028
7029
7030
7031
7032
7033
7034
7035
7036
7037
7038
7039
7040
7041
7042
7043
7044
7045
7046
7047
7048
7049
7050
7051
7052
7053
7054
7055
7056
7057
7058
7059
7060
7061
7062
7063
7064
7065
7066
7067
7068
7069
7070
7071
7072
7073
7074
7075
7076
7077
7078
7079
7080
7081
7082
7083
7084
7085
7086
7087
7088
7089
7090
7091
7092
7093
7094
7095
7096
7097
7098
7099
7100
7101
7102
7103
7104
7105
7106
7107
7108
7109
7110
7111
7112
7113
7114
7115
7116
7117
7118
7119
7120
7121
7122
7123
7124
7125
7126
7127
7128
7129
7130
7131
7132
7133
7134
7135
7136
7137
7138
7139
7140
7141
7142
7143
7144
7145
7146
7147
7148
7149
7150
7151
7152
7153
7154
7155
7156
7157
7158
7159
7160
7161
7162
7163
7164
7165
7166
7167
7168
7169
7170
7171
7172
7173
7174
7175
7176
7177
7178
7179
7180
7181
7182
7183
7184
7185
7186
7187
7188
7189
7190
7191
7192
7193
7194
7195
7196
7197
7198
7199
7200
7201
7202
7203
7204
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214
7215
7216
7217
7218
7219
7220
7221
7222
7223
7224
7225
7226
7227
7228
7229
7230
7231
7232
7233
7234
7235
7236
7237
7238
7239
7240
7241
7242
7243
7244
7245
7246
7247
7248
7249
7250
7251
7252
7253
7254
7255
7256
7257
7258
7259
7260
7261
7262
7263
7264
7265
7266
7267
7268
7269
7270
7271
7272
7273
7274
7275
7276
7277
7278
7279
7280
7281
7282
7283
7284
7285
7286
7287
7288
7289
7290
7291
7292
7293
7294
7295
7296
7297
7298
7299
7300
7301
7302
7303
7304
7305
7306
7307
7308
7309
7310
7311
7312
7313
7314
7315
7316
7317
7318
7319
7320
7321
7322
7323
7324
7325
7326
7327
7328
7329
7330
7331
7332
7333
7334
7335
7336
7337
7338
7339
7340
7341
7342
7343
7344
7345
7346
7347
7348
7349
7350
7351
7352
7353
7354
7355
7356
7357
7358
7359
7360
7361
7362
7363
7364
7365
7366
7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
7461
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476
7477
7478
7479
7480
7481
7482
7483
7484
7485
7486
7487
7488
7489
7490
7491
7492
7493
7494
7495
7496
7497
7498
7499
7500
7501
7502
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
7525
7526
7527
7528
7529
7530
7531
7532
7533
7534
7535
7536
7537
7538
7539
7540
7541
7542
7543
7544
7545
7546
7547
7548
7549
7550
7551
7552
7553
7554
7555
7556
7557
7558
7559
7560
7561
7562
7563
7564
7565
7566
7567
7568
7569
7570
7571
7572
7573
7574
7575
7576
7577
7578
7579
7580
7581
7582
7583
7584
7585
7586
7587
7588
7589
7590
7591
7592
7593
7594
7595
7596
7597
7598
7599
7600
7601
7602
7603
7604
7605
7606
7607
7608
7609
7610
7611
7612
7613
7614
7615
7616
7617
7618
7619
7620
7621
7622
7623
7624
7625
7626
7627
7628
7629
7630
7631
7632
7633
7634
7635
7636
7637
7638
7639
7640
7641
7642
7643
7644
7645
7646
7647
7648
7649
7650
7651
7652
7653
7654
7655
7656
7657
7658
7659
7660
7661
7662
7663
7664
7665
7666
7667
7668
7669
7670
7671
7672
7673
7674
7675
7676
7677
7678
7679
7680
7681
7682
7683
7684
7685
7686
7687
7688
7689
7690
7691
7692
7693
7694
7695
7696
7697
7698
7699
7700
7701
7702
7703
7704
7705
7706
7707
7708
7709
7710
7711
7712
7713
7714
7715
7716
7717
7718
7719
7720
7721
7722
7723
7724
7725
7726
7727
7728
7729
7730
7731
7732
7733
7734
7735
7736
7737
7738
7739
7740
7741
7742
7743
7744
7745
7746
7747
7748
7749
7750
7751
7752
7753
7754
7755
7756
7757
7758
7759
7760
7761
7762
7763
7764
7765
7766
7767
7768
7769
7770
7771
7772
7773
7774
7775
7776
7777
7778
7779
7780
7781
7782
7783
7784
7785
7786
7787
7788
7789
7790
7791
7792
7793
7794
7795
7796
7797
7798
7799
7800
7801
7802
7803
7804
7805
7806
7807
7808
7809
7810
7811
7812
7813
7814
7815
7816
7817
7818
7819
7820
7821
7822
7823
7824
7825
7826
7827
7828
7829
7830
7831
7832
7833
7834
7835
7836
7837
7838
7839
7840
7841
7842
7843
7844
7845
7846
7847
7848
7849
7850
7851
7852
7853
7854
7855
7856
7857
7858
7859
7860
7861
7862
7863
7864
7865
7866
7867
7868
7869
7870
7871
7872
7873
7874
7875
7876
7877
7878
7879
7880
7881
7882
7883
7884
7885
7886
7887
7888
7889
7890
7891
7892
7893
7894
7895
7896
7897
7898
7899
7900
7901
7902
7903
7904
7905
7906
7907
7908
7909
7910
7911
7912
7913
7914
7915
7916
7917
7918
7919
7920
7921
7922
7923
7924
7925
7926
7927
7928
7929
7930
7931
7932
7933
7934
7935
7936
7937
7938
7939
7940
7941
7942
7943
7944
7945
7946
7947
7948
7949
7950
7951
7952
7953
7954
7955
7956
7957
7958
7959
7960
7961
7962
7963
7964
7965
7966
7967
7968
7969
7970
7971
7972
7973
7974
7975
7976
7977
7978
7979
7980
7981
7982
7983
7984
7985
7986
7987
7988
7989
7990
7991
7992
7993
7994
7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021
8022
8023
8024
8025
8026
8027
8028
8029
8030
8031
8032
8033
8034
8035
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
8071
8072
8073
8074
8075
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
8090
8091
8092
8093
8094
8095
8096
8097
8098
8099
8100
8101
8102
8103
8104
8105
8106
8107
8108
8109
8110
8111
8112
8113
8114
8115
8116
8117
8118
8119
8120
8121
8122
8123
8124
8125
8126
8127
8128
8129
8130
8131
8132
8133
8134
8135
8136
8137
8138
8139
8140
8141
8142
8143
8144
8145
8146
8147
8148
8149
8150
8151
8152
8153
8154
8155
8156
8157
8158
8159
8160
8161
8162
8163
8164
8165
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
8191
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
8203
8204
8205
8206
8207
8208
8209
8210
8211
8212
8213
8214
8215
8216
8217
8218
8219
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
8239
8240
8241
8242
8243
8244
8245
8246
8247
8248
8249
8250
8251
8252
8253
8254
8255
8256
8257
8258
8259
8260
8261
8262
8263
8264
8265
8266
8267
8268
8269
8270
8271
8272
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298
8299
8300
8301
8302
8303
8304
8305
8306
8307
8308
8309
8310
8311
8312
8313
8314
8315
8316
8317
8318
8319
8320
8321
8322
8323
8324
8325
8326
8327
8328
8329
8330
8331
8332
8333
8334
8335
8336
8337
8338
8339
8340
8341
8342
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361
8362
8363
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543
8544
8545
8546
8547
8548
8549
8550
8551
8552
8553
8554
8555
8556
8557
8558
8559
8560
8561
8562
8563
8564
8565
8566
8567
8568
8569
8570
8571
8572
8573
8574
8575
8576
8577
8578
8579
8580
8581
8582
8583
8584
8585
8586
8587
8588
8589
8590
8591
8592
8593
8594
8595
8596
8597
8598
8599
8600
8601
8602
8603
8604
8605
8606
8607
8608
8609
8610
8611
8612
8613
8614
8615
8616
8617
8618
8619
8620
8621
8622
8623
8624
8625
8626
8627
8628
8629
8630
8631
8632
8633
8634
8635
8636
8637
8638
8639
8640
8641
8642
8643
8644
8645
8646
8647
8648
8649
8650
8651
8652
8653
8654
8655
8656
8657
8658
8659
8660
8661
8662
8663
8664
8665
8666
8667
8668
8669
8670
8671
8672
8673
8674
8675
8676
8677
8678
8679
8680
8681
8682
8683
8684
8685
8686
8687
8688
8689
8690
8691
8692
8693
8694
8695
8696
8697
8698
8699
8700
8701
8702
8703
8704
8705
8706
8707
8708
8709
8710
8711
8712
8713
8714
8715
8716
8717
8718
8719
8720
8721
8722
8723
8724
8725
8726
8727
8728
8729
8730
8731
8732
8733
8734
8735
8736
8737
8738
8739
8740
8741
8742
8743
8744
8745
8746
8747
8748
8749
8750
8751
8752
8753
8754
8755
8756
8757
8758
8759
8760
8761
8762
8763
8764
8765
8766
8767
8768
8769
8770
8771
8772
8773
8774
8775
8776
8777
8778
8779
8780
8781
8782
8783
8784
8785
8786
8787
8788
8789
8790
8791
8792
8793
8794
8795
8796
8797
8798
8799
8800
8801
8802
8803
8804
8805
8806
8807
8808
8809
8810
8811
8812
8813
8814
8815
8816
8817
8818
8819
8820
8821
8822
8823
8824
8825
8826
8827
8828
8829
8830
8831
8832
8833
8834
8835
8836
8837
8838
8839
8840
8841
8842
8843
8844
8845
8846
8847
8848
8849
8850
8851
8852
8853
8854
8855
8856
8857
8858
8859
8860
8861
8862
8863
8864
8865
8866
8867
8868
8869
8870
8871
8872
8873
8874
8875
8876
8877
8878
8879
8880
8881
8882
8883
8884
8885
8886
8887
8888
8889
8890
8891
8892
8893
8894
8895
8896
8897
8898
8899
8900
8901
8902
8903
8904
8905
8906
8907
8908
8909
8910
8911
8912
8913
8914
8915
8916
8917
8918
8919
8920
8921
8922
8923
8924
8925
8926
8927
8928
8929
8930
8931
8932
8933
8934
8935
8936
8937
8938
8939
8940
8941
8942
8943
8944
8945
8946
8947
8948
8949
8950
8951
8952
8953
8954
8955
8956
8957
8958
8959
8960
8961
8962
8963
8964
8965
8966
8967
8968
8969
8970
8971
8972
8973
8974
8975
8976
8977
8978
8979
8980
8981
8982
8983
8984
8985
8986
8987
8988
8989
8990
8991
8992
8993
8994
8995
8996
8997
8998
8999
9000
9001
9002
9003
9004
9005
9006
9007
9008
9009
9010
9011
9012
9013
9014
9015
9016
9017
9018
9019
9020
9021
9022
9023
9024
9025
9026
9027
9028
9029
9030
9031
9032
9033
9034
9035
9036
9037
9038
9039
9040
9041
9042
9043
9044
9045
9046
9047
9048
9049
9050
9051
9052
9053
9054
9055
9056
9057
9058
9059
9060
9061
9062
9063
9064
9065
9066
9067
9068
9069
9070
9071
9072
9073
9074
9075
9076
9077
9078
9079
9080
9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
9093
9094
9095
9096
9097
9098
9099
9100
9101
9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
9122
9123
9124
9125
9126
9127
9128
9129
9130
9131
9132
9133
9134
9135
9136
9137
9138
9139
9140
9141
9142
9143
9144
9145
9146
9147
9148
9149
9150
9151
9152
9153
9154
9155
9156
9157
9158
9159
9160
9161
9162
9163
9164
9165
9166
9167
9168
9169
9170
9171
9172
9173
9174
9175
9176
9177
9178
9179
9180
9181
9182
9183
9184
9185
9186
9187
9188
9189
9190
9191
9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
9279
9280
9281
9282
9283
9284
9285
9286
9287
9288
9289
9290
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
9314
9315
9316
9317
9318
9319
9320
9321
9322
9323
9324
9325
9326
9327
9328
9329
9330
9331
9332
9333
9334
9335
9336
9337
9338
9339
9340
9341
9342
9343
9344
9345
9346
9347
9348
9349
9350
9351
9352
9353
9354
9355
9356
9357
9358
9359
9360
9361
9362
9363
9364
9365
9366
9367
9368
9369
9370
9371
9372
9373
9374
9375
9376
9377
9378
9379
9380
9381
# Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: stooop.test,v 1.4 2001/12/19 11:58:22 jfontain Exp $

if {[lsearch [namespace children] ::tcltest]<0} {
    package require tcltest
    namespace import ::tcltest::*
}

set source [file join [file dirname [info script]] stooop.tcl]

set dumpArraysCode {
    proc dumpArrays {args} {
        set list {}
        foreach array $args {
            upvar $array data
            foreach name [lsort [array names data]] {
                lappend list "$array\($name\) = $data($name)"
            }
        }
        return $list
    }
}

test stooop-0 {
    check that the empty named array feature works
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        set (0) 0
        lappend ::result $(0)
        namespace eval n {
            variable {}
            set (1) 1
            lappend ::result $(1)
        }

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    0\
    1\
]

test stooop-1 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {new a} ::result
        set ::result
    }]
    interp delete $interpreter
    set result
} {invalid command name "a::a"}

test stooop-2 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
        }
        catch {delete [new a]} message
        lappend ::result $message

        class A {
            proc A {this} {
                lappend ::result "A::A $this"
            }
        }
        catch {delete [new A]} message
        lappend ::result $message

        class b::c {}
        proc b::c::c {this} {
            lappend ::result "c::c $this"
        }
        catch {delete [new b::c]} message
        lappend ::result $message

        class B {
            class C {
                proc C {this} {
                    lappend ::result "C::C $this"
                }
            }
            catch {delete [new C]} message
            lappend ::result $message
        }
        catch {delete [new B::C]} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {invalid command name "::a::~a"}\
    {A::A 2}\
    {invalid command name "::A::~A"}\
    {c::c 3}\
    {invalid command name "::b::c::~c"}\
    {C::C 4}\
    {invalid command name "::B::C::~C"}\
    {C::C 5}\
    {invalid command name "::B::C::~C"}\
]

test stooop-3 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        catch {new a} message
        lappend ::result $message

        class b::c {}
        catch {new b::c} message
        lappend ::result $message

        class A {}
        catch {new A} message
        lappend ::result $message

        class B {
            class C {}
            catch {new C} message
            lappend ::result $message
        }
        catch {new B::C} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {invalid command name "a::a"}\
    {invalid command name "b::c::c"}\
    {invalid command name "A::A"}\
    {invalid command name "C::C"}\
    {invalid command name "B::C::C"}\
]

test stooop-4 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p q} {
            lappend ::result "a::a $this"
            set ($this,m) $p
            set ($this,n) $q
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        set o [new a x {y z}]
        eval lappend ::result [dumpArrays a::]
        delete $o
        eval lappend ::result [dumpArrays a::]

        class A {
            proc A {this p q} {
                lappend ::result "A::A $this"
                set ($this,m) $p
                set ($this,n) $q
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        set o [new A x {y z}]
        eval lappend ::result [dumpArrays A::]
        delete $o
        eval lappend ::result [dumpArrays A::]

        class c::d {}
        proc c::d::d {this p q} {
            lappend ::result "d::d $this"
            set ($this,m) $p
            set ($this,n) $q
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        set o [new c::d x {y z}]
        eval lappend ::result [dumpArrays c::d::]
        delete $o
        eval lappend ::result [dumpArrays c::d::]

        class C {
            class D {
                proc D {this p q} {
                    lappend ::result "D::D $this"
                    set ($this,m) $p
                    set ($this,n) $q
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            set o [new D x {y z}]
            eval lappend ::result [dumpArrays D::]
            delete $o
            eval lappend ::result [dumpArrays D::]
        }
        set o [new C::D x {y z}]
        eval lappend ::result [dumpArrays C::D::]
        delete $o
        eval lappend ::result [dumpArrays C::D::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {a::(1,m) = x}\
    {a::(1,n) = y z}\
    {a::~a 1}\
    {A::A 2}\
    {A::(2,m) = x}\
    {A::(2,n) = y z}\
    {A::~A 2}\
    {d::d 3}\
    {c::d::(3,m) = x}\
    {c::d::(3,n) = y z}\
    {d::~d 3}\
    {D::D 4}\
    {D::(4,m) = x}\
    {D::(4,n) = y z}\
    {D::~D 4}\
    {D::D 5}\
    {C::D::(5,m) = x}\
    {C::D::(5,n) = y z}\
    {D::~D 5}\
]

test stooop-5 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class ::a {}
        class b::b {}
        set ::result {}
    }]
    interp delete $interpreter
    set result
} {}

test stooop-6 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p q} a {$p} {
            lappend ::result "b::b $this"
            set ($this,n) $q
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        set o [new b {x y} z]
        eval lappend ::result [dumpArrays a:: b::]
        delete $o
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this p} {
                lappend ::result "A::A $this"
                set ($this,m) $p
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p q} A {$p} {
                lappend ::result "B::B $this"
                set ($this,n) $q
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        set o [new B {x y} z]
        eval lappend ::result [dumpArrays A:: B::]
        delete $o
        eval lappend ::result [dumpArrays A:: B::]

        class c::d {}
        proc c::d::d {this p} {
            lappend ::result "d::d $this"
            set ($this,m) $p
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this p q} c::d {$p} {
            lappend ::result "e::e $this"
            set ($this,n) $q
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        set o [new c::e {x y} z]
        eval lappend ::result [dumpArrays c::d:: c::e::]
        delete $o
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this p} {
                    lappend ::result "D::D $this"
                    set ($this,m) $p
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p q} C::D {$p} {
                    lappend ::result "E::E $this"
                    set ($this,n) $q
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
        }
        set o [new C::E {x y} z]
        eval lappend ::result [dumpArrays C::D:: C::E::]
        delete $o
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = x y}\
    {b::(1,n) = z}\
    {b::~b 1}\
    {a::~a 1}\
    {A::A 2}\
    {B::B 2}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = x y}\
    {B::(2,n) = z}\
    {B::~B 2}\
    {A::~A 2}\
    {d::d 3}\
    {e::e 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = x y}\
    {c::e::(3,n) = z}\
    {e::~e 3}\
    {d::~d 3}\
    {D::D 4}\
    {E::E 4}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = x y}\
    {C::E::(4,n) = z}\
    {E::~E 4}\
    {D::~D 4}\
]

test stooop-7 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        class b {}
        proc b::b {this} a {} {}
        class c {}
        proc c::c {this} b {} a {} {}
        lappend ::result [classof [new a]]
        lappend ::result [classof [new b]]
        lappend ::result [classof [new c]]

        class A {
            proc A {this} {}
        }
        class B {
            proc B {this} A {} {}
        }
        class C {
            proc C {this} B {} A {} {}
        }
        lappend ::result [classof [new A]]
        lappend ::result [classof [new B]]
        lappend ::result [classof [new C]]

        class d::e {}
        proc d::e::e {this} {}
        class d::f {}
        proc d::f::f {this} d::e {} {}
        class d::g {}
        proc d::g::g {this} d::f {} d::e {} {}
        lappend ::result [classof [new d::e]]
        lappend ::result [classof [new d::f]]
        lappend ::result [classof [new d::g]]

        class D {
            class E {
                proc E {this} {}
            }
            class F {
                proc F {this} D::E {} {}
            }
            class G {
                proc G {this} D::F {} D::E {} {}
            }
            lappend ::result [classof [new E]]
            lappend ::result [classof [new F]]
            lappend ::result [classof [new G]]
        }
        lappend ::result [classof [new D::E]]
        lappend ::result [classof [new D::F]]
        lappend ::result [classof [new D::G]]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    ::a\
    ::b\
    ::c\
    ::A\
    ::B\
    ::C\
    ::d::e\
    ::d::f\
    ::d::g\
    ::D::E\
    ::D::F\
    ::D::G\
    ::D::E\
    ::D::F\
    ::D::G\
]

test stooop-8 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this} a {} {
            lappend ::result "b::b $this"
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class c {}
        proc c::c {this} b {} {
            lappend ::result "c::c $this"
        }
        proc c::~c {this} {
            lappend ::result "c::~c $this"
        }
        delete [new a]
        delete [new b]
        delete [new c]

        class A {
            proc A {this} {
                lappend ::result "A::A $this"
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this} A {} {
                lappend ::result "B::B $this"
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        class C {
            proc C {this} B {} {
                lappend ::result "C::C $this"
            }
            proc ~C {this} {
                lappend ::result "C::~C $this"
            }
        }
        delete [new A]
        delete [new B]
        delete [new C]

        class d::e {}
        proc d::e::e {this} {
            lappend ::result "e::e $this"
        }
        proc d::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        class d::f {}
        proc d::f::f {this} d::e {} {
            lappend ::result "f::f $this"
        }
        proc d::f::~f {this} {
            lappend ::result "f::~f $this"
        }
        class d::g {}
        proc d::g::g {this} d::f {} {
            lappend ::result "g::g $this"
        }
        proc d::g::~g {this} {
            lappend ::result "g::~g $this"
        }
        delete [new d::e]
        delete [new d::f]
        delete [new d::g]

        class D {
            class E {
                proc E {this} {
                    lappend ::result "E::E $this"
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            class F {
                proc F {this} D::E {} {
                    lappend ::result "F::F $this"
                }
                proc ~F {this} {
                    lappend ::result "F::~F $this"
                }
            }
            class G {
                proc G {this} D::F {} {
                    lappend ::result "G::G $this"
                }
                proc ~G {this} {
                    lappend ::result "G::~G $this"
                }
            }
            delete [new E]
            delete [new F]
            delete [new G]
        }
        delete [new D::E]
        delete [new D::F]
        delete [new D::G]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {a::~a 1}\
    {a::a 2}\
    {b::b 2}\
    {b::~b 2}\
    {a::~a 2}\
    {a::a 3}\
    {b::b 3}\
    {c::c 3}\
    {c::~c 3}\
    {b::~b 3}\
    {a::~a 3}\
    {A::A 4}\
    {A::~A 4}\
    {A::A 5}\
    {B::B 5}\
    {B::~B 5}\
    {A::~A 5}\
    {A::A 6}\
    {B::B 6}\
    {C::C 6}\
    {C::~C 6}\
    {B::~B 6}\
    {A::~A 6}\
    {e::e 7}\
    {e::~e 7}\
    {e::e 8}\
    {f::f 8}\
    {f::~f 8}\
    {e::~e 8}\
    {e::e 9}\
    {f::f 9}\
    {g::g 9}\
    {g::~g 9}\
    {f::~f 9}\
    {e::~e 9}\
    {E::E 10}\
    {E::~E 10}\
    {E::E 11}\
    {F::F 11}\
    {F::~F 11}\
    {E::~E 11}\
    {E::E 12}\
    {F::F 12}\
    {G::G 12}\
    {G::~G 12}\
    {F::~F 12}\
    {E::~E 12}\
    {E::E 13}\
    {E::~E 13}\
    {E::E 14}\
    {F::F 14}\
    {F::~F 14}\
    {E::~E 14}\
    {E::E 15}\
    {F::F 15}\
    {G::G 15}\
    {G::~G 15}\
    {F::~F 15}\
    {E::~E 15}\
]

test stooop-9 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {}
            proc a::~a {this p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                proc ~A {this p} {}
            }
        } message
        lappend ::result $message

        catch {
            class b::c {}
            proc b::c::c {this} {}
            proc b::c::~c {this p} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C {this} {}
                    proc ~C {this p} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a destructor must have 1 argument exactly}\
    {class ::A destructor must have 1 argument exactly}\
    {class ::b::c destructor must have 1 argument exactly}\
    {class ::B::C destructor must have 1 argument exactly}\
]

test stooop-10 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {}
            virtual proc a::~a {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                virtual proc ~A {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b::c {}
            proc b::c::c {this} {}
            virtual proc b::c::~c {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C {this} {}
                    virtual proc ~C {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {cannot make class ::a destructor virtual}\
    {cannot make class ::A destructor virtual}\
    {cannot make class ::b::c destructor virtual}\
    {cannot make class ::B::C destructor virtual}\
]

test stooop-11 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        virtual proc a::f {this p q} {}
        virtual proc a::g {this p q}
        virtual proc a::h {this p q} {
            lappend ::result "a::h $this $p $q"
        }
        virtual proc a::i {this p q}
        class b {}
        proc b::b {this} a {} {
            lappend ::result "b::b $this"
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        virtual proc b::f {this p q} {
            lappend ::result "b::f $this $p $q"
        }
        virtual proc b::g {this p q} {
            lappend ::result "b::g $this $p $q"
        }
        set o [new b]
        a::f $o x {y z}
        a::g $o x {y z}
        a::h $o x {y z}
        catch {a::i $o x {y z}} message
        lappend ::result $message

        class A {
            proc A {this} {
                lappend ::result "A::A $this"
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
            virtual proc f {this p q} {}
            virtual proc g {this p q}
            virtual proc h {this p q} {
                lappend ::result "A::h $this $p $q"
            }
            virtual proc i {this p q}
        }
        class B {
            proc B {this} A {} {
                lappend ::result "B::B $this"
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
            virtual proc f {this p q} {
                lappend ::result "B::f $this $p $q"
            }
            virtual proc g {this p q} {
                lappend ::result "B::g $this $p $q"
            }
        }
        set o [new B]
        A::f $o x {y z}
        A::g $o x {y z}
        A::h $o x {y z}
        catch {A::i $o x {y z}} message
        lappend ::result $message

        class c::d {}
        proc c::d::d {this} {
            lappend ::result "d::d $this"
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        virtual proc c::d::f {this p q} {}
        virtual proc c::d::g {this p q}
        virtual proc c::d::h {this p q} {
            lappend ::result "d::h $this $p $q"
        }
        virtual proc c::d::i {this p q}
        class c::e {}
        proc c::e::e {this} c::d {} {
            lappend ::result "e::e $this"
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        virtual proc c::e::f {this p q} {
            lappend ::result "e::f $this $p $q"
        }
        virtual proc c::e::g {this p q} {
            lappend ::result "e::g $this $p $q"
        }
        set o [new c::e]
        c::d::f $o x {y z}
        c::d::g $o x {y z}
        c::d::h $o x {y z}
        catch {c::d::i $o x {y z}} message
        lappend ::result $message

        class C {
            class D {
                proc D {this} {
                    lappend ::result "D::D $this"
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
                virtual proc f {this p q} {}
                virtual proc g {this p q}
                virtual proc h {this p q} {
                    lappend ::result "D::h $this $p $q"
                }
                virtual proc i {this p q}
            }
            class E {
                proc E {this} C::D {} {
                    lappend ::result "E::E $this"
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
                virtual proc f {this p q} {
                    lappend ::result "E::f $this $p $q"
                }
                virtual proc g {this p q} {
                    lappend ::result "E::g $this $p $q"
                }
            }
            set o [new E]
            D::f $o x {y z}
            D::g $o x {y z}
            D::h $o x {y z}
            catch {D::i $o x {y z}} message
            lappend ::result $message
        }
        set o [new C::E]
        C::D::f $o x {y z}
        C::D::g $o x {y z}
        C::D::h $o x {y z}
        catch {C::D::i $o x {y z}} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {b::f 1 x y z}\
    {b::g 1 x y z}\
    {a::h 1 x y z}\
    {invalid command name "::b::i"}\
    {A::A 2}\
    {B::B 2}\
    {B::f 2 x y z}\
    {B::g 2 x y z}\
    {A::h 2 x y z}\
    {invalid command name "::B::i"}\
    {d::d 3}\
    {e::e 3}\
    {e::f 3 x y z}\
    {e::g 3 x y z}\
    {d::h 3 x y z}\
    {invalid command name "::c::e::i"}\
    {D::D 4}\
    {E::E 4}\
    {E::f 4 x y z}\
    {E::g 4 x y z}\
    {D::h 4 x y z}\
    {invalid command name "::C::E::i"}\
    {D::D 5}\
    {E::E 5}\
    {E::f 5 x y z}\
    {E::g 5 x y z}\
    {D::h 5 x y z}\
    {invalid command name "::C::E::i"}\
]

test stooop-12 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            virtual proc a::a {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                virtual proc A {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b::c {}
            virtual proc b::c::c {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    virtual proc C {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {cannot make class ::a constructor virtual}\
    {cannot make class ::A constructor virtual}\
    {cannot make class ::b::c constructor virtual}\
    {cannot make class ::B::C constructor virtual}\
]

test stooop-13 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::~a {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc ~A {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b::c {}
            proc b::c::~c {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc ~C {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a destructor defined before constructor}\
    {class ::A destructor defined before constructor}\
    {class ::b::c destructor defined before constructor}\
    {class ::B::C destructor defined before constructor}\
]

test stooop-14 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        catch {
            class b {}
            proc b::b {this} a {} {}
        } message
        lappend ::result $message

        class A {}
        catch {
            class B {
                proc B {this} A {} {}
            }
        } message
        lappend ::result $message

        class b::c {}
        catch {
            class b::d {}
            proc b::d::d {this} b::c {} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {}
                class D {
                    proc D {this} C {} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::b constructor defined before base class a constructor}\
    {class ::B constructor defined before base class A constructor}\
    {class ::b::d constructor defined before base class b::c constructor}\
    {class ::B::D constructor defined before base class C constructor}\
]

test stooop-15 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            virtual a::f {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                virtual f {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b::c {}
            virtual b::c::f {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    virtual f {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {virtual operator works only on proc, not a::f}\
    {virtual operator works only on proc, not f}\
    {virtual operator works only on proc, not b::c::f}\
    {virtual operator works only on proc, not f}\
]

test stooop-16 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            virtual proc f {} {}
        } message
        lappend ::result $message

        catch {
            virtual proc a::f {} {}
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {procedure ::f class name is empty}\
    {procedure ::a::f class ::a is unknown}\
]

test stooop-17 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::f {this}
        } message
        lappend ::result $message

        catch {
            class A {
                proc f {this}
            }
        } message
        lappend ::result $message

        catch {
            class b::c {}
            proc b::c::f {this}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc f {this}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {missing body for ::a::f}\
    {missing body for ::A::f}\
    {missing body for ::b::c::f}\
    {missing body for ::B::C::f}\
]

test stooop-18 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class b {}
            proc b::b {this} a {}
        } message
        lappend ::result $message

        catch {
            class B {
                proc B {this} A {}
            }
        } message
        lappend ::result $message

        catch {
            class c::e {}
            proc c::e::e {this} d {}
        } message
        lappend ::result $message

        catch {
            class C {
                class E {
                    proc E {this} D {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {bad class ::b constructor declaration, a base class, contructor arguments or body may be missing}\
    {bad class ::B constructor declaration, a base class, contructor arguments or body may be missing}\
    {bad class ::c::e constructor declaration, a base class, contructor arguments or body may be missing}\
    {bad class ::C::E constructor declaration, a base class, contructor arguments or body may be missing}\
]

test stooop-19 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class b {}
            proc b::b {this} b {} {}
        } message
        lappend ::result $message

        catch {
            class B {
                proc B {this} B {} {}
            }
        } message
        lappend ::result $message

        catch {
            class c::d {}
            proc c::d::d {this} c::d {} {}
        } message
        lappend ::result $message

        catch {
            class C {
                class D {
                    proc D {this} D {} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::b cannot be derived from itself}\
    {class ::B cannot be derived from itself}\
    {class ::c::d cannot be derived from itself}\
    {class ::C::D cannot be derived from itself}\
]

test stooop-20 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::~a {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc ~A {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class a {}
            proc a::a {this} {}
            class a::b {}
            proc a::b::~b {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                class B {
                    proc ~B {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a destructor defined before constructor}\
    {class ::A destructor defined before constructor}\
    {class ::a::b destructor defined before constructor}\
    {class ::A::B destructor defined before constructor}\
]

test stooop-21 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {p} {}
            }
        } message
        lappend ::result $message

        catch {
            class a {}
            proc a::a {this} {}
            class a::b {}
            proc a::b::b {p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                class B {
                    proc B {p} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a constructor first argument must be this}\
    {class ::A constructor first argument must be this}\
    {class ::a::b constructor first argument must be this}\
    {class ::A::B constructor first argument must be this}\
]

test stooop-22 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::~a {p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc ~A {p} {}
            }
        } message
        lappend ::result $message

        catch {
            class a {}
            proc a::a {this} {}
            class a::b {}
            proc a::b::~b {p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                class B {
                    proc ~B {p} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a destructor argument must be this}\
    {class ::A destructor argument must be this}\
    {class ::a::b destructor argument must be this}\
    {class ::A::B destructor argument must be this}\
]

test stooop-23 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            virtual proc a::f {p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                virtual proc f {p} {}
            }
        } message
        lappend ::result $message

        catch {
            class a {}
            proc a::a {this} {}
            class a::b {}
            virtual proc a::b::f {p} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                class B {
                    virtual proc f {p} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {cannot make static procedure f of class ::a virtual}\
    {cannot make static procedure f of class ::A virtual}\
    {cannot make static procedure f of class ::a::b virtual}\
    {cannot make static procedure f of class ::A::B virtual}\
]

test stooop-24 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p args} {
            lappend ::result "a::a $this $p $args"
            set ($this,m) [lindex $args 0]
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p args} a {$p $args} {
            lappend ::result "b::b $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        new b {x y} {1 2} 3
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this p args} {
                lappend ::result "A::A $this $p $args"
                set ($this,m) [lindex $args 0]
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p args} A {$p $args} {
                lappend ::result "B::B $this $p $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        new B {x y} {1 2} 3
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this p args} {
            lappend ::result "d::d $this $p $args"
            set ($this,m) [lindex $args 0]
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this p args} c::d {$p $args} {
            lappend ::result "e::e $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        new c::e {x y} {1 2} 3
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this p args} {
                    lappend ::result "D::D $this $p $args"
                    set ($this,m) [lindex $args 0]
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p args} C::D {$p $args} {
                    lappend ::result "E::E $this $p $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            new E {x y} {1 2} 3
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E {x y} {1 2} 3
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 x y {1 2} 3}\
    {b::b 1 x y {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1 2}\
    {b::(1,n) = 1 2}\
    {A::A 2 x y {1 2} 3}\
    {B::B 2 x y {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1 2}\
    {B::(2,n) = 1 2}\
    {d::d 3 x y {1 2} 3}\
    {e::e 3 x y {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1 2}\
    {c::e::(3,n) = 1 2}\
    {D::D 4 x y {1 2} 3}\
    {E::E 4 x y {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1 2}\
    {E::(4,n) = 1 2}\
    {D::D 5 x y {1 2} 3}\
    {E::E 5 x y {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1 2}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1 2}\
    {C::E::(4,n) = 1 2}\
    {C::E::(5,n) = 1 2}\
]

test stooop-25 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        virtual proc a::f {this p args} {}
        proc a::g {this p args} {
            lappend ::result "a::g $this $p $args"
        }
        class b {}
        proc b::b {this} a {} {
            lappend ::result "b::b $this"
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        virtual proc b::f {this p args} {
            lappend ::result "b::f $this $p $args"
        }
        set o [new b]
        a::f $o {x y} {1 2} 3
        a::g $o {x y} {1 2} 3

        class A {
            proc A {this} {
                lappend ::result "A::A $this"
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
            virtual proc f {this p args} {}
            proc g {this p args} {
                lappend ::result "A::g $this $p $args"
            }
        }
        class B {
            proc B {this} A {} {
                lappend ::result "B::B $this"
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
            virtual proc f {this p args} {
                lappend ::result "B::f $this $p $args"
            }
        }
        set o [new B]
        A::f $o {x y} {1 2} 3
        A::g $o {x y} {1 2} 3

        class c {}
        class c::d {}
        proc c::d::d {this} {
            lappend ::result "d::d $this"
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        virtual proc c::d::f {this p args} {}
        proc c::d::g {this p args} {
            lappend ::result "d::g $this $p $args"
        }
        class c::e {}
        proc c::e::e {this} c::d {} {
            lappend ::result "e::e $this"
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        virtual proc c::e::f {this p args} {
            lappend ::result "e::f $this $p $args"
        }
        set o [new c::e]
        c::d::f $o {x y} {1 2} 3
        c::d::g $o {x y} {1 2} 3

        class C {
            class D {
                proc D {this} {
                    lappend ::result "D::D $this"
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
                virtual proc f {this p args} {}
                proc g {this p args} {
                    lappend ::result "D::g $this $p $args"
                }
            }
            class B {
                proc B {this} C::D {} {
                    lappend ::result "B::B $this"
                }
                proc ~B {this} {
                    lappend ::result "B::~B $this"
                }
                virtual proc f {this p args} {
                    lappend ::result "B::f $this $p $args"
                }
            }
            set o [new B]
            D::f $o {x y} {1 2} 3
            D::g $o {x y} {1 2} 3
        }
        set o [new C::B]
        C::D::f $o {x y} {1 2} 3
        C::D::g $o {x y} {1 2} 3

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {b::f 1 x y {1 2} 3}\
    {a::g 1 x y {1 2} 3}\
    {A::A 2}\
    {B::B 2}\
    {B::f 2 x y {1 2} 3}\
    {A::g 2 x y {1 2} 3}\
    {d::d 3}\
    {e::e 3}\
    {e::f 3 x y {1 2} 3}\
    {d::g 3 x y {1 2} 3}\
    {D::D 4}\
    {B::B 4}\
    {B::f 4 x y {1 2} 3}\
    {D::g 4 x y {1 2} 3}\
    {D::D 5}\
    {B::B 5}\
    {B::f 5 x y {1 2} 3}\
    {D::g 5 x y {1 2} 3}\
]

test stooop-26 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p q args} {
            lappend ::result "a::a $this $p $q $args"
            set ($this,m) [lindex $args 0]
            set ($this,p) $p
            set ($this,q) $q
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p q args} a {$p $q $args} {
            lappend ::result "b::b $this $p $q $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        new b {x y} {X Y} {1 2} 3
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this p q args} {
                lappend ::result "A::A $this $p $q $args"
                set ($this,m) [lindex $args 0]
                set ($this,p) $p
                set ($this,q) $q
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p q args} A {$p $q $args} {
                lappend ::result "B::B $this $p $q $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        new B {x y} {X Y} {1 2} 3
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this p q args} {
            lappend ::result "d::d $this $p $q $args"
            set ($this,m) [lindex $args 0]
            set ($this,p) $p
            set ($this,q) $q
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this p q args} c::d {$p $q $args} {
            lappend ::result "e::e $this $p $q $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        new c::e {x y} {X Y} {1 2} 3
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this p q args} {
                    lappend ::result "D::D $this $p $q $args"
                    set ($this,m) [lindex $args 0]
                    set ($this,p) $p
                    set ($this,q) $q
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p q args} C::D {$p $q $args} {
                    lappend ::result "E::E $this $p $q $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            new E {x y} {X Y} {1 2} 3
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E {x y} {X Y} {1 2} 3
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 x y X Y {1 2} 3}\
    {b::b 1 x y X Y {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1 2}\
    {a::(1,p) = x y}\
    {a::(1,q) = X Y}\
    {b::(1,n) = 1 2}\
    {A::A 2 x y X Y {1 2} 3}\
    {B::B 2 x y X Y {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1 2}\
    {A::(2,p) = x y}\
    {A::(2,q) = X Y}\
    {B::(2,n) = 1 2}\
    {d::d 3 x y X Y {1 2} 3}\
    {e::e 3 x y X Y {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1 2}\
    {c::d::(3,p) = x y}\
    {c::d::(3,q) = X Y}\
    {c::e::(3,n) = 1 2}\
    {D::D 4 x y X Y {1 2} 3}\
    {E::E 4 x y X Y {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1 2}\
    {D::(4,p) = x y}\
    {D::(4,q) = X Y}\
    {E::(4,n) = 1 2}\
    {D::D 5 x y X Y {1 2} 3}\
    {E::E 5 x y X Y {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1 2}\
    {C::D::(4,p) = x y}\
    {C::D::(4,q) = X Y}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1 2}\
    {C::D::(5,p) = x y}\
    {C::D::(5,q) = X Y}\
    {C::E::(4,n) = 1 2}\
    {C::E::(5,n) = 1 2}\
]

test stooop-27 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this args} {
            lappend ::result "a::a $this $args"
            set ($this,m) [lindex $args 0]
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p args} a {$args} {
            lappend ::result "b::b $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        new b {x y} {1 2} 3
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this args} {
                lappend ::result "A::A $this $args"
                set ($this,m) [lindex $args 0]
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p args} A {$args} {
                lappend ::result "B::B $this $p $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        new B {x y} {1 2} 3
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this args} {
            lappend ::result "d::d $this $args"
            set ($this,m) [lindex $args 0]
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this p args} c::d {$args} {
            lappend ::result "e::e $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        new c::e {x y} {1 2} 3
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this args} {
                    lappend ::result "D::D $this $args"
                    set ($this,m) [lindex $args 0]
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p args} C::D {$args} {
                    lappend ::result "E::E $this $p $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            new E {x y} {1 2} 3
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E {x y} {1 2} 3
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 {1 2} 3}\
    {b::b 1 x y {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1 2}\
    {b::(1,n) = 1 2}\
    {A::A 2 {1 2} 3}\
    {B::B 2 x y {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1 2}\
    {B::(2,n) = 1 2}\
    {d::d 3 {1 2} 3}\
    {e::e 3 x y {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1 2}\
    {c::e::(3,n) = 1 2}\
    {D::D 4 {1 2} 3}\
    {E::E 4 x y {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1 2}\
    {E::(4,n) = 1 2}\
    {D::D 5 {1 2} 3}\
    {E::E 5 x y {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1 2}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1 2}\
    {C::E::(4,n) = 1 2}\
    {C::E::(5,n) = 1 2}\
]

test stooop-28 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this args} {
            lappend ::result "a::a $this $args"
            set ($this,m) [lindex $args 0]
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this args} a {$args} {
            lappend ::result "b::b $this $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        new b {1 2} 3
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this args} {
                lappend ::result "A::A $this $args"
                set ($this,m) [lindex $args 0]
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this args} A {$args} {
                lappend ::result "B::B $this $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        new B {1 2} 3
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this args} {
            lappend ::result "d::d $this $args"
            set ($this,m) [lindex $args 0]
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this args} c::d {$args} {
            lappend ::result "e::e $this $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        new c::e {1 2} 3
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this args} {
                    lappend ::result "D::D $this $args"
                    set ($this,m) [lindex $args 0]
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this args} C::D {$args} {
                    lappend ::result "E::E $this $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            new E {1 2} 3
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E {1 2} 3
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 {1 2} 3}\
    {b::b 1 {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1 2}\
    {b::(1,n) = 1 2}\
    {A::A 2 {1 2} 3}\
    {B::B 2 {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1 2}\
    {B::(2,n) = 1 2}\
    {d::d 3 {1 2} 3}\
    {e::e 3 {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1 2}\
    {c::e::(3,n) = 1 2}\
    {D::D 4 {1 2} 3}\
    {E::E 4 {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1 2}\
    {E::(4,n) = 1 2}\
    {D::D 5 {1 2} 3}\
    {E::E 5 {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1 2}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1 2}\
    {C::E::(4,n) = 1 2}\
    {C::E::(5,n) = 1 2}\
]

test stooop-29 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this p q} {
            lappend ::result "a::a $this $p $q"
        }
        proc a::~a {this} {}
        class b {}
        proc b::b {this p q} a {
            $p $q
        } {
            lappend ::result "b::b $this $p $q"
        }
        proc b::~b {this} {}
        new b {x y} z

        class A {
            proc A {this p q} {
                lappend ::result "A::A $this $p $q"
            }
            proc ~A {this} {}
        }
        class B {
            proc B {this p q} A {
                $p $q
            } {
                lappend ::result "B::B $this $p $q"
            }
            proc ~B {this} {}
        }
        new B {x y} z

        class c {}
        class c::d {}
        proc c::d::d {this p q} {
            lappend ::result "d::d $this $p $q"
        }
        proc c::d::~d {this} {}
        class c::e {}
        proc c::e::e {this p q} c::d {
            $p $q
        } {
            lappend ::result "e::e $this $p $q"
        }
        proc c::e::~e {this} {}
        new c::e {x y} z

        class C {
            class D {
                proc D {this p q} {
                    lappend ::result "D::D $this $p $q"
                }
                proc ~D {this} {}
            }
            class E {
                proc E {this p q} C::D {
                    $p $q
                } {
                    lappend ::result "E::E $this $p $q"
                }
                proc ~E {this} {}
            }
            new E {x y} z
        }
        new C::E {x y} z

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 x y z}\
    {b::b 1 x y z}\
    {A::A 2 x y z}\
    {B::B 2 x y z}\
    {d::d 3 x y z}\
    {e::e 3 x y z}\
    {D::D 4 x y z}\
    {E::E 4 x y z}\
    {D::D 5 x y z}\
    {E::E 5 x y z}\
]

test stooop-30 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        virtual proc a::f {this p q} {
            lappend ::result "a::h $this $p $q"
        }
        virtual proc a::g {this p args} {
            lappend ::result "a::g $this $p $args"
        }
        class b {}
        proc b::b {this} a {} {
            lappend ::result "b::b $this"
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        proc b::f {this p q} {
            lappend ::result "b::f $this $p $q"
            a::_f $this $p $q
        }
        proc b::g {this p args} {
            lappend ::result "b::g $this $p $args"
            eval a::_g $this $p $args
        }
        set o [new b]
        a::f $o x {y z}
        a::g $o {x y} {1 2} 3 {4 5}

        class A {
            proc A {this} {
                lappend ::result "A::A $this"
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
            virtual proc f {this p q} {
                lappend ::result "A::h $this $p $q"
            }
            virtual proc g {this p args} {
                lappend ::result "A::g $this $p $args"
            }
        }
        class B {
            proc B {this} A {} {
                lappend ::result "B::B $this"
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
            proc f {this p q} {
                lappend ::result "B::f $this $p $q"
                A::_f $this $p $q
            }
            proc g {this p args} {
                lappend ::result "B::g $this $p $args"
                eval A::_g $this $p $args
            }
        }
        set o [new B]
        A::f $o x {y z}
        A::g $o {x y} {1 2} 3 {4 5}

        class c {}
        class c::d {}
        proc c::d::d {this} {
            lappend ::result "d::d $this"
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        virtual proc c::d::f {this p q} {
            lappend ::result "d::h $this $p $q"
        }
        virtual proc c::d::g {this p args} {
            lappend ::result "d::g $this $p $args"
        }
        class c::e {}
        proc c::e::e {this} c::d {} {
            lappend ::result "e::e $this"
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        proc c::e::f {this p q} {
            lappend ::result "e::f $this $p $q"
            c::d::_f $this $p $q
        }
        proc c::e::g {this p args} {
            lappend ::result "e::g $this $p $args"
            eval c::d::_g $this $p $args
        }
        set o [new c::e]
        c::d::f $o x {y z}
        c::d::g $o {x y} {1 2} 3 {4 5}

        class C {
            class D {
                proc D {this} {
                    lappend ::result "D::D $this"
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
                virtual proc f {this p q} {
                    lappend ::result "D::h $this $p $q"
                }
                virtual proc g {this p args} {
                    lappend ::result "D::g $this $p $args"
                }
            }
            class E {
                proc E {this} C::D {} {
                    lappend ::result "E::E $this"
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
                proc f {this p q} {
                    lappend ::result "E::f $this $p $q"
                    C::D::_f $this $p $q
                }
                proc g {this p args} {
                    lappend ::result "E::g $this $p $args"
                    eval C::D::_g $this $p $args
                }
            }
            set o [new E]
            D::f $o x {y z}
            D::g $o {x y} {1 2} 3 {4 5}
        }
        set o [new C::E]
        C::D::f $o x {y z}
        C::D::g $o {x y} {1 2} 3 {4 5}

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {b::f 1 x y z}\
    {a::h 1 x y z}\
    {b::g 1 x y {1 2} 3 {4 5}}\
    {a::g 1 x y {1 2} 3 {4 5}}\
    {A::A 2}\
    {B::B 2}\
    {B::f 2 x y z}\
    {A::h 2 x y z}\
    {B::g 2 x y {1 2} 3 {4 5}}\
    {A::g 2 x y {1 2} 3 {4 5}}\
    {d::d 3}\
    {e::e 3}\
    {e::f 3 x y z}\
    {d::h 3 x y z}\
    {e::g 3 x y {1 2} 3 {4 5}}\
    {d::g 3 x y {1 2} 3 {4 5}}\
    {D::D 4}\
    {E::E 4}\
    {E::f 4 x y z}\
    {D::h 4 x y z}\
    {E::g 4 x y {1 2} 3 {4 5}}\
    {D::g 4 x y {1 2} 3 {4 5}}\
    {D::D 5}\
    {E::E 5}\
    {E::f 5 x y z}\
    {D::h 5 x y z}\
    {E::g 5 x y {1 2} 3 {4 5}}\
    {D::g 5 x y {1 2} 3 {4 5}}\
]

test stooop-31 {
    check multiple inheritance construction order, destruction order and data
    deallocation
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class c {}
        proc c::c {this p q r} a {$p} b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $r
        }
        proc c::~c {this} {
            lappend ::result "c::~c $this"
        }
        set o [new c {x y} z {1 2}]
        eval lappend ::result [dumpArrays a:: b:: c::]
        delete $o
        eval lappend ::result [dumpArrays a:: b:: c::]

        class A {
            proc A {this p} {
                lappend ::result "A::A $this"
                set ($this,m) $p
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p} {
                lappend ::result "B::B $this"
                set ($this,n) $p
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        class C {
            proc C {this p q r} A {$p} B {$q} {
                lappend ::result "C::C $this"
                set ($this,o) $r
            }
            proc ~C {this} {
                lappend ::result "C::~C $this"
            }
        }
        set o [new C {x y} z {1 2}]
        eval lappend ::result [dumpArrays A:: B:: C::]
        delete $o
        eval lappend ::result [dumpArrays A:: B:: C::]

        class d {}
        class d::e {}
        proc d::e::e {this p} {
            lappend ::result "e::e $this"
            set ($this,m) $p
        }
        proc d::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        class d::f {}
        proc d::f::f {this p} {
            lappend ::result "f::f $this"
            set ($this,n) $p
        }
        proc d::f::~f {this} {
            lappend ::result "f::~f $this"
        }
        class d::g {}
        proc d::g::g {this p q r} d::e {$p} d::f {$q} {
            lappend ::result "g::g $this"
            set ($this,o) $r
        }
        proc d::g::~g {this} {
            lappend ::result "g::~g $this"
        }
        set o [new d::g {x y} z {1 2}]
        eval lappend ::result [dumpArrays d::e:: d::f:: d::g::]
        delete $o
        eval lappend ::result [dumpArrays d::e:: d::f:: d::g::]

        class C {
            class E {
                proc E {this p} {
                    lappend ::result "E::E $this"
                    set ($this,m) $p
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            class F {
                proc F {this p} {
                    lappend ::result "F::F $this"
                    set ($this,n) $p
                }
                proc ~F {this} {
                    lappend ::result "F::~F $this"
                }
            }
            class G {
                proc G {this p q r} C::E {$p} C::F {$q} {
                    lappend ::result "G::G $this"
                    set ($this,o) $r
                }
                proc ~G {this} {
                    lappend ::result "G::~G $this"
                }
            }
            set o [new G {x y} z {1 2}]
            eval lappend ::result [dumpArrays E:: F:: G::]
            delete $o
            eval lappend ::result [dumpArrays E:: F:: G::]
        }
        set o [new C::G {x y} z {1 2}]
        eval lappend ::result [dumpArrays C::E:: C::F:: C::G::]
        delete $o
        eval lappend ::result [dumpArrays C::E:: C::F:: C::G::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::(1,_derived) = ::c}\
    {a::(1,m) = x y}\
    {b::(1,_derived) = ::c}\
    {b::(1,n) = z}\
    {c::(1,o) = 1 2}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {A::A 2}\
    {B::B 2}\
    {C::C 2}\
    {A::(2,_derived) = ::C}\
    {A::(2,m) = x y}\
    {B::(2,_derived) = ::C}\
    {B::(2,n) = z}\
    {C::(2,o) = 1 2}\
    {C::~C 2}\
    {B::~B 2}\
    {A::~A 2}\
    {e::e 3}\
    {f::f 3}\
    {g::g 3}\
    {d::e::(3,_derived) = ::d::g}\
    {d::e::(3,m) = x y}\
    {d::f::(3,_derived) = ::d::g}\
    {d::f::(3,n) = z}\
    {d::g::(3,o) = 1 2}\
    {g::~g 3}\
    {f::~f 3}\
    {e::~e 3}\
    {E::E 4}\
    {F::F 4}\
    {G::G 4}\
    {E::(4,_derived) = ::C::G}\
    {E::(4,m) = x y}\
    {F::(4,_derived) = ::C::G}\
    {F::(4,n) = z}\
    {G::(4,o) = 1 2}\
    {G::~G 4}\
    {F::~F 4}\
    {E::~E 4}\
    {E::E 5}\
    {F::F 5}\
    {G::G 5}\
    {C::E::(5,_derived) = ::C::G}\
    {C::E::(5,m) = x y}\
    {C::F::(5,_derived) = ::C::G}\
    {C::F::(5,n) = z}\
    {C::G::(5,o) = 1 2}\
    {G::~G 5}\
    {F::~F 5}\
    {E::~E 5}\
]

test stooop-32 {
    check that class constructor with multiple base classes has correct number
    of base class / argument pairs
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class c {}
            proc c::c {this} a {} b {}
        } message
        lappend ::result $message

        catch {
            class C {
                proc C {this} A {} B {}
            }
        } message
        lappend ::result $message

        catch {
            class d {}
            class d::g {}
            proc d::g::g {this} d::e {} d::f {}
        } message
        lappend ::result $message

        catch {
            class C {
                class G {
                    proc G {this} C::E {} C::F {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {bad class ::c constructor declaration, a base class, contructor arguments or body may be missing}\
    {bad class ::C constructor declaration, a base class, contructor arguments or body may be missing}\
    {bad class ::d::g constructor declaration, a base class, contructor arguments or body may be missing}\
    {bad class ::C::G constructor declaration, a base class, contructor arguments or body may be missing}\
]

test stooop-33 {
    check that base class of class with multiple base classes is defined
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {}
            class b {}
            class c {}
            proc c::c {this} a {} b {} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
            }
            class B {}
            class C {
                proc C {this} A {} B {} {}
            }
        } message
        lappend ::result $message

        catch {
            class d {}
            class d::e {}
            proc d::e::e {this} {}
            class d::f {}
            class d::g {}
            proc d::g::g {this} d::e {} d::f {} {}
        } message
        lappend ::result $message

        catch {
            class C {
                class E {
                    proc E {this} {}
                }
                class F {}
                class G {
                    proc G {this} C::E {} C::F {} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::c constructor defined before base class b constructor}\
    {class ::C constructor defined before base class B constructor}\
    {class ::d::g constructor defined before base class d::f constructor}\
    {class ::C::G constructor defined before base class C::F constructor}\
]

test stooop-34 {
    check that a direct base class is not specified more than once in a class
    constructor declaration
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {}
            class c {}
            proc c::c {this} a {} a {} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
            }
            class C {
                proc C {this} A {} A {} {}
            }
        } message
        lappend ::result $message

        catch {
            class d {}
            class d::e {}
            proc d::e::e {this} {}
            class d::g {}
            proc d::g::g {this} d::e {} d::e {} {}
        } message
        lappend ::result $message

        catch {
            class D {
                class E {
                    proc E {this} {}
                }
                class G {
                    proc G {this} D::E {} D::E {} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::c directly inherits from class ::a more than once}\
    {class ::C directly inherits from class ::A more than once}\
    {class ::d::g directly inherits from class ::d::e more than once}\
    {class ::D::G directly inherits from class ::D::E more than once}\
]

test stooop-35 {
    check that class constructor with multiple base classes allows new lines
    within base class constructors arguments
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class c {}
        proc c::c {this p q r} a {
            $p
        } b {
            $q
        } {
            lappend ::result "c::c $this"
            set ($this,o) $r
        }
        proc c::~c {this} {
            lappend ::result "c::~c $this"
        }
        new c {x y} z {1 2}
        eval lappend ::result [dumpArrays a:: b:: c::]

        class A {
            proc A {this p} {
                lappend ::result "A::A $this"
                set ($this,m) $p
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p} {
                lappend ::result "B::B $this"
                set ($this,n) $p
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        class C {
            proc C {this p q r} A {
                $p
            } B {
                $q
            } {
                lappend ::result "C::C $this"
                set ($this,o) $r
            }
            proc ~C {this} {
                lappend ::result "C::~C $this"
            }
        }
        new C {x y} z {1 2}
        eval lappend ::result [dumpArrays A:: B:: C::]

        class d {}
        class d::e {}
        proc d::e::e {this p} {
            lappend ::result "e::e $this"
            set ($this,m) $p
        }
        proc d::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        class d::f {}
        proc d::f::f {this p} {
            lappend ::result "f::f $this"
            set ($this,n) $p
        }
        proc d::f::~f {this} {
            lappend ::result "f::~f $this"
        }
        class d::g {}
        proc d::g::g {this p q r} d::e {
            $p
        } d::f {
            $q
        } {
            lappend ::result "g::g $this"
            set ($this,o) $r
        }
        proc d::g::~g {this} {
            lappend ::result "g::~g $this"
        }
        new d::g {x y} z {1 2}
        eval lappend ::result [dumpArrays d::e:: d::f:: d::g::]

        class D {
            class E {
                proc E {this p} {
                    lappend ::result "E::E $this"
                    set ($this,m) $p
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            class F {
                proc F {this p} {
                    lappend ::result "F::F $this"
                    set ($this,n) $p
                }
                proc ~F {this} {
                    lappend ::result "F::~F $this"
                }
            }
            class G {
                proc G {this p q r} D::E {
                    $p
                } D::F {
                    $q
                } {
                    lappend ::result "G::G $this"
                    set ($this,o) $r
                }
                proc ~G {this} {
                    lappend ::result "G::~G $this"
                }
            }
            new G {x y} z {1 2}
            eval lappend ::result [dumpArrays E:: F:: G::]
        }
        new D::G {x y} z {1 2}
        eval lappend ::result [dumpArrays D::E:: D::F:: D::G::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::(1,_derived) = ::c}\
    {a::(1,m) = x y}\
    {b::(1,_derived) = ::c}\
    {b::(1,n) = z}\
    {c::(1,o) = 1 2}\
    {A::A 2}\
    {B::B 2}\
    {C::C 2}\
    {A::(2,_derived) = ::C}\
    {A::(2,m) = x y}\
    {B::(2,_derived) = ::C}\
    {B::(2,n) = z}\
    {C::(2,o) = 1 2}\
    {e::e 3}\
    {f::f 3}\
    {g::g 3}\
    {d::e::(3,_derived) = ::d::g}\
    {d::e::(3,m) = x y}\
    {d::f::(3,_derived) = ::d::g}\
    {d::f::(3,n) = z}\
    {d::g::(3,o) = 1 2}\
    {E::E 4}\
    {F::F 4}\
    {G::G 4}\
    {E::(4,_derived) = ::D::G}\
    {E::(4,m) = x y}\
    {F::(4,_derived) = ::D::G}\
    {F::(4,n) = z}\
    {G::(4,o) = 1 2}\
    {E::E 5}\
    {F::F 5}\
    {G::G 5}\
    {D::E::(4,_derived) = ::D::G}\
    {D::E::(4,m) = x y}\
    {D::E::(5,_derived) = ::D::G}\
    {D::E::(5,m) = x y}\
    {D::F::(4,_derived) = ::D::G}\
    {D::F::(4,n) = z}\
    {D::F::(5,_derived) = ::D::G}\
    {D::F::(5,n) = z}\
    {D::G::(4,o) = 1 2}\
    {D::G::(5,o) = 1 2}\
]

test stooop-36 {
    check multiple inheritance construction order, destruction order and data
    deallocation with a common indirect base class
    (see test 71 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class c {}
        proc c::c {this p q r} a {$p} b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $r
        }
        proc c::~c {this} {
            lappend ::result "c::~c $this"
        }
        class d {}
        proc d::d {this p q r} a {$p} b {$q} {
            lappend ::result "d::d $this"
            set ($this,p) $p
        }
        proc d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class e {}
        proc e::e {this p q r} c {$p $q $r} d {$q $q $r} {
            lappend ::result "e::e $this"
            set ($this,q) $q
        }
        proc e::~e {this} {
            lappend ::result "e::~e $this"
        }
        set o [new e {x y} z {1 2}]
        eval lappend ::result [dumpArrays a:: b:: c:: d:: e::]
        delete $o
        eval lappend ::result [dumpArrays a:: b:: c:: d:: e::]

        class A {
            proc A {this p} {
                lappend ::result "A::A $this"
                set ($this,m) $p
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p} {
                lappend ::result "B::B $this"
                set ($this,n) $p
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        class C {
            proc C {this p q r} A {$p} B {$q} {
                lappend ::result "C::C $this"
                set ($this,o) $r
            }
            proc ~C {this} {
                lappend ::result "C::~C $this"
            }
        }
        class D {
            proc D {this p q r} A {$p} B {$q} {
                lappend ::result "D::D $this"
                set ($this,p) $p
            }
            proc ~D {this} {
                lappend ::result "D::~D $this"
            }
        }
        class E {
            proc E {this p q r} C {$p $q $r} D {$q $q $r} {
                lappend ::result "E::E $this"
                set ($this,q) $q
            }
            proc ~E {this} {
                lappend ::result "E::~E $this"
            }
        }
        set o [new E {x y} z {1 2}]
        eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]
        delete $o
        eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::a 1}\
    {b::b 1}\
    {d::d 1}\
    {e::e 1}\
    {a::(1,_derived) = ::d}\
    {a::(1,m) = z}\
    {b::(1,_derived) = ::d}\
    {b::(1,n) = z}\
    {c::(1,_derived) = ::e}\
    {c::(1,o) = 1 2}\
    {d::(1,_derived) = ::e}\
    {d::(1,p) = z}\
    {e::(1,q) = z}\
    {e::~e 1}\
    {d::~d 1}\
    {b::~b 1}\
    {a::~a 1}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {A::A 2}\
    {B::B 2}\
    {C::C 2}\
    {A::A 2}\
    {B::B 2}\
    {D::D 2}\
    {E::E 2}\
    {A::(2,_derived) = ::D}\
    {A::(2,m) = z}\
    {B::(2,_derived) = ::D}\
    {B::(2,n) = z}\
    {C::(2,_derived) = ::E}\
    {C::(2,o) = 1 2}\
    {D::(2,_derived) = ::E}\
    {D::(2,p) = z}\
    {E::(2,q) = z}\
    {E::~E 2}\
    {D::~D 2}\
    {B::~B 2}\
    {A::~A 2}\
    {C::~C 2}\
    {B::~B 2}\
    {A::~A 2}\
]

test stooop-37 {
    check that multiply inherited base classes constructors work with variable
    number of arguments (see test 72 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this args} {
            lappend ::result "a::a $this $args"
            set ($this,m) [lindex $args 0]
        }
        class b {}
        proc b::b {this p} {
            lappend ::result "b::b $this $p"
            set ($this,n) $p
        }
        class c {}
        proc c::c {this p args} {
            lappend ::result "c::c $this $p $args"
            set ($this,o) $p
            set ($this,p) [lindex $args 0]
        }
        class d {}
        proc d::d {this p args} a {$args} b {$p} c {$p $args} {
            lappend ::result "d::d $this $p $args"
            set ($this,q) $p
            set ($this,r) [lindex $args 0]
        }
        new d {x y} {1 2} 3
        eval lappend ::result [dumpArrays a:: b:: c:: d::]

        class A {
            proc A {this args} {
                lappend ::result "A::A $this $args"
                set ($this,m) [lindex $args 0]
            }
        }
        class B {
            proc B {this p} {
                lappend ::result "B::B $this $p"
                set ($this,n) $p
            }
        }
        class C {
            proc C {this p args} {
                lappend ::result "C::C $this $p $args"
                set ($this,o) $p
                set ($this,p) [lindex $args 0]
            }
        }
        class D {
            proc D {this p args} A {$args} B {$p} C {$p $args} {
                lappend ::result "D::D $this $p $args"
                set ($this,q) $p
                set ($this,r) [lindex $args 0]
            }
        }
        new D {x y} {1 2} 3
        eval lappend ::result [dumpArrays A:: B:: C:: D::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 {1 2} 3}\
    {b::b 1 x y}\
    {c::c 1 x y {1 2} 3}\
    {d::d 1 x y {1 2} 3}\
    {a::(1,_derived) = ::d}\
    {a::(1,m) = 1 2}\
    {b::(1,_derived) = ::d}\
    {b::(1,n) = x y}\
    {c::(1,_derived) = ::d}\
    {c::(1,o) = x y}\
    {c::(1,p) = 1 2}\
    {d::(1,q) = x y}\
    {d::(1,r) = 1 2}\
    {A::A 2 {1 2} 3}\
    {B::B 2 x y}\
    {C::C 2 x y {1 2} 3}\
    {D::D 2 x y {1 2} 3}\
    {A::(2,_derived) = ::D}\
    {A::(2,m) = 1 2}\
    {B::(2,_derived) = ::D}\
    {B::(2,n) = x y}\
    {C::(2,_derived) = ::D}\
    {C::(2,o) = x y}\
    {C::(2,p) = 1 2}\
    {D::(2,q) = x y}\
    {D::(2,r) = 1 2}\
]

test stooop-38 {
    check multiple inheritance destruction order and data deallocation with a
    common indirect base class (see test 73 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class c {}
        proc c::c {this p q r} a {$p} b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $r
        }
        proc c::~c {this} {
            lappend ::result "c::~c $this"
        }
        class d {}
        proc d::d {this p q r} a {$p} b {$q} {
            lappend ::result "d::d $this"
            set ($this,p) $p
        }
        proc d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class e {}
        proc e::e {this p q r} c {$p $q $r} d {$q $q $r} {
            lappend ::result "e::e $this"
            set ($this,q) $q
        }
        proc e::~e {this} {
            lappend ::result "e::~e $this"
        }
        set o [new e {x y} z {1 2}]
        eval lappend ::result [dumpArrays a:: b:: c:: d:: e::]
        delete $o
        eval lappend ::result [dumpArrays a:: b:: c:: d:: e::]

        class A {
            proc A {this p} {
                lappend ::result "A::A $this"
                set ($this,m) $p
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p} {
                lappend ::result "B::B $this"
                set ($this,n) $p
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        class C {
            proc C {this p q r} A {$p} B {$q} {
                lappend ::result "C::C $this"
                set ($this,o) $r
            }
            proc ~C {this} {
                lappend ::result "C::~C $this"
            }
        }
        class D {
            proc D {this p q r} A {$p} B {$q} {
                lappend ::result "D::D $this"
                set ($this,p) $p
            }
            proc ~D {this} {
                lappend ::result "D::~D $this"
            }
        }
        class E {
            proc E {this p q r} C {$p $q $r} D {$q $q $r} {
                lappend ::result "E::E $this"
                set ($this,q) $q
            }
            proc ~E {this} {
                lappend ::result "E::~E $this"
            }
        }
        set o [new E {x y} z {1 2}]
        eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]
        delete $o
        eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::a 1}\
    {b::b 1}\
    {d::d 1}\
    {e::e 1}\
    {a::(1,_derived) = ::d}\
    {a::(1,m) = z}\
    {b::(1,_derived) = ::d}\
    {b::(1,n) = z}\
    {c::(1,_derived) = ::e}\
    {c::(1,o) = 1 2}\
    {d::(1,_derived) = ::e}\
    {d::(1,p) = z}\
    {e::(1,q) = z}\
    {e::~e 1}\
    {d::~d 1}\
    {b::~b 1}\
    {a::~a 1}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {A::A 2}\
    {B::B 2}\
    {C::C 2}\
    {A::A 2}\
    {B::B 2}\
    {D::D 2}\
    {E::E 2}\
    {A::(2,_derived) = ::D}\
    {A::(2,m) = z}\
    {B::(2,_derived) = ::D}\
    {B::(2,n) = z}\
    {C::(2,_derived) = ::E}\
    {C::(2,o) = 1 2}\
    {D::(2,_derived) = ::E}\
    {D::(2,p) = z}\
    {E::(2,q) = z}\
    {E::~E 2}\
    {D::~D 2}\
    {B::~B 2}\
    {A::~A 2}\
    {C::~C 2}\
    {B::~B 2}\
    {A::~A 2}\
]

test stooop-39 {
    check that optional arguments in constructors and multiple inheritance work
    together (see test 74 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this {p 0}} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this {p 1}} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class c {}
        proc c::c {this {p 2} {q 3}} a {$p} b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $p
            set ($this,p) $q
        }
        proc c::~c {this} {
            lappend ::result "c::~c $this"
        }
        set o [new c {x y} z]
        eval lappend ::result [dumpArrays a:: b:: c::]
        delete $o
        set o [new c]
        eval lappend ::result [dumpArrays a:: b:: c::]

        class A {
            proc A {this {p 0}} {
                lappend ::result "A::A $this"
                set ($this,m) $p
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this {p 1}} {
                lappend ::result "B::B $this"
                set ($this,n) $p
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        class C {
            proc C {this {p 2} {q 3}} A {$p} B {$q} {
                lappend ::result "C::C $this"
                set ($this,o) $p
                set ($this,p) $q
            }
            proc ~C {this} {
                lappend ::result "C::~C $this"
            }
        }
        set o [new C {x y} z]
        eval lappend ::result [dumpArrays A:: B:: C::]
        delete $o
        set o [new C]
        eval lappend ::result [dumpArrays A:: B:: C::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::(1,_derived) = ::c}\
    {a::(1,m) = x y}\
    {b::(1,_derived) = ::c}\
    {b::(1,n) = z}\
    {c::(1,o) = x y}\
    {c::(1,p) = z}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {a::a 2}\
    {b::b 2}\
    {c::c 2}\
    {a::(2,_derived) = ::c}\
    {a::(2,m) = 2}\
    {b::(2,_derived) = ::c}\
    {b::(2,n) = 3}\
    {c::(2,o) = 2}\
    {c::(2,p) = 3}\
    {A::A 3}\
    {B::B 3}\
    {C::C 3}\
    {A::(3,_derived) = ::C}\
    {A::(3,m) = x y}\
    {B::(3,_derived) = ::C}\
    {B::(3,n) = z}\
    {C::(3,o) = x y}\
    {C::(3,p) = z}\
    {C::~C 3}\
    {B::~B 3}\
    {A::~A 3}\
    {A::A 4}\
    {B::B 4}\
    {C::C 4}\
    {A::(4,_derived) = ::C}\
    {A::(4,m) = 2}\
    {B::(4,_derived) = ::C}\
    {B::(4,n) = 3}\
    {C::(4,o) = 2}\
    {C::(4,p) = 3}\
]

test stooop-40 {
    check various virtual procedures configurations in a 3 level deep class
    hierarchy (see test 75 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        virtual proc a::f {this p q} {}
        virtual proc a::g {this p q}
        virtual proc a::h {this p q} {
            lappend ::result "a::h $this $p $q"
        }
        virtual proc a::i {this p q} {
            lappend ::result "a::i $this $p $q"
        }
        virtual proc a::k {this p q}
        virtual proc a::l {this p q} {
            lappend ::result "a::l $this $p $q"
        }
        class b {}
        proc b::b {this} a {} {}
        proc b::~b {this} {}
        virtual proc b::f {this p q} {
            lappend ::result "b::f $this $p $q"
        }
        virtual proc b::g {this p q}
        virtual proc b::h {this p q} {
            lappend ::result "b::h $this $p $q"
        }
        proc b::i {this p q} {
            lappend ::result "b::i $this $p $q"
        }
        virtual proc b::k {this p q} {
            lappend ::result "b::k $this $p $q"
        }
        virtual proc b::l {this p q}
        class c {}
        proc c::c {this} b {} {}
        proc c::~c {this} {}
        proc c::f {this p q} {
            lappend ::result "c::f $this $p $q"
        }
        proc c::g {this p q} {
            lappend ::result "c::g $this $p $q"
        }
        proc c::i {this p q} {
            lappend ::result "c::i $this $p $q"
        }
        proc c::k {this p q} {
            lappend ::result "c::k $this $p $q"
        }
        proc c::l {this p q} {
            lappend ::result "c::l $this $p $q"
        }
        set o [new c]
        a::f $o x {y z}
        a::g $o x {y z}
        a::h $o x {y z}
        a::i $o x {y z}
        a::k $o x {y z}
        a::l $o x {y z}

        class A {
            proc A {this} {}
            proc ~A {this} {}
            virtual proc f {this p q} {}
            virtual proc g {this p q}
            virtual proc h {this p q} {
                lappend ::result "A::h $this $p $q"
            }
            virtual proc i {this p q} {
                lappend ::result "A::i $this $p $q"
            }
            virtual proc k {this p q}
            virtual proc l {this p q} {
                lappend ::result "A::l $this $p $q"
            }
        }
        class B {
            proc B {this} A {} {}
            proc ~B {this} {}
            virtual proc f {this p q} {
                lappend ::result "B::f $this $p $q"
            }
            virtual proc g {this p q}
            virtual proc h {this p q} {
                lappend ::result "B::h $this $p $q"
            }
            proc i {this p q} {
                lappend ::result "B::i $this $p $q"
            }
            virtual proc k {this p q} {
                lappend ::result "B::k $this $p $q"
            }
            virtual proc l {this p q}
        }
        class C {
            proc C {this} B {} {}
            proc ~C {this} {}
            proc f {this p q} {
                lappend ::result "C::f $this $p $q"
            }
            proc g {this p q} {
                lappend ::result "C::g $this $p $q"
            }
            proc i {this p q} {
                lappend ::result "C::i $this $p $q"
            }
            proc k {this p q} {
                lappend ::result "C::k $this $p $q"
            }
            proc l {this p q} {
                lappend ::result "C::l $this $p $q"
            }
        }
        set o [new C]
        A::f $o x {y z}
        A::g $o x {y z}
        A::h $o x {y z}
        A::i $o x {y z}
        A::k $o x {y z}
        A::l $o x {y z}

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {c::f 1 x y z}\
    {c::g 1 x y z}\
    {b::h 1 x y z}\
    {b::i 1 x y z}\
    {c::k 1 x y z}\
    {c::l 1 x y z}\
    {C::f 2 x y z}\
    {C::g 2 x y z}\
    {B::h 2 x y z}\
    {B::i 2 x y z}\
    {C::k 2 x y z}\
    {C::l 2 x y z}\
]

test stooop-41 {
    check various virtual procedures with variable number of arguments
    configurations in a 3 level deep class hierarchy
    (see 76.tcl for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        virtual proc a::f {this p args} {}
        virtual proc a::g {this p args}
        virtual proc a::h {this p args} {
            lappend ::result "a::h $this $p $args"
        }
        virtual proc a::i {this p args} {
            lappend ::result "a::i $this $p $args"
        }
        virtual proc a::k {this p args}
        virtual proc a::l {this p args} {
            lappend ::result "a::l $this $p $args"
        }
        class b {}
        proc b::b {this} a {} {}
        proc b::~b {this} {}
        virtual proc b::f {this p args} {
            lappend ::result "b::f $this $p $args"
        }
        virtual proc b::g {this p args}
        virtual proc b::h {this p args} {
            lappend ::result "b::h $this $p $args"
        }
        proc b::i {this p args} {
            lappend ::result "b::i $this $p $args"
        }
        virtual proc b::k {this p args} {
            lappend ::result "b::k $this $p $args"
        }
        virtual proc b::l {this p args}
        class c {}
        proc c::c {this} b {} {}
        proc c::~c {this} {}
        proc c::f {this p args} {
            lappend ::result "c::f $this $p $args"
        }
        proc c::g {this p args} {
            lappend ::result "c::g $this $p $args"
        }
        proc c::i {this p args} {
            lappend ::result "c::i $this $p $args"
        }
        proc c::k {this p args} {
            lappend ::result "c::k $this $p $args"
        }
        proc c::l {this p args} {
            lappend ::result "c::l $this $p $args"
        }
        set o [new c]
        a::f $o x {y z}
        a::g $o x {y z}
        a::h $o x {y z}
        a::i $o x {y z}
        a::k $o x {y z}
        a::l $o x {y z}

        class A {
            proc A {this} {}
            proc ~A {this} {}
            virtual proc f {this p args} {}
            virtual proc g {this p args}
            virtual proc h {this p args} {
                lappend ::result "A::h $this $p $args"
            }
            virtual proc i {this p args} {
                lappend ::result "A::i $this $p $args"
            }
            virtual proc k {this p args}
            virtual proc l {this p args} {
                lappend ::result "A::l $this $p $args"
            }
        }
        class B {
            proc B {this} A {} {}
            proc ~B {this} {}
            virtual proc f {this p args} {
                lappend ::result "B::f $this $p $args"
            }
            virtual proc g {this p args}
            virtual proc h {this p args} {
                lappend ::result "B::h $this $p $args"
            }
            proc i {this p args} {
                lappend ::result "B::i $this $p $args"
            }
            virtual proc k {this p args} {
                lappend ::result "B::k $this $p $args"
            }
            virtual proc l {this p args}
        }
        class C {
            proc C {this} B {} {}
            proc ~C {this} {}
            proc f {this p args} {
                lappend ::result "C::f $this $p $args"
            }
            proc g {this p args} {
                lappend ::result "C::g $this $p $args"
            }
            proc i {this p args} {
                lappend ::result "C::i $this $p $args"
            }
            proc k {this p args} {
                lappend ::result "C::k $this $p $args"
            }
            proc l {this p args} {
                lappend ::result "C::l $this $p $args"
            }
        }
        set o [new C]
        A::f $o x {y z}
        A::g $o x {y z}
        A::h $o x {y z}
        A::i $o x {y z}
        A::k $o x {y z}
        A::l $o x {y z}

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {c::f 1 x {y z}}\
    {c::g 1 x {y z}}\
    {b::h 1 x {y z}}\
    {b::i 1 x {y z}}\
    {c::k 1 x {y z}}\
    {c::l 1 x {y z}}\
    {C::f 2 x {y z}}\
    {C::g 2 x {y z}}\
    {B::h 2 x {y z}}\
    {B::i 2 x {y z}}\
    {C::k 2 x {y z}}\
    {C::l 2 x {y z}}\
]

test stooop-42 {
    check basic cloning operation (see nested class version in test 70)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            set ($this,x) 0
        }
        new [new a]
        eval lappend ::result [dumpArrays a::]

        class A {
            proc A {this} {
                set ($this,x) 0
            }
        }
        new [new A]
        eval lappend ::result [dumpArrays A::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,x) = 0}\
    {a::(2,x) = 0}\
    {A::(3,x) = 0}\
    {A::(4,x) = 0}\
]

test stooop-43 {
    check user defined cloning operation (see nested class version in test 69)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            set ($this,x) 0
        }
        proc a::a {this copy} {
            set ($this,x) [expr $($copy,x)+1]
        }
        new [new a]
        eval lappend ::result [dumpArrays a::]

        class A {
            proc A {this} {
                set ($this,x) 0
            }
            proc A {this copy} {
                set ($this,x) [expr $($copy,x)+1]
            }
        }
        new [new A]
        eval lappend ::result [dumpArrays A::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,x) = 0}\
    {a::(2,x) = 1}\
    {A::(3,x) = 0}\
    {A::(4,x) = 1}\
]

test stooop-44 {
    check cloning operation in a 3 level deep class hierarchy
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            set ($this,x) 0
        }
        class b {}
        proc b::b {this} a {} {
            set ($this,y) 1
        }
        class c {}
        proc c::c {this} b {} {
            set ($this,z) 2
        }
        new [new c]
        eval lappend ::result [dumpArrays a:: b:: c::]

        class A {
            proc A {this} {
                set ($this,x) 0
            }
        }
        class B {
            proc B {this} A {} {
                set ($this,y) 1
            }
        }
        class C {
            proc C {this} B {} {
                set ($this,z) 2
            }
        }
        new [new C]
        eval lappend ::result [dumpArrays A:: B:: C::]

        class d {}
        class d::e {}
        proc d::e::e {this} {
            set ($this,x) 0
        }
        class d::f {}
        proc d::f::f {this} d::e {} {
            set ($this,y) 1
        }
        class d::g {}
        proc d::g::g {this} d::f {} {
            set ($this,z) 2
        }
        new [new d::g]
        eval lappend ::result [dumpArrays d::e:: d::f:: d::g::]

        class D {
            class E {
                proc E {this} {
                    set ($this,x) 0
                }
            }
            class F {
                proc F {this} D::E {} {
                    set ($this,y) 1
                }
            }
            class G {
                proc G {this} D::F {} {
                    set ($this,z) 2
                }
            }
            new [new G]
            eval lappend ::result [dumpArrays E:: F:: G::]
        }
        new [new D::G]
        eval lappend ::result [dumpArrays D::E:: D::F:: D::G::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,_derived) = ::b}\
    {a::(1,x) = 0}\
    {a::(2,_derived) = ::b}\
    {a::(2,x) = 0}\
    {b::(1,_derived) = ::c}\
    {b::(1,y) = 1}\
    {b::(2,_derived) = ::c}\
    {b::(2,y) = 1}\
    {c::(1,z) = 2}\
    {c::(2,z) = 2}\
    {A::(3,_derived) = ::B}\
    {A::(3,x) = 0}\
    {A::(4,_derived) = ::B}\
    {A::(4,x) = 0}\
    {B::(3,_derived) = ::C}\
    {B::(3,y) = 1}\
    {B::(4,_derived) = ::C}\
    {B::(4,y) = 1}\
    {C::(3,z) = 2}\
    {C::(4,z) = 2}\
    {d::e::(5,_derived) = ::d::f}\
    {d::e::(5,x) = 0}\
    {d::e::(6,_derived) = ::d::f}\
    {d::e::(6,x) = 0}\
    {d::f::(5,_derived) = ::d::g}\
    {d::f::(5,y) = 1}\
    {d::f::(6,_derived) = ::d::g}\
    {d::f::(6,y) = 1}\
    {d::g::(5,z) = 2}\
    {d::g::(6,z) = 2}\
    {E::(7,_derived) = ::D::F}\
    {E::(7,x) = 0}\
    {E::(8,_derived) = ::D::F}\
    {E::(8,x) = 0}\
    {F::(7,_derived) = ::D::G}\
    {F::(7,y) = 1}\
    {F::(8,_derived) = ::D::G}\
    {F::(8,y) = 1}\
    {G::(7,z) = 2}\
    {G::(8,z) = 2}\
    {D::E::(10,_derived) = ::D::F}\
    {D::E::(10,x) = 0}\
    {D::E::(7,_derived) = ::D::F}\
    {D::E::(7,x) = 0}\
    {D::E::(8,_derived) = ::D::F}\
    {D::E::(8,x) = 0}\
    {D::E::(9,_derived) = ::D::F}\
    {D::E::(9,x) = 0}\
    {D::F::(10,_derived) = ::D::G}\
    {D::F::(10,y) = 1}\
    {D::F::(7,_derived) = ::D::G}\
    {D::F::(7,y) = 1}\
    {D::F::(8,_derived) = ::D::G}\
    {D::F::(8,y) = 1}\
    {D::F::(9,_derived) = ::D::G}\
    {D::F::(9,y) = 1}\
    {D::G::(10,z) = 2}\
    {D::G::(7,z) = 2}\
    {D::G::(8,z) = 2}\
    {D::G::(9,z) = 2}\
]

test stooop-45 {
    check user defined cloning operation error checking
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {
                set ($this,x) 0
            }
            proc a::a {destination source} {}
            new [new a]
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {
                    set ($this,x) 0
                }
                proc A {destination source} {}
            }
            new [new A]
        } message
        lappend ::result $message

        catch {
            class b {}
            class b::c {}
            proc b::c::c {this} {
                set ($this,x) 0
            }
            proc b::c::c {destination source} {}
            new [new b::c]
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C {this} {
                        set ($this,x) 0
                    }
                    proc C {destination source} {}
                }
                new [new C]
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a constructor first argument must be this}\
    {class ::A constructor first argument must be this}\
    {class ::b::c constructor first argument must be this}\
    {class ::B::C constructor first argument must be this}\
]

test stooop-46 {
    check user defined cloning operation error checking
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {
                set ($this,x) 0
            }
            proc a::a {this copy dummy} {}
            new [new a]
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {
                    set ($this,x) 0
                }
                proc A {this copy dummy} {}
            }
            new [new A]
        } message
        lappend ::result $message

        catch {
            class b {}
            class b::c {}
            proc b::c::c {this} {
                set ($this,x) 0
            }
            proc b::c::c {this copy dummy} {}
            new [new b::c]
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C {this} {
                        set ($this,x) 0
                    }
                    proc C {this copy dummy} {}
                }
                new [new C]
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a copy constructor must have 2 arguments exactly}\
    {class ::A copy constructor must have 2 arguments exactly}\
    {class ::b::c copy constructor must have 2 arguments exactly}\
    {class ::B::C copy constructor must have 2 arguments exactly}\
]

test stooop-47 {
    check normal and user defined cloning operation with multiple inheritance
    and member objects (see test 77 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            set ($this,m) $p
        }
        class b {}
        proc b::b {this p} {
            set ($this,n) $p
        }
        class c {}
        proc c::c {this p q r} a {$p} b {$q} {
            set ($this,o) $r
            set ($this,O) [new f]
        }
        proc c::c {this copy} a {$a::($copy,m)} b 1 {
            set ($this,o) $($copy,o)
            set ($this,O) [new f]
        }
        class d {}
        proc d::d {this p q r} a {$p} b {$q} {
            set ($this,p) $p
        }
        class e {}
        proc e::e {this p q r} c {$p $q $r} d {$q $q $r} {
            set ($this,q) $q
        }
        class f {}
        proc f::f {this} {
            set ($this,x) 0
        }
        new [new e {x y} z {1 2}]
        eval lappend ::result [dumpArrays a:: b:: c:: d:: e:: f::]

        class A {
            proc A {this p} {
                set ($this,m) $p
            }
        }
        class B {
            proc B {this p} {
                set ($this,n) $p
            }
        }
        class C {
            proc C {this p q r} A {$p} B {$q} {
                set ($this,o) $r
                set ($this,O) [new F]
            }
            proc C {this copy} A {$A::($copy,m)} B 1 {
                set ($this,o) $($copy,o)
                set ($this,O) [new F]
            }
        }
        class D {
            proc D {this p q r} A {$p} B {$q} {
                set ($this,p) $p
            }
        }
        class E {
            proc E {this p q r} C {$p $q $r} D {$q $q $r} {
                set ($this,q) $q
            }
        }
        class F {
            proc F {this} {
                set ($this,x) 0
            }
        }
        new [new E {x y} z {1 2}]
        eval lappend ::result [dumpArrays A:: B:: C:: D:: E:: F::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,_derived) = ::d}\
    {a::(1,m) = z}\
    {a::(3,_derived) = ::d}\
    {a::(3,m) = z}\
    {b::(1,_derived) = ::d}\
    {b::(1,n) = z}\
    {b::(3,_derived) = ::d}\
    {b::(3,n) = z}\
    {c::(1,O) = 2}\
    {c::(1,_derived) = ::e}\
    {c::(1,o) = 1 2}\
    {c::(3,O) = 4}\
    {c::(3,_derived) = ::e}\
    {c::(3,o) = 1 2}\
    {d::(1,_derived) = ::e}\
    {d::(1,p) = z}\
    {d::(3,_derived) = ::e}\
    {d::(3,p) = z}\
    {e::(1,q) = z}\
    {e::(3,q) = z}\
    {f::(2,x) = 0}\
    {f::(4,x) = 0}\
    {A::(5,_derived) = ::D}\
    {A::(5,m) = z}\
    {A::(7,_derived) = ::D}\
    {A::(7,m) = z}\
    {B::(5,_derived) = ::D}\
    {B::(5,n) = z}\
    {B::(7,_derived) = ::D}\
    {B::(7,n) = z}\
    {C::(5,O) = 6}\
    {C::(5,_derived) = ::E}\
    {C::(5,o) = 1 2}\
    {C::(7,O) = 8}\
    {C::(7,_derived) = ::E}\
    {C::(7,o) = 1 2}\
    {D::(5,_derived) = ::E}\
    {D::(5,p) = z}\
    {D::(7,_derived) = ::E}\
    {D::(7,p) = z}\
    {E::(5,q) = z}\
    {E::(7,q) = z}\
    {F::(6,x) = 0}\
    {F::(8,x) = 0}\
]

test stooop-48 {
    check basic cloning operation with array members
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            variable ${this}x
            set ${this}x(0) 0
            set ($this,y) 1
        }
        proc a::a {this copy} {
            variable ${this}x
            variable ${copy}x
            array set ${this}x [array get ${copy}x]
            set ($this,y) $($copy,y)
        }
        new [new a]
        eval lappend ::result [dumpArrays a:: a::1x a::2x]

        class A {
            proc A {this} {
                variable ${this}x
                set ${this}x(0) 0
                set ($this,y) 1
            }
            proc A {this copy} {
                variable ${this}x
                variable ${copy}x
                array set ${this}x [array get ${copy}x]
                set ($this,y) $($copy,y)
            }
        }
        new [new A]
        eval lappend ::result [dumpArrays A:: A::3x A::4x]

        class b {}
        class b::c {}
        proc b::c::c {this} {
            variable ${this}x
            set ${this}x(0) 0
            set ($this,y) 1
        }
        proc b::c::c {this copy} {
            variable ${this}x
            variable ${copy}x
            array set ${this}x [array get ${copy}x]
            set ($this,y) $($copy,y)
        }
        new [new b::c]
        eval lappend ::result [dumpArrays b::c:: b::c::5x b::c::6x]

        class B {
            class C {
                proc C {this} {
                    variable ${this}x
                    set ${this}x(0) 0
                    set ($this,y) 1
                }
                proc C {this copy} {
                    variable ${this}x
                    variable ${copy}x
                    array set ${this}x [array get ${copy}x]
                    set ($this,y) $($copy,y)
                }
            }
            new [new C]
            eval lappend ::result [dumpArrays C:: C::7x C::8x]
        }
        new [new B::C]
        eval lappend ::result [dumpArrays B::C:: B::C::9x B::C::10x]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,y) = 1}\
    {a::(2,y) = 1}\
    {a::1x(0) = 0}\
    {a::2x(0) = 0}\
    {A::(3,y) = 1}\
    {A::(4,y) = 1}\
    {A::3x(0) = 0}\
    {A::4x(0) = 0}\
    {b::c::(5,y) = 1}\
    {b::c::(6,y) = 1}\
    {b::c::5x(0) = 0}\
    {b::c::6x(0) = 0}\
    {C::(7,y) = 1}\
    {C::(8,y) = 1}\
    {C::7x(0) = 0}\
    {C::8x(0) = 0}\
    {B::C::(10,y) = 1}\
    {B::C::(7,y) = 1}\
    {B::C::(8,y) = 1}\
    {B::C::(9,y) = 1}\
    {B::C::9x(0) = 0}\
    {B::C::10x(0) = 0}\
]

test stooop-49 {
    check user defined cloning operation error checking
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this copy} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this copy} {}
            }
        } message
        lappend ::result $message

        catch {
            class b {}
            class b::c {}
            proc b::c::c {this copy} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C {this copy} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a copy constructor defined before constructor}\
    {class ::A copy constructor defined before constructor}\
    {class ::b::c copy constructor defined before constructor}\
    {class ::B::C copy constructor defined before constructor}\
]

test stooop-50 {
    check copy constructor base class(es) initialization errors
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this p} {}
            class b {}
            proc b::b {this} a 0 {}
            proc b::b {this copy} {}
            new [new b]
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this p} {}
            }
            class B {
                proc B {this} A 0 {}
                proc B {this copy} {}
            }
            new [new B]
        } message
        lappend ::result $message

        catch {
            class c {}
            class c::d {}
            proc c::d::d {this p} {}
            class c::e {}
            proc c::e::e {this} c::d 0 {}
            proc c::e::e {this copy} {}
            new [new c::e]
        } message
        lappend ::result $message

        catch {
            class C {
                class D {
                    proc D {this p} {}
                }
                class E {
                    proc E {this} C::D 0 {}
                    proc E {this copy} {}
                }
                new [new E]
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {missing base class ::a constructor arguments from class ::b constructor}\
    {missing base class ::A constructor arguments from class ::B constructor}\
    {missing base class ::c::d constructor arguments from class ::c::e constructor}\
    {missing base class ::C::D constructor arguments from class ::C::E constructor}\
]

test stooop-51 {
    check that multiple declarations that can occur when a class declaration
    file is sourced multiple times have no adverse effects
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        class b {}
        proc b::b {this} a {} {}
        proc b::b {this} a {} {}

        class A {
            proc A {this} {}
        }
        class B {
            proc B {this} A {} {}
        }
        class B {
            proc B {this} A {} {}
        }

        class c {}
        class c::d {}
        proc c::d::d {this} {}
        class c::e {}
        proc c::e::e {this} c::d {} {}
        proc c::e::e {this} c::d {} {}

        class C {
            class D {
                proc D {this} {}
            }
            class E {
                proc E {this} C::D {} {}
            }
            class E {
                proc E {this} C::D {} {}
            }
        }

        set ::result {}
    }]
    interp delete $interpreter
    set result
} {}

test stooop-52 {
    check that member procedure cannot be defined before constructor
    declaration for we need ancestors for global ancestors array declaration
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::p {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc p {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b {}
            class b::c {}
            proc b::c::p {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc p {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a member procedure p defined before constructor}\
    {class ::A member procedure p defined before constructor}\
    {class ::b::c member procedure p defined before constructor}\
    {class ::B::C member procedure p defined before constructor}\
]

test stooop-53 {
    check that embedded command in base class constructor arguments does not
    interfere with variable number of arguments processing special case
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this p args} {}
        proc a::~a {this} {}
        class b {}
        proc b::b {this args} a {[list {}] $args} {}
        proc b::b {this args} a {[list {}] $args } {}
        proc b::b {this args} a {
            [list {}] $args
        } {}

        class A {
            proc A {this p args} {}
            proc ~A {this} {}
        }
        class B {
            proc B {this args} A {[list {}] $args} {}
            proc B {this args} A {[list {}] $args } {}
            proc B {this args} A {
                [list {}] $args
            } {}
        }

        class c {}
        class c::d {}
        proc c::d::d {this p args} {}
        proc c::d::~d {this} {}
        class c::e {}
        proc c::e::e {this args} c::d {[list {}] $args} {}
        proc c::e::e {this args} c::d {[list {}] $args } {}
        proc c::e::e {this args} c::d {
            [list {}] $args
        } {}

        class C {
            class D {
                proc D {this p args} {}
                proc ~D {this} {}
            }
            class E {
                proc E {this args} C::D {[list {}] $args} {}
                proc E {this args} C::D {[list {}] $args } {}
                proc E {this args} C::D {
                    [list {}] $args
                } {}
            }
        }

        set ::result {}
    }]
    interp delete $interpreter
    set result
} {}

test stooop-54 {
    check that virtual procedure invocations from base class constructor behave
    as in C++ (see test 78 for nested class version)
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            a::f $this x
            a::g $this x {y z}
            # pure virtual invocations behavior is undefined
            lappend ::result [catch {a::h $this x}]
            lappend ::result [catch {a::i $this x {y z}}]
        }
        proc a::~a {this} {}
        virtual proc a::f {this p} {
            lappend ::result "a::f $this $p"
        }
        virtual proc a::g {this p args} {
            lappend ::result "a::g $this $p $args"
        }
        virtual proc a::h {this p}
        virtual proc a::i {this p args}
        class b {}
        proc b::b {this} a {} {}
        proc b::~b {this} {}
        virtual proc b::f {this p} {
            lappend ::result "b::f $this $p"
        }
        virtual proc b::g {this p args} {
            lappend ::result "b::g $this $p $args"
        }
        virtual proc b::h {this p} {
            lappend ::result "b::h $this $p"
        }
        proc b::i {this p args} {
            lappend ::result "b::i $this $p $args"
        }
        new b

        class A {
            proc A {this} {
                A::f $this x
                A::g $this x {y z}
                # pure virtual invocations behavior is undefined
                lappend ::result [catch {A::h $this x}]
                lappend ::result [catch {A::i $this x {y z}}]
            }
            proc ~A {this} {}
            virtual proc f {this p} {
                lappend ::result "A::f $this $p"
            }
            virtual proc g {this p args} {
                lappend ::result "A::g $this $p $args"
            }
            virtual proc h {this p}
            virtual proc i {this p args}
        }
        class B {
            proc B {this} A {} {}
            proc ~B {this} {}
            virtual proc f {this p} {
                lappend ::result "B::f $this $p"
            }
            virtual proc g {this p args} {
                lappend ::result "B::g $this $p $args"
            }
            virtual proc h {this p} {
                lappend ::result "B::h $this $p"
            }
            proc i {this p args} {
                lappend ::result "B::i $this $p $args"
            }
        }
        new B

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::f 1 x}\
    {a::g 1 x {y z}}\
    {1}\
    {1}\
    {A::f 2 x}\
    {A::g 2 x {y z}}\
    {1}\
    {1}\
]

test stooop-55 {
    check that procedure invocation on variable arguments in derived class base
    class constructor arguments works
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p args} {
            lappend ::result "a::a $this $p $args"
            set ($this,m) [lindex $args 0]
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this p args} a {$p [concat $args]} {
            lappend ::result "b::b $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        new b {x y} {1 2} 3
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this p args} {
                lappend ::result "A::A $this $p $args"
                set ($this,m) [lindex $args 0]
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this p args} A {$p [concat $args]} {
                lappend ::result "B::B $this $p $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        new B {x y} {1 2} 3
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this p args} {
            lappend ::result "d::d $this $p $args"
            set ($this,m) [lindex $args 0]
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this p args} c::d {$p [concat $args]} {
            lappend ::result "e::e $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        new c::e {x y} {1 2} 3
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this p args} {
                    lappend ::result "D::D $this $p $args"
                    set ($this,m) [lindex $args 0]
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p args} C::D {$p [concat $args]} {
                    lappend ::result "E::E $this $p $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            new E {x y} {1 2} 3
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E {x y} {1 2} 3
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 x y {1 2} 3}\
    {b::b 1 x y {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1 2}\
    {b::(1,n) = 1 2}\
    {A::A 2 x y {1 2} 3}\
    {B::B 2 x y {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1 2}\
    {B::(2,n) = 1 2}\
    {d::d 3 x y {1 2} 3}\
    {e::e 3 x y {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1 2}\
    {c::e::(3,n) = 1 2}\
    {D::D 4 x y {1 2} 3}\
    {E::E 4 x y {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1 2}\
    {E::(4,n) = 1 2}\
    {D::D 5 x y {1 2} 3}\
    {E::E 5 x y {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1 2}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1 2}\
    {C::E::(4,n) = 1 2}\
    {C::E::(5,n) = 1 2}\
]

test stooop-56 {
    check that procedure invocation on variable arguments in derived class base
    class constructor arguments works
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this args} {
            lappend ::result "a::a $this $args"
            set ($this,m) [lindex $args 0]
        }
        proc a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class b {}
        proc b::b {this args} a {[concat $args]} {
            lappend ::result "b::b $this $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {
            lappend ::result "b::~b $this"
        }
        new b {1 2} 3
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this args} {
                lappend ::result "A::A $this $args"
                set ($this,m) [lindex $args 0]
            }
            proc ~A {this} {
                lappend ::result "A::~A $this"
            }
        }
        class B {
            proc B {this args} A {[concat $args]} {
                lappend ::result "B::B $this $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {
                lappend ::result "B::~B $this"
            }
        }
        new B {1 2} 3
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this args} {
            lappend ::result "d::d $this $args"
            set ($this,m) [lindex $args 0]
        }
        proc c::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class c::e {}
        proc c::e::e {this args} c::d {[concat $args]} {
            lappend ::result "e::e $this $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        new c::e {1 2} 3
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this args} {
                    lappend ::result "D::D $this $args"
                    set ($this,m) [lindex $args 0]
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this args} C::D {[concat $args]} {
                    lappend ::result "E::E $this $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            new E {1 2} 3
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E {1 2} 3
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 {1 2} 3}\
    {b::b 1 {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1 2}\
    {b::(1,n) = 1 2}\
    {A::A 2 {1 2} 3}\
    {B::B 2 {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1 2}\
    {B::(2,n) = 1 2}\
    {d::d 3 {1 2} 3}\
    {e::e 3 {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1 2}\
    {c::e::(3,n) = 1 2}\
    {D::D 4 {1 2} 3}\
    {E::E 4 {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1 2}\
    {E::(4,n) = 1 2}\
    {D::D 5 {1 2} 3}\
    {E::E 5 {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1 2}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1 2}\
    {C::E::(4,n) = 1 2}\
    {C::E::(5,n) = 1 2}\
]

test stooop-57 {
    check that variable arguments in derived class work with base class
    constructor constant arguments
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            lappend ::result "a::a $this $p"
            set ($this,m) $p
        }
        proc a::~a {this} {}
        class b {}
        proc b::b {this p args} a {$args} {
            lappend ::result "b::b $this $p $args"
        }
        proc b::~b {this} {}
        new b {x y} {1 2} 3
        eval lappend ::result [dumpArrays a::]

        class A {
            proc A {this p} {
                lappend ::result "A::A $this $p"
                set ($this,m) $p
            }
            proc ~A {this} {}
        }
        class B {
            proc B {this p args} A {$args} {
                lappend ::result "B::B $this $p $args"
            }
            proc ~B {this} {}
        }
        new B {x y} {1 2} 3
        eval lappend ::result [dumpArrays A::]

        class c {}
        class c::d {}
        proc c::d::d {this p} {
            lappend ::result "d::d $this $p"
            set ($this,m) $p
        }
        proc c::d::~d {this} {}
        class c::e {}
        proc c::e::e {this p args} c::d {$args} {
            lappend ::result "e::e $this $p $args"
        }
        proc c::e::~e {this} {}
        new c::e {x y} {1 2} 3
        eval lappend ::result [dumpArrays c::d::]

        class C {
            class D {
                proc D {this p} {
                    lappend ::result "D::D $this $p"
                    set ($this,m) $p
                }
                proc ~D {this} {}
            }
            class E {
                proc E {this p args} C::D {$args} {
                    lappend ::result "E::E $this $p $args"
                }
                proc ~E {this} {}
            }
            new E {x y} {1 2} 3
            eval lappend ::result [dumpArrays D::]
        }
        new C::E {x y} {1 2} 3
        eval lappend ::result [dumpArrays C::D::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 {1 2} 3}\
    {b::b 1 x y {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = {1 2} 3}\
    {A::A 2 {1 2} 3}\
    {B::B 2 x y {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = {1 2} 3}\
    {d::d 3 {1 2} 3}\
    {e::e 3 x y {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = {1 2} 3}\
    {D::D 4 {1 2} 3}\
    {E::E 4 x y {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = {1 2} 3}\
    {D::D 5 {1 2} 3}\
    {E::E 5 x y {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = {1 2} 3}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = {1 2} 3}\
]

test stooop-58 {
    check that variable arguments in derived class work with base class
    constructor constant arguments
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p args} {
            lappend ::result "a::a $this $p $args"
            set ($this,m) [lindex $args 0]
        }
        proc a::~a {this} {}
        class b {}
        proc b::b {this p args} a {$p z} {
            lappend ::result "b::b $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc b::~b {this} {}
        new b {x y} {1 2} 3
        eval lappend ::result [dumpArrays a::]

        class A {
            proc A {this p args} {
                lappend ::result "A::A $this $p $args"
                set ($this,m) [lindex $args 0]
            }
            proc ~A {this} {}
        }
        class B {
            proc B {this p args} A {$p z} {
                lappend ::result "B::B $this $p $args"
                set ($this,n) [lindex $args 0]
            }
            proc ~B {this} {}
        }
        new B {x y} {1 2} 3
        eval lappend ::result [dumpArrays A::]

        class c {}
        class c::d {}
        proc c::d::d {this p args} {
            lappend ::result "d::d $this $p $args"
            set ($this,m) [lindex $args 0]
        }
        proc c::d::~d {this} {}
        class c::e {}
        proc c::e::e {this p args} c::d {$p z} {
            lappend ::result "e::e $this $p $args"
            set ($this,n) [lindex $args 0]
        }
        proc c::e::~e {this} {}
        new c::e {x y} {1 2} 3
        eval lappend ::result [dumpArrays c::d::]

        class C {
            class D {
                proc D {this p args} {
                    lappend ::result "D::D $this $p $args"
                    set ($this,m) [lindex $args 0]
                }
                proc ~D {this} {}
            }
            class E {
                proc E {this p args} C::D {$p z} {
                    lappend ::result "E::E $this $p $args"
                    set ($this,n) [lindex $args 0]
                }
                proc ~E {this} {}
            }
            new E {x y} {1 2} 3
            eval lappend ::result [dumpArrays D::]
        }
        new C::E {x y} {1 2} 3
        eval lappend ::result [dumpArrays C::D::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 x y z}\
    {b::b 1 x y {1 2} 3}\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = z}\
    {A::A 2 x y z}\
    {B::B 2 x y {1 2} 3}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = z}\
    {d::d 3 x y z}\
    {e::e 3 x y {1 2} 3}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = z}\
    {D::D 4 x y z}\
    {E::E 4 x y {1 2} 3}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = z}\
    {D::D 5 x y z}\
    {E::E 5 x y {1 2} 3}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = z}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = z}\
]

test stooop-59 {
    check that construction, copy and deletion work transparently for variable
    context
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p} {
            upvar $p q
            eval lappend ::result [dumpArrays q]
        }
        proc a::a {this copy} {
            upvar d q
            eval lappend ::result [dumpArrays q]
        }
        proc a::~a {this} {
            upvar d q
            eval lappend ::result [dumpArrays q]
        }
        set d(0) 0
        set o [new a d]
        new $o
        delete $o

        class A {
            proc A {this p} {
                upvar $p q
                eval lappend ::result [dumpArrays q]
            }
            proc A {this copy} {
                upvar d q
                eval lappend ::result [dumpArrays q]
            }
            proc ~A {this} {
                upvar d q
                eval lappend ::result [dumpArrays q]
            }
        }
        set d(0) 1
        set o [new A d]
        new $o
        delete $o

        class b {}
        class b::c {}
        proc b::c::c {this p} {
            upvar $p q
            eval lappend ::result [dumpArrays q]
        }
        proc b::c::c {this copy} {
            upvar d q
            eval lappend ::result [dumpArrays q]
        }
        proc b::c::~c {this} {
            upvar d q
            eval lappend ::result [dumpArrays q]
        }
        set d(0) 2
        set o [new b::c d]
        new $o
        delete $o

        class B {
            class C {
                proc C {this p} {
                    upvar $p q
                    eval lappend ::result [dumpArrays q]
                }
                proc C {this copy} {
                    upvar d q
                    eval lappend ::result [dumpArrays q]
                }
                proc ~C {this} {
                    upvar d q
                    eval lappend ::result [dumpArrays q]
                }
            }
            set d(0) 3
            set o [new C d]
            new $o
            delete $o
        }
        set d(0) 4
        set o [new B::C d]
        new $o
        delete $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {q(0) = 0}\
    {q(0) = 0}\
    {q(0) = 0}\
    {q(0) = 1}\
    {q(0) = 1}\
    {q(0) = 1}\
    {q(0) = 2}\
    {q(0) = 2}\
    {q(0) = 2}\
    {q(0) = 3}\
    {q(0) = 3}\
    {q(0) = 3}\
    {q(0) = 4}\
    {q(0) = 4}\
    {q(0) = 4}\
]

test stooop-60 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a::p {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A::p {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b {}
            class b::c {}
            proc b::c::c::p {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C::p {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {can't create procedure "a::a::p": unknown namespace}\
    {can't create procedure "A::p": unknown namespace}\
    {can't create procedure "b::c::c::p": unknown namespace}\
    {can't create procedure "C::p": unknown namespace}\
]

test stooop-61 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {new 1} ::result
        set ::result
    }]
    interp delete $interpreter
    set result
} {invalid object identifier 1}

test stooop-62 {
    check that multiple class definitions for the same class are possible
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {
            proc a {this} {}
            proc ~a {this} {}
        }
        proc a::p {this p} {
            set ($this,m) $p
        }
        class a {
            proc q {this} {
                lappend ::result $($this,m)
            }
        }
        set o [new a]
        a::p $o 0
        a::q $o

        class b {
            class c {
                proc c {this} {}
                proc ~c {this} {}
            }
            proc c::p {this p} {
                set ($this,m) $p
            }
            class c {
                proc q {this} {
                    lappend ::result $($this,m)
                }
            }
            set o [new c]
            c::p $o 0
            c::q $o
        }
        set o [new b::c]
        b::c::p $o 0
        b::c::q $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    0\
    0\
    0\
]

test stooop-63 {
    check that non qualified procedure invocation in derived class base class
    constructor arguments works
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        proc p {p} {error "::p invoked"}

        class a {}
        proc a::a {this p} {
            set ($this,m) $p
        }
        proc a::~a {this} {}
        class b {}
        proc b::b {this p} a {[p $p]} {
            set ($this,n) $p
        }
        proc b::~b {this} {}
        proc b::p {p} {
            return [incr p]
        }
        new b 0
        eval lappend ::result [dumpArrays a:: b::]

        class A {
            proc A {this p} {
                set ($this,m) $p
            }
            proc ~A {this} {}
        }
        class B {
            proc B {this p} A {[p $p]} {
                set ($this,n) $p
            }
            proc ~B {this} {}
            proc p {p} {
                return [incr p]
            }
        }
        new B 0
        eval lappend ::result [dumpArrays A:: B::]

        class c {}
        class c::d {}
        proc c::d::d {this p} {
            set ($this,m) $p
        }
        proc c::d::~d {this} {}
        class c::e {}
        proc c::e::e {this p} c::d {[p $p]} {
            set ($this,n) $p
        }
        proc c::e::~e {this} {}
        proc c::e::p {p} {
            return [incr p]
        }
        new c::e 0
        eval lappend ::result [dumpArrays c::d:: c::e::]

        class C {
            class D {
                proc D {this p} {
                    set ($this,m) $p
                }
                proc ~D {this} {}
            }
            class E {
                proc E {this p} C::D {[p $p]} {
                    set ($this,n) $p
                }
                proc ~E {this} {}
                proc p {p} {
                    return [incr p]
                }
            }
            new E 0
            eval lappend ::result [dumpArrays D:: E::]
        }
        new C::E 0
        eval lappend ::result [dumpArrays C::D:: C::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = 1}\
    {b::(1,n) = 0}\
    {A::(2,_derived) = ::B}\
    {A::(2,m) = 1}\
    {B::(2,n) = 0}\
    {c::d::(3,_derived) = ::c::e}\
    {c::d::(3,m) = 1}\
    {c::e::(3,n) = 0}\
    {D::(4,_derived) = ::C::E}\
    {D::(4,m) = 1}\
    {E::(4,n) = 0}\
    {C::D::(4,_derived) = ::C::E}\
    {C::D::(4,m) = 1}\
    {C::D::(5,_derived) = ::C::E}\
    {C::D::(5,m) = 1}\
    {C::E::(4,n) = 0}\
    {C::E::(5,n) = 0}\
]

test stooop-64 {
    check static member initialization within class body
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {
            set (l) {}
        }
        proc a::a {this} {
            lappend (l) $this
        }
        proc a::~a {this} {}
        new a
        new a
        eval lappend ::result [dumpArrays a::]

        class A {
            set A::(l) {}
            proc A {this} {
                lappend (l) $this
            }
            proc ~A {this} {}
        }
        new A
        new A
        eval lappend ::result [dumpArrays A::]

        class b {}
        class b::c {
            set (l) {}
        }
        proc b::c::c {this} {
            lappend (l) $this
        }
        proc b::c::~c {this} {}
        new b::c
        new b::c
        eval lappend ::result [dumpArrays b::c::]

        class B {
            class C {
                set (l) {}
                proc C {this} {
                    lappend (l) $this
                }
                proc ~C {this} {}
            }
            new C
            new C
            eval lappend ::result [dumpArrays C::]
        }
        new B::C
        new B::C
        eval lappend ::result [dumpArrays B::C::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(l) = 1 2}\
    {A::(l) = 3 4}\
    {b::c::(l) = 5 6}\
    {C::(l) = 7 8}\
    {B::C::(l) = 7 8 9 10}\
]

test stooop-65 {
    undocumented
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        catch {
            class a {}
            proc a::a {this} {}
            virtual proc a::a::p {this} {}
        } message
        lappend ::result $message

        catch {
            class A {
                proc A {this} {}
                virtual proc A::p {this} {}
            }
        } message
        lappend ::result $message

        catch {
            class b {}
            class b::c {}
            proc b::c::c {this} {}
            virtual proc b::c::c::p {this} {}
        } message
        lappend ::result $message

        catch {
            class B {
                class C {
                    proc C {this} {}
                    virtual proc C::p {this} {}
                }
            }
        } message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {procedure ::a::a::p class ::a::a is unknown}\
    {procedure ::A::A::p class ::A::A is unknown}\
    {procedure ::b::c::c::p class ::b::c::c is unknown}\
    {procedure ::B::C::C::p class ::B::C::C is unknown}\
]

test stooop-66 {
    check that nested class procedure definition works inside and outside
    nested class or namespace
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {
            class b {
                proc b {this} {}
                proc p {this} {
                    lappend ::result 1
                }
            }
            set o [new b]
            b::p $o
            proc b::p {this} {
                lappend ::result 2
            }
            b::p $o
        }

        namespace eval c {
            class b {
                proc b {this} {}
                proc p {this} {
                    lappend ::result 3
                }
            }
            set o [new b]
            b::p $o
            proc b::p {this} {
                lappend ::result 4
            }
            b::p $o
        }

        set o [new a::b]
        proc a::b::p {this} {
            lappend ::result 5
        }
        a::b::p $o

        set o [new c::b]
        proc c::b::p {this} {
            lappend ::result 6
        }
        c::b::p $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    1\
    2\
    3\
    4\
    5\
    6\
]

test stooop-67 {
    check that nested class procedure definition works inside a separate
    namespace and is free from interferences
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {
            proc a {this} {}
            proc p {this} {
                lappend ::result 1
            }
        }
        set o [new a]
        a::p $o

        namespace eval b {
            namespace eval a {}
            proc a::p {this} {
                lappend ::result 2
            }
        }
        a::p $o

        namespace eval c {
            proc ::a::p {this} {
                lappend ::result 3
            }
        }
        a::p $o

        namespace eval d {
            class a {
                proc a {this} {}
                proc p {this} {
                    lappend ::result 4
                }
            }
            set o [new a]
            a::p $o

            namespace eval b {
                namespace eval a {}
                proc a::p {this} {
                    lappend ::result 5
                }
            }
            a::p $o

            namespace eval c {
                proc ::d::a::p {this} {
                    lappend ::result 6
                }
            }
            a::p $o
        }

        class e {
            proc e {this} {}
            class a {
                proc a {this} {}
                proc p {this} {
                    lappend ::result 7
                }
            }
            set o [new a]
            a::p $o

            namespace eval b {
                namespace eval a {}
                proc a::p {this} {
                    lappend ::result 8
                }
            }
            a::p $o

            namespace eval c {
                proc ::e::a::p {this} {
                    lappend ::result 9
                }
            }
            a::p $o
        }

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    1\
    1\
    3\
    4\
    4\
    6\
    7\
    7\
    9\
]

test stooop-68 {
    check inheritance within a deep nested class hierarchy
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {
            proc a {this} {
                lappend ::result a::a
            }
            class b {
                proc b {this} a {} {
                    lappend ::result b::b
                }
                class c {
                    catch {
                        proc c {this} b {} {}
                    } message
                    lappend ::result $message
                    proc c {this} a::b {} {
                        lappend ::result c::c
                    }
                }
                new c
            }
        }

        namespace eval d {
            proc d {this} {
                lappend ::result d::d
            }
            namespace eval e {
                proc e {this} {
                    d::d $this
                    lappend ::result e::e
                }
                namespace eval f {
                    proc f {this} {
                        catch {
                            e::e $this
                        } message
                        lappend ::result $message
                        d::e::e $this
                        lappend ::result f::f
                    }
                }
                f::f 0
            }
        }

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class ::a::b::c constructor defined before base class b constructor}\
    {a::a}\
    {b::b}\
    {c::c}\
    {invalid command name "e::e"}\
    {d::d}\
    {e::e}\
    {f::f}\
]

test stooop-69 {
    check user defined cloning operation in nested class context
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        class a::b {}
        proc a::b::b {this} {
            set ($this,x) 0
        }
        proc a::b::b {this copy} {
            set ($this,x) [expr $($copy,x)+1]
        }
        new [new a::b]
        eval lappend ::result [dumpArrays a::b::]

        class A {
            proc A {this} {}
            class B {
                proc B {this} {
                    set ($this,x) 0
                }
                proc B {this copy} {
                    set ($this,x) [expr $($copy,x)+1]
                }
            }
            new [new B]
            eval lappend ::result [dumpArrays B::]
        }
        new [new A::B]
        eval lappend ::result [dumpArrays A::B::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::b::(1,x) = 0}\
    {a::b::(2,x) = 1}\
    {B::(3,x) = 0}\
    {B::(4,x) = 1}\
    {A::B::(3,x) = 0}\
    {A::B::(4,x) = 1}\
    {A::B::(5,x) = 0}\
    {A::B::(6,x) = 1}\
]

test stooop-70 {
    check basic cloning operation in nested class context
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        class a::b {}
        proc a::b::b {this} {
            set ($this,x) 0
        }
        new [new a::b]
        eval lappend ::result [dumpArrays a::b::]

        class A {
            proc A {this} {}
            class B {
                proc B {this} {
                    set ($this,x) 0
                }
            }
            new [new B]
            eval lappend ::result [dumpArrays B::]
        }
        new [new A::B]
        eval lappend ::result [dumpArrays A::B::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::b::(1,x) = 0}\
    {a::b::(2,x) = 0}\
    {B::(3,x) = 0}\
    {B::(4,x) = 0}\
    {A::B::(3,x) = 0}\
    {A::B::(4,x) = 0}\
    {A::B::(5,x) = 0}\
    {A::B::(6,x) = 0}\
]

test stooop-71 {
    check multiple inheritance construction order, destruction order and data
    deallocation with a common indirect base class
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc z::a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class z::b {}
        proc z::b::b {this p} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc z::b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class z::c {}
        proc z::c::c {this p q r} z::a {$p} z::b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $r
        }
        proc z::c::~c {this} {
            lappend ::result "c::~c $this"
        }
        class z::d {}
        proc z::d::d {this p q r} z::a {$p} z::b {$q} {
            lappend ::result "d::d $this"
            set ($this,p) $p
        }
        proc z::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class z::e {}
        proc z::e::e {this p q r} z::c {$p $q $r} z::d {$q $q $r} {
            lappend ::result "e::e $this"
            set ($this,q) $q
        }
        proc z::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        set o [new z::e {x y} z {1 2}]
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::]
        delete $o
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::]

        class Z {
            class A {
                proc A {this p} {
                    lappend ::result "A::A $this"
                    set ($this,m) $p
                }
                proc ~A {this} {
                    lappend ::result "A::~A $this"
                }
            }
            class B {
                proc B {this p} {
                    lappend ::result "B::B $this"
                    set ($this,n) $p
                }
                proc ~B {this} {
                    lappend ::result "B::~B $this"
                }
            }
            class C {
                proc C {this p q r} Z::A {$p} Z::B {$q} {
                    lappend ::result "C::C $this"
                    set ($this,o) $r
                }
                proc ~C {this} {
                    lappend ::result "C::~C $this"
                }
            }
            class D {
                proc D {this p q r} Z::A {$p} Z::B {$q} {
                    lappend ::result "D::D $this"
                    set ($this,p) $p
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p q r} Z::C {$p $q $r} Z::D {$q $q $r} {
                    lappend ::result "E::E $this"
                    set ($this,q) $q
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            set o [new E {x y} z {1 2}]
            eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]
            delete $o
            eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]
        }
        set o [new Z::E {x y} z {1 2}]
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::]
        delete $o
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::a 1}\
    {b::b 1}\
    {d::d 1}\
    {e::e 1}\
    {z::a::(1,_derived) = ::z::d}\
    {z::a::(1,m) = z}\
    {z::b::(1,_derived) = ::z::d}\
    {z::b::(1,n) = z}\
    {z::c::(1,_derived) = ::z::e}\
    {z::c::(1,o) = 1 2}\
    {z::d::(1,_derived) = ::z::e}\
    {z::d::(1,p) = z}\
    {z::e::(1,q) = z}\
    {e::~e 1}\
    {d::~d 1}\
    {b::~b 1}\
    {a::~a 1}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {A::A 2}\
    {B::B 2}\
    {C::C 2}\
    {A::A 2}\
    {B::B 2}\
    {D::D 2}\
    {E::E 2}\
    {A::(2,_derived) = ::Z::D}\
    {A::(2,m) = z}\
    {B::(2,_derived) = ::Z::D}\
    {B::(2,n) = z}\
    {C::(2,_derived) = ::Z::E}\
    {C::(2,o) = 1 2}\
    {D::(2,_derived) = ::Z::E}\
    {D::(2,p) = z}\
    {E::(2,q) = z}\
    {E::~E 2}\
    {D::~D 2}\
    {B::~B 2}\
    {A::~A 2}\
    {C::~C 2}\
    {B::~B 2}\
    {A::~A 2}\
    {A::A 3}\
    {B::B 3}\
    {C::C 3}\
    {A::A 3}\
    {B::B 3}\
    {D::D 3}\
    {E::E 3}\
    {Z::A::(3,_derived) = ::Z::D}\
    {Z::A::(3,m) = z}\
    {Z::B::(3,_derived) = ::Z::D}\
    {Z::B::(3,n) = z}\
    {Z::C::(3,_derived) = ::Z::E}\
    {Z::C::(3,o) = 1 2}\
    {Z::D::(3,_derived) = ::Z::E}\
    {Z::D::(3,p) = z}\
    {Z::E::(3,q) = z}\
    {E::~E 3}\
    {D::~D 3}\
    {B::~B 3}\
    {A::~A 3}\
    {C::~C 3}\
    {B::~B 3}\
    {A::~A 3}\
]

test stooop-72 {
    check that multiply inherited base classes constructors work with variable
    number of arguments
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this args} {
            lappend ::result "a::a $this $args"
            set ($this,m) [lindex $args 0]
        }
        class z::b {}
        proc z::b::b {this p} {
            lappend ::result "b::b $this $p"
            set ($this,n) $p
        }
        class z::c {}
        proc z::c::c {this p args} {
            lappend ::result "c::c $this $p $args"
            set ($this,o) $p
            set ($this,p) [lindex $args 0]
        }
        class z::d {}
        proc z::d::d {this p args} z::a {$args} z::b {$p} z::c {$p $args} {
            lappend ::result "d::d $this $p $args"
            set ($this,q) $p
            set ($this,r) [lindex $args 0]
        }
        new z::d {x y} {1 2} 3
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d::]

        class Z {
            class A {
                proc A {this args} {
                    lappend ::result "A::A $this $args"
                    set ($this,m) [lindex $args 0]
                }
            }
            class B {
                proc B {this p} {
                    lappend ::result "B::B $this $p"
                    set ($this,n) $p
                }
            }
            class C {
                proc C {this p args} {
                    lappend ::result "C::C $this $p $args"
                    set ($this,o) $p
                    set ($this,p) [lindex $args 0]
                }
            }
            class D {
                proc D {this p args} Z::A {$args} Z::B {$p} Z::C {$p $args} {
                    lappend ::result "D::D $this $p $args"
                    set ($this,q) $p
                    set ($this,r) [lindex $args 0]
                }
            }
            new D {x y} {1 2} 3
            eval lappend ::result [dumpArrays A:: B:: C:: D::]
        }
        new Z::D {x y} {1 2} 3
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1 {1 2} 3}\
    {b::b 1 x y}\
    {c::c 1 x y {1 2} 3}\
    {d::d 1 x y {1 2} 3}\
    {z::a::(1,_derived) = ::z::d}\
    {z::a::(1,m) = 1 2}\
    {z::b::(1,_derived) = ::z::d}\
    {z::b::(1,n) = x y}\
    {z::c::(1,_derived) = ::z::d}\
    {z::c::(1,o) = x y}\
    {z::c::(1,p) = 1 2}\
    {z::d::(1,q) = x y}\
    {z::d::(1,r) = 1 2}\
    {A::A 2 {1 2} 3}\
    {B::B 2 x y}\
    {C::C 2 x y {1 2} 3}\
    {D::D 2 x y {1 2} 3}\
    {A::(2,_derived) = ::Z::D}\
    {A::(2,m) = 1 2}\
    {B::(2,_derived) = ::Z::D}\
    {B::(2,n) = x y}\
    {C::(2,_derived) = ::Z::D}\
    {C::(2,o) = x y}\
    {C::(2,p) = 1 2}\
    {D::(2,q) = x y}\
    {D::(2,r) = 1 2}\
    {A::A 3 {1 2} 3}\
    {B::B 3 x y}\
    {C::C 3 x y {1 2} 3}\
    {D::D 3 x y {1 2} 3}\
    {Z::A::(2,_derived) = ::Z::D}\
    {Z::A::(2,m) = 1 2}\
    {Z::A::(3,_derived) = ::Z::D}\
    {Z::A::(3,m) = 1 2}\
    {Z::B::(2,_derived) = ::Z::D}\
    {Z::B::(2,n) = x y}\
    {Z::B::(3,_derived) = ::Z::D}\
    {Z::B::(3,n) = x y}\
    {Z::C::(2,_derived) = ::Z::D}\
    {Z::C::(2,o) = x y}\
    {Z::C::(2,p) = 1 2}\
    {Z::C::(3,_derived) = ::Z::D}\
    {Z::C::(3,o) = x y}\
    {Z::C::(3,p) = 1 2}\
    {Z::D::(2,q) = x y}\
    {Z::D::(2,r) = 1 2}\
    {Z::D::(3,q) = x y}\
    {Z::D::(3,r) = 1 2}\
]

test stooop-73 {
    check multiple inheritance destruction order and data deallocation with a
    common indirect base class
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this p} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc z::a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class z::b {}
        proc z::b::b {this p} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc z::b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class z::c {}
        proc z::c::c {this p q r} z::a {$p} z::b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $r
        }
        proc z::c::~c {this} {
            lappend ::result "c::~c $this"
        }
        class z::d {}
        proc z::d::d {this p q r} z::a {$p} z::b {$q} {
            lappend ::result "d::d $this"
            set ($this,p) $p
        }
        proc z::d::~d {this} {
            lappend ::result "d::~d $this"
        }
        class z::e {}
        proc z::e::e {this p q r} z::c {$p $q $r} z::d {$q $q $r} {
            lappend ::result "e::e $this"
            set ($this,q) $q
        }
        proc z::e::~e {this} {
            lappend ::result "e::~e $this"
        }
        set o [new z::e {x y} z {1 2}]
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::]
        delete $o
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e::]

        class Z {
            class A {
                proc A {this p} {
                    lappend ::result "A::A $this"
                    set ($this,m) $p
                }
                proc ~A {this} {
                    lappend ::result "A::~A $this"
                }
            }
            class B {
                proc B {this p} {
                    lappend ::result "B::B $this"
                    set ($this,n) $p
                }
                proc ~B {this} {
                    lappend ::result "B::~B $this"
                }
            }
            class C {
                proc C {this p q r} Z::A {$p} Z::B {$q} {
                    lappend ::result "C::C $this"
                    set ($this,o) $r
                }
                proc ~C {this} {
                    lappend ::result "C::~C $this"
                }
            }
            class D {
                proc D {this p q r} Z::A {$p} Z::B {$q} {
                    lappend ::result "D::D $this"
                    set ($this,p) $p
                }
                proc ~D {this} {
                    lappend ::result "D::~D $this"
                }
            }
            class E {
                proc E {this p q r} Z::C {$p $q $r} Z::D {$q $q $r} {
                    lappend ::result "E::E $this"
                    set ($this,q) $q
                }
                proc ~E {this} {
                    lappend ::result "E::~E $this"
                }
            }
            set o [new E {x y} z {1 2}]
            eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]
            delete $o
            eval lappend ::result [dumpArrays A:: B:: C:: D:: E::]
        }
        set o [new Z::E {x y} z {1 2}]
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::]
        delete $o
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {a::a 1}\
    {b::b 1}\
    {d::d 1}\
    {e::e 1}\
    {z::a::(1,_derived) = ::z::d}\
    {z::a::(1,m) = z}\
    {z::b::(1,_derived) = ::z::d}\
    {z::b::(1,n) = z}\
    {z::c::(1,_derived) = ::z::e}\
    {z::c::(1,o) = 1 2}\
    {z::d::(1,_derived) = ::z::e}\
    {z::d::(1,p) = z}\
    {z::e::(1,q) = z}\
    {e::~e 1}\
    {d::~d 1}\
    {b::~b 1}\
    {a::~a 1}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {A::A 2}\
    {B::B 2}\
    {C::C 2}\
    {A::A 2}\
    {B::B 2}\
    {D::D 2}\
    {E::E 2}\
    {A::(2,_derived) = ::Z::D}\
    {A::(2,m) = z}\
    {B::(2,_derived) = ::Z::D}\
    {B::(2,n) = z}\
    {C::(2,_derived) = ::Z::E}\
    {C::(2,o) = 1 2}\
    {D::(2,_derived) = ::Z::E}\
    {D::(2,p) = z}\
    {E::(2,q) = z}\
    {E::~E 2}\
    {D::~D 2}\
    {B::~B 2}\
    {A::~A 2}\
    {C::~C 2}\
    {B::~B 2}\
    {A::~A 2}\
    {A::A 3}\
    {B::B 3}\
    {C::C 3}\
    {A::A 3}\
    {B::B 3}\
    {D::D 3}\
    {E::E 3}\
    {Z::A::(3,_derived) = ::Z::D}\
    {Z::A::(3,m) = z}\
    {Z::B::(3,_derived) = ::Z::D}\
    {Z::B::(3,n) = z}\
    {Z::C::(3,_derived) = ::Z::E}\
    {Z::C::(3,o) = 1 2}\
    {Z::D::(3,_derived) = ::Z::E}\
    {Z::D::(3,p) = z}\
    {Z::E::(3,q) = z}\
    {E::~E 3}\
    {D::~D 3}\
    {B::~B 3}\
    {A::~A 3}\
    {C::~C 3}\
    {B::~B 3}\
    {A::~A 3}\
]

test stooop-74 {
    check that optional arguments in constructors and multiple inheritance work
    together
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this {p 0}} {
            lappend ::result "a::a $this"
            set ($this,m) $p
        }
        proc z::a::~a {this} {
            lappend ::result "a::~a $this"
        }
        class z::b {}
        proc z::b::b {this {p 1}} {
            lappend ::result "b::b $this"
            set ($this,n) $p
        }
        proc z::b::~b {this} {
            lappend ::result "b::~b $this"
        }
        class z::c {}
        proc z::c::c {this {p 2} {q 3}} z::a {$p} z::b {$q} {
            lappend ::result "c::c $this"
            set ($this,o) $p
            set ($this,p) $q
        }
        proc z::c::~c {this} {
            lappend ::result "c::~c $this"
        }
        set o [new z::c {x y} z]
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c::]
        delete $o
        set o [new z::c]
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c::]

        class Z {
            class A {
                proc A {this {p 0}} {
                    lappend ::result "A::A $this"
                    set ($this,m) $p
                }
                proc ~A {this} {
                    lappend ::result "A::~A $this"
                }
            }
            class B {
                proc B {this {p 1}} {
                    lappend ::result "B::B $this"
                    set ($this,n) $p
                }
                proc ~B {this} {
                    lappend ::result "B::~B $this"
                }
            }
            class C {
                proc C {this {p 2} {q 3}} Z::A {$p} Z::B {$q} {
                    lappend ::result "C::C $this"
                    set ($this,o) $p
                    set ($this,p) $q
                }
                proc ~C {this} {
                    lappend ::result "C::~C $this"
                }
            }
            set o [new C {x y} z]
            eval lappend ::result [dumpArrays A:: B:: C::]
            delete $o
            set o [new C]
            eval lappend ::result [dumpArrays A:: B:: C::]
            delete $o
        }
        set o [new Z::C {x y} z]
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C::]
        delete $o
        set o [new Z::C]
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 1}\
    {c::c 1}\
    {z::a::(1,_derived) = ::z::c}\
    {z::a::(1,m) = x y}\
    {z::b::(1,_derived) = ::z::c}\
    {z::b::(1,n) = z}\
    {z::c::(1,o) = x y}\
    {z::c::(1,p) = z}\
    {c::~c 1}\
    {b::~b 1}\
    {a::~a 1}\
    {a::a 2}\
    {b::b 2}\
    {c::c 2}\
    {z::a::(2,_derived) = ::z::c}\
    {z::a::(2,m) = 2}\
    {z::b::(2,_derived) = ::z::c}\
    {z::b::(2,n) = 3}\
    {z::c::(2,o) = 2}\
    {z::c::(2,p) = 3}\
    {A::A 3}\
    {B::B 3}\
    {C::C 3}\
    {A::(3,_derived) = ::Z::C}\
    {A::(3,m) = x y}\
    {B::(3,_derived) = ::Z::C}\
    {B::(3,n) = z}\
    {C::(3,o) = x y}\
    {C::(3,p) = z}\
    {C::~C 3}\
    {B::~B 3}\
    {A::~A 3}\
    {A::A 4}\
    {B::B 4}\
    {C::C 4}\
    {A::(4,_derived) = ::Z::C}\
    {A::(4,m) = 2}\
    {B::(4,_derived) = ::Z::C}\
    {B::(4,n) = 3}\
    {C::(4,o) = 2}\
    {C::(4,p) = 3}\
    {C::~C 4}\
    {B::~B 4}\
    {A::~A 4}\
    {A::A 5}\
    {B::B 5}\
    {C::C 5}\
    {Z::A::(5,_derived) = ::Z::C}\
    {Z::A::(5,m) = x y}\
    {Z::B::(5,_derived) = ::Z::C}\
    {Z::B::(5,n) = z}\
    {Z::C::(5,o) = x y}\
    {Z::C::(5,p) = z}\
    {C::~C 5}\
    {B::~B 5}\
    {A::~A 5}\
    {A::A 6}\
    {B::B 6}\
    {C::C 6}\
    {Z::A::(6,_derived) = ::Z::C}\
    {Z::A::(6,m) = 2}\
    {Z::B::(6,_derived) = ::Z::C}\
    {Z::B::(6,n) = 3}\
    {Z::C::(6,o) = 2}\
    {Z::C::(6,p) = 3}\
]

test stooop-75 {
    check various virtual procedures configurations in a 3 level deep class
    hierarchy
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this} {}
        proc z::a::~a {this} {}
        virtual proc z::a::f {this p q} {}
        virtual proc z::a::g {this p q}
        virtual proc z::a::h {this p q} {
            lappend ::result "a::h $this $p $q"
        }
        virtual proc z::a::i {this p q} {
            lappend ::result "a::i $this $p $q"
        }
        virtual proc z::a::k {this p q}
        virtual proc z::a::l {this p q} {
            lappend ::result "a::l $this $p $q"
        }
        class z::b {}
        proc z::b::b {this} z::a {} {}
        proc z::b::~b {this} {}
        virtual proc z::b::f {this p q} {
            lappend ::result "b::f $this $p $q"
        }
        virtual proc z::b::g {this p q}
        virtual proc z::b::h {this p q} {
            lappend ::result "b::h $this $p $q"
        }
        proc z::b::i {this p q} {
            lappend ::result "b::i $this $p $q"
        }
        virtual proc z::b::k {this p q} {
            lappend ::result "b::k $this $p $q"
        }
        virtual proc z::b::l {this p q}
        class z::c {}
        proc z::c::c {this} z::b {} {}
        proc z::c::~c {this} {}
        proc z::c::f {this p q} {
            lappend ::result "c::f $this $p $q"
        }
        proc z::c::g {this p q} {
            lappend ::result "c::g $this $p $q"
        }
        proc z::c::i {this p q} {
            lappend ::result "c::i $this $p $q"
        }
        proc z::c::k {this p q} {
            lappend ::result "c::k $this $p $q"
        }
        proc z::c::l {this p q} {
            lappend ::result "c::l $this $p $q"
        }
        set o [new z::c]
        z::a::f $o x {y z}
        z::a::g $o x {y z}
        z::a::h $o x {y z}
        z::a::i $o x {y z}
        z::a::k $o x {y z}
        z::a::l $o x {y z}

        class Z {
            class A {
                proc A {this} {}
                proc ~A {this} {}
                virtual proc f {this p q} {}
                virtual proc g {this p q}
                virtual proc h {this p q} {
                    lappend ::result "A::h $this $p $q"
                }
                virtual proc i {this p q} {
                    lappend ::result "A::i $this $p $q"
                }
                virtual proc k {this p q}
                virtual proc l {this p q} {
                    lappend ::result "A::l $this $p $q"
                }
            }
            class B {
                proc B {this} Z::A {} {}
                proc ~B {this} {}
                virtual proc f {this p q} {
                    lappend ::result "B::f $this $p $q"
                }
                virtual proc g {this p q}
                virtual proc h {this p q} {
                    lappend ::result "B::h $this $p $q"
                }
                proc i {this p q} {
                    lappend ::result "B::i $this $p $q"
                }
                virtual proc k {this p q} {
                    lappend ::result "B::k $this $p $q"
                }
                virtual proc l {this p q}
            }
            class C {
                proc C {this} Z::B {} {}
                proc ~C {this} {}
                proc f {this p q} {
                    lappend ::result "C::f $this $p $q"
                }
                proc g {this p q} {
                    lappend ::result "C::g $this $p $q"
                }
                proc i {this p q} {
                    lappend ::result "C::i $this $p $q"
                }
                proc k {this p q} {
                    lappend ::result "C::k $this $p $q"
                }
                proc l {this p q} {
                    lappend ::result "C::l $this $p $q"
                }
            }
            set o [new C]
            A::f $o x {y z}
            A::g $o x {y z}
            A::h $o x {y z}
            A::i $o x {y z}
            A::k $o x {y z}
            A::l $o x {y z}
        }
        set o [new Z::C]
        Z::A::f $o x {y z}
        Z::A::g $o x {y z}
        Z::A::h $o x {y z}
        Z::A::i $o x {y z}
        Z::A::k $o x {y z}
        Z::A::l $o x {y z}

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {c::f 1 x y z}\
    {c::g 1 x y z}\
    {b::h 1 x y z}\
    {b::i 1 x y z}\
    {c::k 1 x y z}\
    {c::l 1 x y z}\
    {C::f 2 x y z}\
    {C::g 2 x y z}\
    {B::h 2 x y z}\
    {B::i 2 x y z}\
    {C::k 2 x y z}\
    {C::l 2 x y z}\
    {C::f 3 x y z}\
    {C::g 3 x y z}\
    {B::h 3 x y z}\
    {B::i 3 x y z}\
    {C::k 3 x y z}\
    {C::l 3 x y z}\
]

test stooop-76 {
    check various virtual procedures with variable number of arguments
    configurations in a 3 level deep class hierarchy
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this} {}
        proc z::a::~a {this} {}
        virtual proc z::a::f {this p args} {}
        virtual proc z::a::g {this p args}
        virtual proc z::a::h {this p args} {
            lappend ::result "a::h $this $p $args"
        }
        virtual proc z::a::i {this p args} {
            lappend ::result "a::i $this $p $args"
        }
        virtual proc z::a::k {this p args}
        virtual proc z::a::l {this p args} {
            lappend ::result "a::l $this $p $args"
        }
        class z::b {}
        proc z::b::b {this} z::a {} {}
        proc z::b::~b {this} {}
        virtual proc z::b::f {this p args} {
            lappend ::result "b::f $this $p $args"
        }
        virtual proc z::b::g {this p args}
        virtual proc z::b::h {this p args} {
            lappend ::result "b::h $this $p $args"
        }
        proc z::b::i {this p args} {
            lappend ::result "b::i $this $p $args"
        }
        virtual proc z::b::k {this p args} {
            lappend ::result "b::k $this $p $args"
        }
        virtual proc z::b::l {this p args}
        class z::c {}
        proc z::c::c {this} z::b {} {}
        proc z::c::~c {this} {}
        proc z::c::f {this p args} {
            lappend ::result "c::f $this $p $args"
        }
        proc z::c::g {this p args} {
            lappend ::result "c::g $this $p $args"
        }
        proc z::c::i {this p args} {
            lappend ::result "c::i $this $p $args"
        }
        proc z::c::k {this p args} {
            lappend ::result "c::k $this $p $args"
        }
        proc z::c::l {this p args} {
            lappend ::result "c::l $this $p $args"
        }
        set o [new z::c]
        z::a::f $o x {y z}
        z::a::g $o x {y z}
        z::a::h $o x {y z}
        z::a::i $o x {y z}
        z::a::k $o x {y z}
        z::a::l $o x {y z}

        class Z {
            class A {
                proc A {this} {}
                proc ~A {this} {}
                virtual proc f {this p args} {}
                virtual proc g {this p args}
                virtual proc h {this p args} {
                    lappend ::result "A::h $this $p $args"
                }
                virtual proc i {this p args} {
                    lappend ::result "A::i $this $p $args"
                }
                virtual proc k {this p args}
                virtual proc l {this p args} {
                    lappend ::result "A::l $this $p $args"
                }
            }
            class B {
                proc B {this} Z::A {} {}
                proc ~B {this} {}
                virtual proc f {this p args} {
                    lappend ::result "B::f $this $p $args"
                }
                virtual proc g {this p args}
                virtual proc h {this p args} {
                    lappend ::result "B::h $this $p $args"
                }
                proc i {this p args} {
                    lappend ::result "B::i $this $p $args"
                }
                virtual proc k {this p args} {
                    lappend ::result "B::k $this $p $args"
                }
                virtual proc l {this p args}
            }
            class C {
                proc C {this} Z::B {} {}
                proc ~C {this} {}
                proc f {this p args} {
                    lappend ::result "C::f $this $p $args"
                }
                proc g {this p args} {
                    lappend ::result "C::g $this $p $args"
                }
                proc i {this p args} {
                    lappend ::result "C::i $this $p $args"
                }
                proc k {this p args} {
                    lappend ::result "C::k $this $p $args"
                }
                proc l {this p args} {
                    lappend ::result "C::l $this $p $args"
                }
            }
            set o [new C]
            A::f $o x {y z}
            A::g $o x {y z}
            A::h $o x {y z}
            A::i $o x {y z}
            A::k $o x {y z}
            A::l $o x {y z}
        }
        set o [new Z::C]
        Z::A::f $o x {y z}
        Z::A::g $o x {y z}
        Z::A::h $o x {y z}
        Z::A::i $o x {y z}
        Z::A::k $o x {y z}
        Z::A::l $o x {y z}

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {c::f 1 x {y z}}\
    {c::g 1 x {y z}}\
    {b::h 1 x {y z}}\
    {b::i 1 x {y z}}\
    {c::k 1 x {y z}}\
    {c::l 1 x {y z}}\
    {C::f 2 x {y z}}\
    {C::g 2 x {y z}}\
    {B::h 2 x {y z}}\
    {B::i 2 x {y z}}\
    {C::k 2 x {y z}}\
    {C::l 2 x {y z}}\
    {C::f 3 x {y z}}\
    {C::g 3 x {y z}}\
    {B::h 3 x {y z}}\
    {B::i 3 x {y z}}\
    {C::k 3 x {y z}}\
    {C::l 3 x {y z}}\
]

test stooop-77 {
    check normal and user defined cloning operation with multiple inheritance
    and member objects
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this p} {
            set ($this,m) $p
        }
        class z::b {}
        proc z::b::b {this p} {
            set ($this,n) $p
        }
        class z::c {}
        proc z::c::c {this p q r} z::a {$p} z::b {$q} {
            set ($this,o) $r
            set ($this,O) [new z::f]
        }
        proc z::c::c {this copy} z::a {$z::a::($copy,m)} z::b 1 {
            set ($this,o) $($copy,o)
            set ($this,O) [new z::f]
        }
        class z::d {}
        proc z::d::d {this p q r} z::a {$p} z::b {$q} {
            set ($this,p) $p
        }
        class z::e {}
        proc z::e::e {this p q r} z::c {$p $q $r} z::d {$q $q $r} {
            set ($this,q) $q
        }
        class z::f {}
        proc z::f::f {this} {
            set ($this,x) 0
        }
        new [new z::e {x y} z {1 2}]
        eval lappend ::result [dumpArrays z::a:: z::b:: z::c:: z::d:: z::e:: z::f::]

        class Z {
            class A {
                proc A {this p} {
                    set ($this,m) $p
                }
            }
            class B {
                proc B {this p} {
                    set ($this,n) $p
                }
            }
            class C {
                proc C {this p q r} Z::A {$p} Z::B {$q} {
                    set ($this,o) $r
                    set ($this,O) [new Z::F]
                }
                proc C {this copy} Z::A {$Z::A::($copy,m)} Z::B 1 {
                    set ($this,o) $($copy,o)
                    set ($this,O) [new Z::F]
                }
            }
            class D {
                proc D {this p q r} Z::A {$p} Z::B {$q} {
                    set ($this,p) $p
                }
            }
            class E {
                proc E {this p q r} Z::C {$p $q $r} Z::D {$q $q $r} {
                    set ($this,q) $q
                }
            }
            class F {
                proc F {this} {
                    set ($this,x) 0
                }
            }
            new [new E {x y} z {1 2}]
            eval lappend ::result [dumpArrays A:: B:: C:: D:: E:: F::]
        }
        new [new Z::E {x y} z {1 2}]
        eval lappend ::result [dumpArrays Z::A:: Z::B:: Z::C:: Z::D:: Z::E:: Z::F::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {z::a::(1,_derived) = ::z::d}\
    {z::a::(1,m) = z}\
    {z::a::(3,_derived) = ::z::d}\
    {z::a::(3,m) = z}\
    {z::b::(1,_derived) = ::z::d}\
    {z::b::(1,n) = z}\
    {z::b::(3,_derived) = ::z::d}\
    {z::b::(3,n) = z}\
    {z::c::(1,O) = 2}\
    {z::c::(1,_derived) = ::z::e}\
    {z::c::(1,o) = 1 2}\
    {z::c::(3,O) = 4}\
    {z::c::(3,_derived) = ::z::e}\
    {z::c::(3,o) = 1 2}\
    {z::d::(1,_derived) = ::z::e}\
    {z::d::(1,p) = z}\
    {z::d::(3,_derived) = ::z::e}\
    {z::d::(3,p) = z}\
    {z::e::(1,q) = z}\
    {z::e::(3,q) = z}\
    {z::f::(2,x) = 0}\
    {z::f::(4,x) = 0}\
    {A::(5,_derived) = ::Z::D}\
    {A::(5,m) = z}\
    {A::(7,_derived) = ::Z::D}\
    {A::(7,m) = z}\
    {B::(5,_derived) = ::Z::D}\
    {B::(5,n) = z}\
    {B::(7,_derived) = ::Z::D}\
    {B::(7,n) = z}\
    {C::(5,O) = 6}\
    {C::(5,_derived) = ::Z::E}\
    {C::(5,o) = 1 2}\
    {C::(7,O) = 8}\
    {C::(7,_derived) = ::Z::E}\
    {C::(7,o) = 1 2}\
    {D::(5,_derived) = ::Z::E}\
    {D::(5,p) = z}\
    {D::(7,_derived) = ::Z::E}\
    {D::(7,p) = z}\
    {E::(5,q) = z}\
    {E::(7,q) = z}\
    {F::(6,x) = 0}\
    {F::(8,x) = 0}\
    {Z::A::(11,_derived) = ::Z::D}\
    {Z::A::(11,m) = z}\
    {Z::A::(5,_derived) = ::Z::D}\
    {Z::A::(5,m) = z}\
    {Z::A::(7,_derived) = ::Z::D}\
    {Z::A::(7,m) = z}\
    {Z::A::(9,_derived) = ::Z::D}\
    {Z::A::(9,m) = z}\
    {Z::B::(11,_derived) = ::Z::D}\
    {Z::B::(11,n) = z}\
    {Z::B::(5,_derived) = ::Z::D}\
    {Z::B::(5,n) = z}\
    {Z::B::(7,_derived) = ::Z::D}\
    {Z::B::(7,n) = z}\
    {Z::B::(9,_derived) = ::Z::D}\
    {Z::B::(9,n) = z}\
    {Z::C::(11,O) = 12}\
    {Z::C::(11,_derived) = ::Z::E}\
    {Z::C::(11,o) = 1 2}\
    {Z::C::(5,O) = 6}\
    {Z::C::(5,_derived) = ::Z::E}\
    {Z::C::(5,o) = 1 2}\
    {Z::C::(7,O) = 8}\
    {Z::C::(7,_derived) = ::Z::E}\
    {Z::C::(7,o) = 1 2}\
    {Z::C::(9,O) = 10}\
    {Z::C::(9,_derived) = ::Z::E}\
    {Z::C::(9,o) = 1 2}\
    {Z::D::(11,_derived) = ::Z::E}\
    {Z::D::(11,p) = z}\
    {Z::D::(5,_derived) = ::Z::E}\
    {Z::D::(5,p) = z}\
    {Z::D::(7,_derived) = ::Z::E}\
    {Z::D::(7,p) = z}\
    {Z::D::(9,_derived) = ::Z::E}\
    {Z::D::(9,p) = z}\
    {Z::E::(11,q) = z}\
    {Z::E::(5,q) = z}\
    {Z::E::(7,q) = z}\
    {Z::E::(9,q) = z}\
    {Z::F::(10,x) = 0}\
    {Z::F::(12,x) = 0}\
    {Z::F::(6,x) = 0}\
    {Z::F::(8,x) = 0}\
]

test stooop-78 {
    check that virtual procedure invocations from base class constructor behave
    as in C++
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class z {}
        class z::a {}
        proc z::a::a {this} {
            z::a::f $this x
            z::a::g $this x {y z}
            # pure virtual invocations behavior is undefined
            lappend ::result [catch {z::a::h $this x}]
            lappend ::result [catch {z::a::i $this x {y z}}]
        }
        proc z::a::~a {this} {}
        virtual proc z::a::f {this p} {
            lappend ::result "a::f $this $p"
        }
        virtual proc z::a::g {this p args} {
            lappend ::result "a::g $this $p $args"
        }
        virtual proc z::a::h {this p}
        virtual proc z::a::i {this p args}
        class z::b {}
        proc z::b::b {this} z::a {} {}
        proc z::b::~b {this} {}
        virtual proc z::b::f {this p} {
            lappend ::result "b::f $this $p"
        }
        virtual proc z::b::g {this p args} {
            lappend ::result "b::g $this $p $args"
        }
        virtual proc z::b::h {this p} {
            lappend ::result "b::h $this $p"
        }
        proc z::b::i {this p args} {
            lappend ::result "b::i $this $p $args"
        }
        new z::b

        class Z {
            class A {
                proc A {this} {
                    f $this x
                    g $this x {y z}
                    # pure virtual invocations behavior is undefined
                    lappend ::result [catch {A::h $this x}]
                    lappend ::result [catch {A::i $this x {y z}}]
                }
                proc ~A {this} {}
                virtual proc f {this p} {
                    lappend ::result "A::f $this $p"
                }
                virtual proc g {this p args} {
                    lappend ::result "A::g $this $p $args"
                }
                virtual proc h {this p}
                virtual proc i {this p args}
            }
            class B {
                proc B {this} Z::A {} {}
                proc ~B {this} {}
                virtual proc f {this p} {
                    lappend ::result "B::f $this $p"
                }
                virtual proc g {this p args} {
                    lappend ::result "B::g $this $p $args"
                }
                virtual proc h {this p} {
                    lappend ::result "B::h $this $p"
                }
                proc i {this p args} {
                    lappend ::result "B::i $this $p $args"
                }
            }
            new B
        }
        new Z::B

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::f 1 x}\
    {a::g 1 x {y z}}\
    {1}\
    {1}\
    {A::f 2 x}\
    {A::g 2 x {y z}}\
    {1}\
    {1}\
    {A::f 3 x}\
    {A::g 3 x {y z}}\
    {1}\
    {1}\
]

test stooop-79 {
    check that child nested class is visible within parent namespace
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
            new b
        }
        class a::b {}
        proc a::b::b {this} {
            lappend ::result "b::b $this"
        }
        new a

        class a {
            proc a {this} {
                lappend ::result "a::a $this"
                new b
            }
            class b {
                proc b {this} {
                    lappend ::result "b::b $this"
                }
            }
            new a
        }

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {b::b 2}\
    {a::a 3}\
    {b::b 4}\
]

test stooop-80 {
    verify regular member procedure checking in procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::p {this} {}
        class b {}
        proc b::b {this} {}
        proc b::p {this} {}
        set o [new a]
        a::p $o
        catch {b::p $o} message
        lappend ::result $message

        class A {
            proc A {this} {}
            proc p {this} {}
        }
        class B {
            proc B {this} {}
            proc p {this} {}
        }
        set o [new A]
        A::p $o
        catch {B::p $o} message
        lappend ::result $message

        class c {}
        class c::d {}
        proc c::d::d {this} {}
        proc c::d::p {this} {}
        class c::e {}
        proc c::e::e {this} {}
        proc c::e::p {this} {}
        set o [new c::d]
        c::d::p $o
        catch {c::e::p $o} message
        lappend ::result $message

        class C {
            class D {
                proc D {this} {}
                proc p {this} {}
            }
            class E {
                proc E {this} {}
                proc p {this} {}
            }
            set o [new D]
            D::p $o
            catch {E::p $o} message
            lappend ::result $message
        }
        set o [new C::D]
        C::D::p $o
        catch {C::E::p $o} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class b of ::b::p procedure not an ancestor of object 1 class a}\
    {class B of ::B::p procedure not an ancestor of object 2 class A}\
    {class c::e of ::c::e::p procedure not an ancestor of object 3 class c::d}\
    {class C::E of ::C::E::p procedure not an ancestor of object 4 class C::D}\
    {class C::E of ::C::E::p procedure not an ancestor of object 5 class C::D}\
]

test stooop-81 {
    verify regular member procedure checking within class hierarchy in
    procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        proc a::p {this} {}
        class b {}
        proc b::b {this} a {} {}
        proc b::~b {this} {}
        proc b::p {this} {}
        class c {}
        proc c::c {this} b {} {}
        proc c::~c {this} {}
        proc c::p {this} {}
        set o [new a]
        a::p $o
        catch {b::p $o} message
        lappend ::result $message
        catch {c::p $o} message
        lappend ::result $message
        delete $o
        set o [new b]
        a::p $o
        b::p $o
        catch {c::p $o} message
        lappend ::result $message
        delete $o
        set o [new c]
        a::p $o
        b::p $o
        c::p $o
        delete $o

        class a {
            proc a {this} {}
            proc ~a {this} {}
            proc p {this} {}
        }
        class b {
            proc b {this} a {} {}
            proc ~b {this} {}
            proc p {this} {}
        }
        class c {
            proc c {this} b {} {}
            proc ~c {this} {}
            proc p {this} {}
        }
        set o [new a]
        a::p $o
        catch {b::p $o} message
        lappend ::result $message
        catch {c::p $o} message
        lappend ::result $message
        delete $o
        set o [new b]
        a::p $o
        b::p $o
        catch {c::p $o} message
        lappend ::result $message
        delete $o
        set o [new c]
        a::p $o
        b::p $o
        c::p $o
        delete $o

        class d {}
        class d::e {}
        proc d::e::e {this} {}
        proc d::e::~e {this} {}
        proc d::e::p {this} {}
        class d::f {}
        proc d::f::f {this} d::e {} {}
        proc d::f::~f {this} {}
        proc d::f::p {this} {}
        class d::g {}
        proc d::g::g {this} d::f {} {}
        proc d::g::~g {this} {}
        proc d::g::p {this} {}
        set o [new d::e]
        d::e::p $o
        catch {d::f::p $o} message
        lappend ::result $message
        catch {d::g::p $o} message
        lappend ::result $message
        delete $o
        set o [new d::f]
        d::e::p $o
        d::f::p $o
        catch {d::g::p $o} message
        lappend ::result $message
        delete $o
        set o [new d::g]
        d::e::p $o
        d::f::p $o
        d::g::p $o
        delete $o

        class C {
            class D {
                proc D {this} {}
                proc ~D {this} {}
                proc p {this} {}
            }
            class E {
                proc E {this} C::D {} {}
                proc ~E {this} {}
                proc p {this} {}
            }
            class F {
                proc F {this} C::E {} {}
                proc ~F {this} {}
                proc p {this} {}
            }
            set o [new D]
            D::p $o
            catch {E::p $o} message
            lappend ::result $message
            catch {F::p $o} message
            lappend ::result $message
            delete $o
            set o [new E]
            D::p $o
            E::p $o
            catch {F::p $o} message
            lappend ::result $message
            delete $o
            set o [new F]
            D::p $o
            E::p $o
            F::p $o
            delete $o
        }
        set o [new C::D]
        C::D::p $o
        catch {C::E::p $o} message
        lappend ::result $message
        catch {C::F::p $o} message
        lappend ::result $message
        delete $o
        set o [new C::E]
        C::D::p $o
        C::E::p $o
        catch {C::F::p $o} message
        lappend ::result $message
        delete $o
        set o [new C::F]
        C::D::p $o
        C::E::p $o
        C::F::p $o
        delete $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class b of ::b::p procedure not an ancestor of object 1 class a}\
    {class c of ::c::p procedure not an ancestor of object 1 class a}\
    {class c of ::c::p procedure not an ancestor of object 2 class b}\
    {class b of ::b::p procedure not an ancestor of object 4 class a}\
    {class c of ::c::p procedure not an ancestor of object 4 class a}\
    {class c of ::c::p procedure not an ancestor of object 5 class b}\
    {class d::f of ::d::f::p procedure not an ancestor of object 7 class d::e}\
    {class d::g of ::d::g::p procedure not an ancestor of object 7 class d::e}\
    {class d::g of ::d::g::p procedure not an ancestor of object 8 class d::f}\
    {class C::E of ::C::E::p procedure not an ancestor of object 10 class C::D}\
    {class C::F of ::C::F::p procedure not an ancestor of object 10 class C::D}\
    {class C::F of ::C::F::p procedure not an ancestor of object 11 class C::E}\
    {class C::E of ::C::E::p procedure not an ancestor of object 13 class C::D}\
    {class C::F of ::C::F::p procedure not an ancestor of object 13 class C::D}\
    {class C::F of ::C::F::p procedure not an ancestor of object 14 class C::E}\
]

test stooop-82 {
    verify regular member procedure checking within multiple inheritance class
    hierarchy in procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::p {this} {}
        class b {}
        proc b::b {this} {}
        proc b::p {this} {}
        class c {}
        proc c::c {this} a {} b {} {}
        proc c::p {this} {}
        set o [new a]
        a::p $o
        catch {b::p $o} message
        lappend ::result $message
        catch {c::p $o} message
        lappend ::result $message

        class A {
            proc A {this} {}
            proc p {this} {}
        }
        class B {
            proc B {this} {}
            proc p {this} {}
        }
        class C {
            proc C {this} A {} B {} {}
            proc p {this} {}
        }
        set o [new A]
        A::p $o
        catch {B::p $o} message
        lappend ::result $message
        catch {C::p $o} message
        lappend ::result $message

        class d {}
        class d::e {}
        proc d::e::e {this} {}
        proc d::e::p {this} {}
        class d::f {}
        proc d::f::f {this} {}
        proc d::f::p {this} {}
        class d::g {}
        proc d::g::g {this} d::e {} d::f {} {}
        proc d::g::p {this} {}
        set o [new d::e]
        d::e::p $o
        catch {d::f::p $o} message
        lappend ::result $message
        catch {d::g::p $o} message
        lappend ::result $message

        class D {
            class E {
                proc E {this} {}
                proc p {this} {}
            }
            class F {
                proc F {this} {}
                proc p {this} {}
            }
            class G {
                proc G {this} D::E {} D::F {} {}
                proc p {this} {}
            }
            set o [new E]
            E::p $o
            catch {F::p $o} message
            lappend ::result $message
            catch {G::p $o} message
            lappend ::result $message
        }
        set o [new D::E]
        D::E::p $o
        catch {D::F::p $o} message
        lappend ::result $message
        catch {D::G::p $o} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {class b of ::b::p procedure not an ancestor of object 1 class a}\
    {class c of ::c::p procedure not an ancestor of object 1 class a}\
    {class B of ::B::p procedure not an ancestor of object 2 class A}\
    {class C of ::C::p procedure not an ancestor of object 2 class A}\
    {class d::f of ::d::f::p procedure not an ancestor of object 3 class d::e}\
    {class d::g of ::d::g::p procedure not an ancestor of object 3 class d::e}\
    {class D::F of ::D::F::p procedure not an ancestor of object 4 class D::E}\
    {class D::G of ::D::G::p procedure not an ancestor of object 4 class D::E}\
    {class D::F of ::D::F::p procedure not an ancestor of object 5 class D::E}\
    {class D::G of ::D::G::p procedure not an ancestor of object 5 class D::E}\
]

test stooop-83 {
    verify object identifier checking in procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::p {this} {}
        catch {a::p 1} message
        lappend ::result $message

        class A {
            proc A {this} {}
            proc p {this} {}
        }
        catch {A::p 2} message
        lappend ::result $message

        class b {}
        class b::c {}
        proc b::c::c {this} {}
        proc b::c::p {this} {}
        catch {b::c::p 3} message
        lappend ::result $message

        class B {
            class C {
                proc C {this} {}
                proc p {this} {}
            }
            catch {C::p 4} message
            lappend ::result $message
        }
        catch {B::C::p 5} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {1 is not a valid object identifier}\
    {2 is not a valid object identifier}\
    {3 is not a valid object identifier}\
    {4 is not a valid object identifier}\
    {5 is not a valid object identifier}\
]

test stooop-84 {
    verify virtual member procedure checking in procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        virtual proc a::p {this} {
            lappend ::result "a::p $this"
        }
        virtual proc a::q {this}
        virtual proc a::r {this} {
            lappend ::result "a::r $this"
        }
        class b {}
        proc b::b {this} a {} {}
        proc b::~b {this} {}
        proc b::p {this} {
            lappend ::result "b::p $this"
        }
        proc b::q {this} {
            lappend ::result "b::q $this"
        }
        set o [new b]
        a::p $o
        a::q $o
        a::r $o
        b::p $o
        b::q $o
        delete $o
        catch {a::p $o} message; lappend ::result $message
        catch {a::q $o} message; lappend ::result $message
        catch {a::r $o} message; lappend ::result $message
        catch {b::p $o} message; lappend ::result $message
        catch {b::q $o} message; lappend ::result $message

        class A {
            proc A {this} {}
            proc ~A {this} {}
            virtual proc p {this} {
                lappend ::result "A::p $this"
            }
            virtual proc q {this}
            virtual proc r {this} {
                lappend ::result "A::r $this"
            }
        }
        class B {
            proc B {this} A {} {}
            proc ~B {this} {}
            proc p {this} {
                lappend ::result "B::p $this"
            }
            proc q {this} {
                lappend ::result "B::q $this"
            }
        }
        set o [new B]
        A::p $o
        A::q $o
        A::r $o
        B::p $o
        B::q $o
        delete $o
        catch {A::p $o} message; lappend ::result $message
        catch {A::q $o} message; lappend ::result $message
        catch {A::r $o} message; lappend ::result $message
        catch {B::p $o} message; lappend ::result $message
        catch {B::q $o} message; lappend ::result $message

        class c {}
        class c::d {}
        proc c::d::d {this} {}
        proc c::d::~d {this} {}
        virtual proc c::d::p {this} {
            lappend ::result "d::p $this"
        }
        virtual proc c::d::q {this}
        virtual proc c::d::r {this} {
            lappend ::result "d::r $this"
        }
        class c::e {}
        proc c::e::e {this} c::d {} {}
        proc c::e::~e {this} {}
        proc c::e::p {this} {
            lappend ::result "e::p $this"
        }
        proc c::e::q {this} {
            lappend ::result "e::q $this"
        }
        set o [new c::e]
        c::d::p $o
        c::d::q $o
        c::d::r $o
        c::e::p $o
        c::e::q $o
        delete $o
        catch {c::d::p $o} message; lappend ::result $message
        catch {c::d::q $o} message; lappend ::result $message
        catch {c::d::r $o} message; lappend ::result $message
        catch {c::e::p $o} message; lappend ::result $message
        catch {c::e::q $o} message; lappend ::result $message

        class C {
            class D {
                proc D {this} {}
                proc ~D {this} {}
                virtual proc p {this} {
                    lappend ::result "D::p $this"
                }
                virtual proc q {this}
                virtual proc r {this} {
                    lappend ::result "D::r $this"
                }
            }
            class E {
                proc E {this} C::D {} {}
                proc ~E {this} {}
                proc p {this} {
                    lappend ::result "E::p $this"
                }
                proc q {this} {
                    lappend ::result "E::q $this"
                }
            }
            set o [new E]
            D::p $o
            D::q $o
            D::r $o
            E::p $o
            E::q $o
            delete $o
            catch {D::p $o} message; lappend ::result $message
            catch {D::q $o} message; lappend ::result $message
            catch {D::r $o} message; lappend ::result $message
            catch {E::p $o} message; lappend ::result $message
            catch {E::q $o} message; lappend ::result $message
        }
        set o [new C::E]
        C::D::p $o
        C::D::q $o
        C::D::r $o
        C::E::p $o
        C::E::q $o
        delete $o
        catch {C::D::p $o} message; lappend ::result $message
        catch {C::D::q $o} message; lappend ::result $message
        catch {C::D::r $o} message; lappend ::result $message
        catch {C::E::p $o} message; lappend ::result $message
        catch {C::E::q $o} message; lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {b::p 1}\
    {b::q 1}\
    {a::r 1}\
    {b::p 1}\
    {b::q 1}\
    {1 is not a valid object identifier}\
    {1 is not a valid object identifier}\
    {1 is not a valid object identifier}\
    {1 is not a valid object identifier}\
    {1 is not a valid object identifier}\
    {B::p 2}\
    {B::q 2}\
    {A::r 2}\
    {B::p 2}\
    {B::q 2}\
    {2 is not a valid object identifier}\
    {2 is not a valid object identifier}\
    {2 is not a valid object identifier}\
    {2 is not a valid object identifier}\
    {2 is not a valid object identifier}\
    {e::p 3}\
    {e::q 3}\
    {d::r 3}\
    {e::p 3}\
    {e::q 3}\
    {3 is not a valid object identifier}\
    {3 is not a valid object identifier}\
    {3 is not a valid object identifier}\
    {3 is not a valid object identifier}\
    {3 is not a valid object identifier}\
    {E::p 4}\
    {E::q 4}\
    {D::r 4}\
    {E::p 4}\
    {E::q 4}\
    {4 is not a valid object identifier}\
    {4 is not a valid object identifier}\
    {4 is not a valid object identifier}\
    {4 is not a valid object identifier}\
    {4 is not a valid object identifier}\
    {E::p 5}\
    {E::q 5}\
    {D::r 5}\
    {E::p 5}\
    {E::q 5}\
    {5 is not a valid object identifier}\
    {5 is not a valid object identifier}\
    {5 is not a valid object identifier}\
    {5 is not a valid object identifier}\
    {5 is not a valid object identifier}\
]

test stooop-85 {
    verify pure interface class object creation in procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            lappend ::result "a::a $this"
        }
        proc a::~a {this} {}
        virtual proc a::p {this} {}
        set o [new a]
        delete $o
        virtual proc a::q {this}
        catch {new a} message
        lappend ::result $message

        class A {
            proc A {this} {
                lappend ::result "A::A $this"
            }
            proc ~A {this} {}
            virtual proc p {this} {}
        }
        set o [new A]
        delete $o
        class A {
            virtual proc q {this}
        }
        catch {new A} message
        lappend ::result $message

        class b {}
        class b::c {}
        proc b::c::c {this} {
            lappend ::result "c::c $this"
        }
        proc b::c::~c {this} {}
        virtual proc b::c::p {this} {}
        set o [new b::c]
        delete $o
        virtual proc b::c::q {this}
        catch {new b::c} message
        lappend ::result $message

        class B {
            class C {
                proc C {this} {
                    lappend ::result "C::C $this"
                }
                proc ~C {this} {}
                virtual proc p {this} {}
            }
            set o [new C]
            delete $o
            class C {
                virtual proc q {this}
            }
            catch {new C} message
            lappend ::result $message
        }
        catch {new B::C} message
        lappend ::result $message

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::a 1}\
    {class ::a with pure virtual procedures should not be instanciated}\
    {A::A 2}\
    {class ::A with pure virtual procedures should not be instanciated}\
    {c::c 3}\
    {class ::b::c with pure virtual procedures should not be instanciated}\
    {C::C 4}\
    {class ::B::C with pure virtual procedures should not be instanciated}\
    {class ::B::C with pure virtual procedures should not be instanciated}\
]

test stooop-86 {
    verify member writing and unsetting within class procedures in member data
    checking mode
    (it seems that unset tracing prevents error reporting at this time (bug?))
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKDATA) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        proc a::p {this} {
            set b::($this,m) 0
        }
        proc a::q {this} {
            set b::(n) 0
        }
        proc a::r {this} {
            unset b::($this,m)
        }
        proc a::s {this} {
            unset b::(n)
        }
        set o [new a]
        class b {}
        set b::($o,m) 0
        set b::(n) 0
        catch {a::p $o} message; lappend ::result $message
        catch {a::q $o} message; lappend ::result $message
        catch {a::r $o} message; lappend ::result bug
        catch {a::s $o} message; lappend ::result bug
        delete $o

        class A {
            proc A {this} {}
            proc ~A {this} {}
            proc p {this} {
                set B::($this,m) 0
            }
            proc q {this} {
                set B::(n) 0
            }
            proc r {this} {
                unset B::($this,m)
            }
            proc s {this} {
                unset B::(n)
            }
        }
        set o [new A]
        class B {
            set ($o,m) 0
            set (n) 0
        }
        class A {
            catch {p $o} message; lappend ::result $message
            catch {q $o} message; lappend ::result $message
            catch {r $o} message; lappend ::result bug
            catch {s $o} message; lappend ::result bug
        }
        delete $o

        class c {}
        class c::d {}
        proc c::d::d {this} {}
        proc c::d::~d {this} {}
        proc c::d::p {this} {
            set c::e::($this,m) 0
        }
        proc c::d::q {this} {
            set c::e::(n) 0
        }
        proc c::d::r {this} {
            unset c::e::($this,m)
        }
        proc c::d::s {this} {
            unset c::e::(n)
        }
        class c::e {}
        set o [new c::d]
        set c::e::($o,m) 0
        set c::e::(n) 0
        catch {c::d::p $o} message; lappend ::result $message
        catch {c::d::q $o} message; lappend ::result $message
        catch {c::d::r $o} message; lappend ::result bug
        catch {c::d::s $o} message; lappend ::result bug
        delete $o

        class C {
            class D {
                proc D {this} {}
                proc ~D {this} {}
                proc p {this} {
                    set C::E::($this,m) 0
                }
                proc q {this} {
                    set C::E::(n) 0
                }
                proc r {this} {
                    unset C::E::($this,m)
                }
                proc s {this} {
                    unset C::E::(n)
                }
            }
            set ::o [new D]
            class E {
                set ($o,m) 0
                set (n) 0
            }
            class D {
                catch {p $o} message; lappend ::result $message
                catch {q $o} message; lappend ::result $message
                catch {r $o} message; lappend ::result bug
                catch {s $o} message; lappend ::result bug
            }
        }
        catch {C::D::p $o} message; lappend ::result $message
        catch {C::D::q $o} message; lappend ::result $message
        catch {C::D::r $o} message; lappend ::result bug
        catch {C::D::s $o} message; lappend ::result bug
        delete $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {can't set "b::(1,m)": class access violation in procedure ::a::p}\
    {can't set "b::(n)": class access violation in procedure ::a::q}\
    bug\
    bug\
    {can't set "B::(2,m)": class access violation in procedure ::A::p}\
    {can't set "B::(n)": class access violation in procedure ::A::q}\
    bug\
    bug\
    {can't set "c::e::(3,m)": class access violation in procedure ::c::d::p}\
    {can't set "c::e::(n)": class access violation in procedure ::c::d::q}\
    bug\
    bug\
    {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\
    {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\
    bug\
    bug\
    {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\
    {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\
    bug\
    bug\
]

test stooop-87 {
    verify member writing and unsetting within class namespaces in member data
    checking mode
    (it seems that unset tracing prevents error reporting at this time (bug?))
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKDATA) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {
            set (m) 0
        }
        proc a::a {this} {
            set ($this,n) 0
        }
        proc a::~a {this} {}
        set o [new a]
        catch {class b {incr a::(m)}} message; lappend ::result $message
        catch {class b {incr a::($o,n)}} message; lappend ::result $message
        catch {class b {unset a::(m)}} message; lappend ::result bug
        catch {class b {unset a::($o,n)}} message; lappend ::result bug
        delete $o

        class A {
            set (m) 0
            proc A {this} {
                set ($this,n) 0
            }
            proc ~A {this} {}
        }
        set o [new A]
        class B {
            catch {incr A::(m)} message; lappend ::result $message
            catch {incr A::($o,n)} message; lappend ::result $message
            catch {unset A::(m)} message; lappend ::result bug
            catch {unset A::($o,n)} message; lappend ::result bug
        }
        delete $o

        class c {}
        class c::d {
            set (m) 0
        }
        proc c::d::d {this} {
            set ($this,n) 0
        }
        proc c::d::~d {this} {}
        set o [new c::d]
        catch {class c::e {incr c::d::(m)}} message; lappend ::result $message
        catch {class c::e {incr c::d::($o,n)}} message; lappend ::result $message
        catch {class c::e {unset c::d::(m)}} message; lappend ::result bug
        catch {class c::e {unset c::d::($o,n)}} message; lappend ::result bug
        delete $o

        class C {
            class D {
                set (m) 0
                proc D {this} {
                    set ($this,n) 0
                }
                proc ~D {this} {}
            }
            set ::o [new D]
            class B {
                catch {incr C::D::(m)} message; lappend ::result $message
                catch {incr C::D::($o,n)} message; lappend ::result $message
                catch {unset C::D::(m)} message; lappend ::result bug
                catch {unset C::D::($o,n)} message; lappend ::result bug
            }
        }
        catch {incr C::D::(m)} message; lappend ::result $message
        catch {incr C::D::($o,n)} message; lappend ::result $message
        catch {unset C::D::(m)} message; lappend ::result bug
        catch {unset C::D::($o,n)} message; lappend ::result bug
        delete $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {can't set "a::(m)": class access violation in class b namespace}\
    {can't set "a::(1,n)": class access violation in class b namespace}\
    bug\
    bug\
    {can't set "A::(m)": class access violation in class B namespace}\
    {can't set "A::(2,n)": class access violation in class B namespace}\
    bug\
    bug\
    {can't set "c::d::(m)": class access violation in class c::e namespace}\
    {can't set "c::d::(3,n)": class access violation in class c::e namespace}\
    bug\
    bug\
    {can't set "C::D::(m)": class access violation in class C::B namespace}\
    {can't set "C::D::(4,n)": class access violation in class C::B namespace}\
    bug\
    bug\
    {can't read "C::D::(m)": no such element in array}\
    {can't read "C::D::(4,n)": no such element in array}\
    bug\
    bug\
]

test stooop-88 {
    verify that object copying still works in member data checking mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKDATA) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            set ($this,n) 0
        }
        new [new a]

        class A {
            proc A {this} {
                set ($this,n) 0
            }
        }
        new [new A]

        class b {}
        class b::c {}
        proc b::c::c {this} {
            set ($this,n) 0
        }
        new [new b::c]

        class B {
            class C {
                proc C {this} {
                    set ($this,n) 0
                }
            }
            new [new C]
        }
        new [new B::C]

        set ::result {}
    }]
    interp delete $interpreter
    set result
} {}

test stooop-89 {
    verify both data and procedure static access in member data checking mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKDATA) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {
            set (m) 0
        }
        proc a::a {this} {
            set ($this,n) 0
        }
        proc a::~a {this} {}
        proc a::p {this} {
            incr (m)
            incr b::(o)
        }
        proc a::q {object} {
            incr ($object,n)
            incr b::($object,p)
        }
        class b {
            set (o) 0
        }
        proc b::b {this} a {} {
            set ($this,p) 0
        }
        proc b::~b {this} {}
        proc b::r {this} {
            incr (o)
            incr a::(m)
        }
        proc b::s {object} {
            incr ($object,p)
            incr a::($object,n)
        }
        set o [new b]
        catch {a::p $o} message; lappend ::result $message
        catch {a::q $o} message; lappend ::result $message
        catch {b::r $o} message; lappend ::result $message
        catch {b::s $o} message; lappend ::result $message
        delete $o

        class A {
            set (m) 0
            proc A {this} {
                set ($this,n) 0
            }
            proc ~A {this} {}
            proc p {this} {
                incr (m)
                incr B::(o)
            }
            proc q {object} {
                incr ($object,n)
                incr B::($object,p)
            }
        }
        class B {
            set (o) 0
            proc B {this} A {} {
                set ($this,p) 0
            }
            proc ~B {this} {}
            proc r {this} {
                incr (o)
                incr A::(m)
            }
            proc s {object} {
                incr ($object,p)
                incr A::($object,n)
            }
        }
        set o [new B]
        catch {A::p $o} message; lappend ::result $message
        catch {A::q $o} message; lappend ::result $message
        catch {B::r $o} message; lappend ::result $message
        catch {B::s $o} message; lappend ::result $message
        delete $o

        class c {}
        class c::d {
            set (m) 0
        }
        proc c::d::d {this} {
            set ($this,n) 0
        }
        proc c::d::~d {this} {}
        proc c::d::p {this} {
            incr (m)
            incr c::e::(o)
        }
        proc c::d::q {object} {
            incr ($object,n)
            incr c::e::($object,p)
        }
        class c::e {
            set (o) 0
        }
        proc c::e::e {this} c::d {} {
            set ($this,p) 0
        }
        proc c::e::~e {this} {}
        proc c::e::r {this} {
            incr (o)
            incr c::d::(m)
        }
        proc c::e::s {object} {
            incr ($object,p)
            incr c::d::($object,n)
        }
        set o [new c::e]
        catch {c::d::p $o} message; lappend ::result $message
        catch {c::d::q $o} message; lappend ::result $message
        catch {c::e::r $o} message; lappend ::result $message
        catch {c::e::s $o} message; lappend ::result $message
        delete $o

        class C {
            class D {
                set (m) 0
                proc D {this} {
                    set ($this,n) 0
                }
                proc ~D {this} {}
                proc p {this} {
                    incr (m)
                    incr C::E::(o)
                }
                proc q {object} {
                    incr ($object,n)
                    incr C::E::($object,p)
                }
            }
            class E {
                set (o) 0
                proc E {this} C::D {} {
                    set ($this,p) 0
                }
                proc ~E {this} {}
                proc r {this} {
                    incr (o)
                    incr C::D::(m)
                }
                proc s {object} {
                    incr ($object,p)
                    incr C::D::($object,n)
                }
            }
            set ::o [new E]
            catch {D::p $o} message; lappend ::result $message
            catch {D::q $o} message; lappend ::result $message
            catch {E::r $o} message; lappend ::result $message
            catch {E::s $o} message; lappend ::result $message
        }
        catch {C::D::p $o} message; lappend ::result $message
        catch {C::D::q $o} message; lappend ::result $message
        catch {C::E::r $o} message; lappend ::result $message
        catch {C::E::s $o} message; lappend ::result $message
        delete $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {can't set "b::(o)": class access violation in procedure ::a::p}\
    {can't set "b::(1,p)": class access violation in procedure ::a::q}\
    {can't set "a::(m)": class access violation in procedure ::b::r}\
    {can't set "a::(1,n)": class access violation in procedure ::b::s}\
    {can't set "B::(o)": class access violation in procedure ::A::p}\
    {can't set "B::(2,p)": class access violation in procedure ::A::q}\
    {can't set "A::(m)": class access violation in procedure ::B::r}\
    {can't set "A::(2,n)": class access violation in procedure ::B::s}\
    {can't set "c::e::(o)": class access violation in procedure ::c::d::p}\
    {can't set "c::e::(3,p)": class access violation in procedure ::c::d::q}\
    {can't set "c::d::(m)": class access violation in procedure ::c::e::r}\
    {can't set "c::d::(3,n)": class access violation in procedure ::c::e::s}\
    {can't set "C::E::(o)": class access violation in procedure ::C::D::p}\
    {can't set "C::E::(4,p)": class access violation in procedure ::C::D::q}\
    {can't set "C::D::(m)": class access violation in procedure ::C::E::r}\
    {can't set "C::D::(4,n)": class access violation in procedure ::C::E::s}\
    {can't set "C::E::(o)": class access violation in procedure ::C::D::p}\
    {can't set "C::E::(4,p)": class access violation in procedure ::C::D::q}\
    {can't set "C::D::(m)": class access violation in procedure ::C::E::r}\
    {can't set "C::D::(4,n)": class access violation in procedure ::C::E::s}\
]

test stooop-90 {
    verify member data checking when "array set" is used
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKDATA) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        proc a::p {this} {
            array set b:: "$this,m 0"
        }
        proc a::q {this} {
            array set b:: {n 0}
        }
        set o [new a]
        class b {}
        array set b:: "$o,m 0 n 0"
        catch {a::p $o} message; lappend ::result $message
        catch {a::q $o} message; lappend ::result $message
        delete $o

        class A {
            proc A {this} {}
            proc ~A {this} {}
            proc p {this} {
                array set B:: "$this,m 0"
            }
            proc q {this} {
                array set B:: {n 0}
            }
        }
        set o [new A]
        class B {
            array set B:: "$o,m 0 n 0"
        }
        class A {
            catch {p $o} message; lappend ::result $message
            catch {q $o} message; lappend ::result $message
        }
        delete $o

        class c {}
        class c::d {}
        proc c::d::d {this} {}
        proc c::d::~d {this} {}
        proc c::d::p {this} {
            array set c::e:: "$this,m 0"
        }
        proc c::d::q {this} {
            array set c::e:: {n 0}
        }
        class c::e {}
        set o [new c::d]
        array set c::e:: "$o,m 0 n 0"
        catch {c::d::p $o} message; lappend ::result $message
        catch {c::d::q $o} message; lappend ::result $message
        delete $o

        class C {
            class D {
                proc D {this} {}
                proc ~D {this} {}
                proc p {this} {
                    array set C::E:: "$this,m 0"
                }
                proc q {this} {
                    array set C::E:: {n 0}
                }
            }
            set ::o [new D]
            class E {
                array set C::E:: "$o,m 0 n 0"
            }
            class D {
                catch {p $o} message; lappend ::result $message
                catch {q $o} message; lappend ::result $message
            }
        }
        catch {C::D::p $o} message; lappend ::result $message
        catch {C::D::q $o} message; lappend ::result $message
        delete $o

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {can't set "b::(1,m)": class access violation in procedure ::a::p}\
    {can't set "b::(n)": class access violation in procedure ::a::q}\
    {can't set "B::(2,m)": class access violation in procedure ::A::p}\
    {can't set "B::(n)": class access violation in procedure ::A::q}\
    {can't set "c::e::(3,m)": class access violation in procedure ::c::d::p}\
    {can't set "c::e::(n)": class access violation in procedure ::c::d::q}\
    {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\
    {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\
    {can't set "C::E::(4,m)": class access violation in procedure ::C::D::p}\
    {can't set "C::E::(n)": class access violation in procedure ::C::D::q}\
]

test stooop-91 {
    verify that packaged class works even in debugging mode
} {
    makeDirectory 91
    makeFile {package ifneeded 91 1 [list tclPkgSetup $dir 91 1 {{p.tcl source {::a::_copy ::a::a}}}]}\
        [file join 91 pkgIndex.tcl]
    makeFile {package provide 91 1; class a {proc a {this} {}}}\
        [file join 91 p.tcl]
    set interpreter [interp create]
    $interpreter eval {
        # search in test directory sub-directories:
        lappend auto_path [file dirname [info script]]
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        package require 91
        new a
        set ::result {}
    }]
    interp delete $interpreter
    set result
} {}

test stooop-92 {
    check that parameter passing by reference works with virtual declarations
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        virtual proc a::f {this a} {}
        virtual proc a::g {this a}
        virtual proc a::h {this a} {
            upvar $a d
            set d(0) 0
        }
        virtual proc a::i {this a} {}
        virtual proc a::j {this a}
        virtual proc a::k {this a} {}
        class b {}
        proc b::b {this} a {} {}
        proc b::~b {this} {}
        proc b::f {this a} {
            upvar $a d
            set d(1) 1
        }
        proc b::g {this a} {
            upvar $a d
            set d(2) 2
        }
        virtual proc b::i {this a} {}
        virtual proc b::j {this a}
        virtual proc b::k {this a} {
            upvar $a d
            set d(3) 3
        }
        class c {}
        proc c::c {this} b {} {}
        proc c::~c {this} {}
        proc c::i {this a} {
            upvar $a d
            set d(4) 4
        }
        proc c::j {this a} {
            upvar $a d
            set d(5) 5
        }
        set o [new c]
        a::f $o z
        a::g $o z
        a::h $o z
        a::i $o z
        a::j $o z
        a::k $o z
        eval lappend ::result [dumpArrays z]

        class A {
            proc A {this} {}
            proc ~A {this} {}
            virtual proc f {this a} {}
            virtual proc g {this a}
            virtual proc h {this a} {
                upvar $a d
                set d(0) 0
            }
            virtual proc i {this a} {}
            virtual proc j {this a}
            virtual proc k {this a} {}
        }
        class B {
            proc B {this} A {} {}
            proc ~B {this} {}
            proc f {this a} {
                upvar $a d
                set d(1) 1
            }
            proc g {this a} {
                upvar $a d
                set d(2) 2
            }
            virtual proc i {this a} {}
            virtual proc j {this a}
            virtual proc k {this a} {
                upvar $a d
                set d(3) 3
            }
        }
        class C {
            proc C {this} B {} {}
            proc ~C {this} {}
            proc i {this a} {
                upvar $a d
                set d(4) 4
            }
            proc j {this a} {
                upvar $a d
                set d(5) 5
            }
        }
        set o [new C]
        A::f $o Z
        A::g $o Z
        A::h $o Z
        A::i $o Z
        A::j $o Z
        A::k $o Z
        eval lappend ::result [dumpArrays Z]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {z(0) = 0}\
    {z(1) = 1}\
    {z(2) = 2}\
    {z(3) = 3}\
    {z(4) = 4}\
    {z(5) = 5}\
    {Z(0) = 0}\
    {Z(1) = 1}\
    {Z(2) = 2}\
    {Z(3) = 3}\
    {Z(4) = 4}\
    {Z(5) = 5}\
]

test stooop-93 {
    check that member procedure invocation within constructor does not break
    procedure checking debug mode
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKPROCEDURES) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    set result [$interpreter eval {
        class a {}
        proc a::a {this} {
            p $this
            q
        }
        proc a::~a {this} {}
        proc a::p {this} {}
        proc a::q {} {}
        new a

        class A {
            proc A {this} {
                p $this
                q
            }
            proc ~A {this} {}
            proc p {this} {}
            proc q {} {}
        }
        new A

        class b {}
        class b::c {}
        proc b::c::c {this} {
            p $this
            q
        }
        proc b::c::~c {this} {}
        proc b::c::p {this} {}
        proc b::c::q {} {}
        new b::c

        class B {
            class C {
                proc C {this} {
                    p $this
                    q
                }
                proc ~C {this} {}
                proc p {this} {}
                proc q {} {}
            }
        }
        new B::C

        set ::result {}
    }]
    interp delete $interpreter
    set result
} {}

test stooop-94 {
    basic objects checking
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        proc p {} {
            new a
        }
        namespace eval n {
            proc p {} {
                new a
            }
        }
        stooop::record
        new a
        stooop::report
        p
        stooop::report
        n::p
        stooop::report
        stooop::record
        delete 1
        stooop::report
        delete 2
        stooop::report
        delete 3
        stooop::report

        class A {
            proc A {this} {}
            proc ~A {this} {}
        }
        proc q {} {
            new A
        }
        namespace eval m {
            proc q {} {
                new A
            }
        }
        stooop::record
        new A
        stooop::report
        q
        stooop::report
        m::q
        stooop::report
        stooop::record
        delete 4
        stooop::report
        delete 5
        stooop::report
        delete 6
        stooop::report
    }
    interp delete $interpreter
    set result
} [list\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + top level}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + top level}\
    {+ ::a(2) + ::p}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + top level}\
    {+ ::a(2) + ::p}\
    {+ ::a(3) + ::n::p}\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {- ::a(1) - top level + top level}\
    {stooop::report invoked from top level:}\
    {- ::a(1) - top level + top level}\
    {- ::a(2) - top level + ::p}\
    {stooop::report invoked from top level:}\
    {- ::a(1) - top level + top level}\
    {- ::a(2) - top level + ::p}\
    {- ::a(3) - top level + ::n::p}\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {+ ::A(4) + top level}\
    {stooop::report invoked from top level:}\
    {+ ::A(4) + top level}\
    {+ ::A(5) + ::q}\
    {stooop::report invoked from top level:}\
    {+ ::A(4) + top level}\
    {+ ::A(5) + ::q}\
    {+ ::A(6) + ::m::q}\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {- ::A(4) - top level + top level}\
    {stooop::report invoked from top level:}\
    {- ::A(4) - top level + top level}\
    {- ::A(5) - top level + ::q}\
    {stooop::report invoked from top level:}\
    {- ::A(4) - top level + top level}\
    {- ::A(5) - top level + ::q}\
    {- ::A(6) - top level + ::m::q}\
]

test stooop-95 {
    objects checking from namespace body and namespace procedure
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class a {
            proc a {this} {}
            proc ~a {this} {}
        }
        namespace eval n {
            proc p {} {
                new a
            }
            namespace eval m {
                proc q {} {
                    new a
                }
            }
        }
        stooop::record
        namespace eval n {
            new a
        }
        stooop::report
        n::p
        stooop::report
        namespace eval n::m {
            new a
        }
        stooop::report
        n::m::q
        stooop::report
        delete 1 2 3 4
    }
    interp delete $interpreter
    set result
} [list\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + namespace ::n}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + namespace ::n}\
    {+ ::a(2) + ::n::p}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + namespace ::n}\
    {+ ::a(2) + ::n::p}\
    {+ ::a(3) + namespace ::n::m}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + namespace ::n}\
    {+ ::a(2) + ::n::p}\
    {+ ::a(3) + namespace ::n::m}\
    {+ ::a(4) + ::n::m::q}\
]

test stooop-96 {
    objects checking from within derived class constructor
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class a {
            proc a {this i} {}
            proc ~a {this} {}
        }
        class b {
            proc b {this} a {[new c]} {}
            proc ~b {this} {}
        }
        class c {
            proc c {this} {}
            proc ~c {this} {}
        }
        stooop::record
        new b
        stooop::report

        class A {
            class a {
                proc a {this i} {}
                proc ~a {this} {}
            }
            class b {
                proc b {this} a {[new c]} {}
                proc ~b {this} {}
            }
            class c {
                proc c {this} {}
                proc ~c {this} {}
            }
            stooop::record
            new b
            stooop::report
        }

    }
    interp delete $interpreter
    set result
} [list\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {+ ::b(1) + top level}\
    {+ ::c(2) + ::b::b}\
    {stooop::record invoked from namespace ::A}\
    {stooop::report invoked from namespace ::A:}\
    {+ ::A::b(3) + namespace ::A}\
    {+ ::c(4) + ::A::b::b}\
]

test stooop-97 {
    objects checking with debugging procedures invocation from namespace body
    and namespace procedure
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class a {
            proc a {this} {}
            proc ~a {this} {}
        }
        namespace eval n {
            proc p {} {
                stooop::record
                new a
                stooop::report
            }
            namespace eval m {
                proc q {} {
                    stooop::record
                    new a
                    stooop::report
                }
            }
        }
        n::p
        n::m::q
        namespace eval n {
            stooop::record
            new a
            stooop::report
        }

    }
    interp delete $interpreter
    set result
} [list\
    {stooop::record invoked from ::n::p}\
    {stooop::report invoked from ::n::p:}\
    {+ ::a(1) + ::n::p}\
    {stooop::record invoked from ::n::m::q}\
    {stooop::report invoked from ::n::m::q:}\
    {+ ::a(2) + ::n::m::q}\
    {stooop::record invoked from namespace ::n}\
    {stooop::report invoked from namespace ::n:}\
    {+ ::a(3) + namespace ::n}\
]

test stooop-98 {
    objects checking with missing and extra objects
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class a {
            proc a {this} {}
            proc ~a {this} {}
        }
        stooop::record
        set o [new a]
        stooop::report
        stooop::record
        delete $o
        stooop::report

    }
    interp delete $interpreter
    set result
} [list\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {+ ::a(1) + top level}\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {- ::a(1) - top level + top level}\
]

test stooop-99 {
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class a {}
        proc a::a {this} {}
        proc a::~a {this} {}
        proc p {} {
            new a
        }
        namespace eval n {
            proc p {} {
                new a
            }
        }
        stooop::printObjects
        new a
        stooop::printObjects
        p
        stooop::printObjects
        n::p
        stooop::printObjects
        delete 1
        stooop::printObjects
        delete 2
        stooop::printObjects
        delete 3
        stooop::printObjects

        class A {
            proc A {this} {}
            proc ~A {this} {}
        }
        proc q {} {
            new A
        }
        namespace eval m {
            proc q {} {
                new A
            }
        }
        stooop::printObjects
        new A
        stooop::printObjects
        q
        stooop::printObjects
        m::q
        stooop::printObjects
        delete 4
        stooop::printObjects
        delete 5
        stooop::printObjects
        delete 6
        stooop::printObjects

    }
    interp delete $interpreter
    set result
} [list\
    {stooop::printObjects invoked from top level:}\
    {stooop::printObjects invoked from top level:}\
    {::a(1) + top level}\
    {stooop::printObjects invoked from top level:}\
    {::a(1) + top level}\
    {::a(2) + ::p}\
    {stooop::printObjects invoked from top level:}\
    {::a(1) + top level}\
    {::a(2) + ::p}\
    {::a(3) + ::n::p}\
    {stooop::printObjects invoked from top level:}\
    {::a(2) + ::p}\
    {::a(3) + ::n::p}\
    {stooop::printObjects invoked from top level:}\
    {::a(3) + ::n::p}\
    {stooop::printObjects invoked from top level:}\
    {stooop::printObjects invoked from top level:}\
    {stooop::printObjects invoked from top level:}\
    {::A(4) + top level}\
    {stooop::printObjects invoked from top level:}\
    {::A(4) + top level}\
    {::A(5) + ::q}\
    {stooop::printObjects invoked from top level:}\
    {::A(4) + top level}\
    {::A(5) + ::q}\
    {::A(6) + ::m::q}\
    {stooop::printObjects invoked from top level:}\
    {::A(5) + ::q}\
    {::A(6) + ::m::q}\
    {stooop::printObjects invoked from top level:}\
    {::A(6) + ::m::q}\
    {stooop::printObjects invoked from top level:}\
]

test stooop-100 {
    objects checking pattern matching
} {
    set interpreter [interp create]
    $interpreter eval {
        # reset any existing environment variables:
        foreach name [array names env STOOOP*] {unset env($name)}
        set env(STOOOPCHECKOBJECTS) 1
    }
    $interpreter eval "source $source; namespace import stooop::*"
    # alias puts to be able to collect standard output data:
    proc appendResult {string} {lappend ::result $string}
    $interpreter alias puts appendResult
    set result {}
    $interpreter eval {
        class aa {
            proc aa {this} {}
            proc ~aa {this} {}
        }
        class ab {
            proc ab {this} {}
            proc ~ab {this} {}
        }
        class bb {
            proc bb {this} {}
            proc ~bb {this} {}
        }
        stooop::record
        new aa
        new ab
        new bb
        stooop::printObjects ::a*
        stooop::printObjects ::*b
        stooop::report ::a*
        stooop::report ::*b
        stooop::record
        delete 1 2 3
        stooop::report ::a*
        stooop::report ::*b

    }
    interp delete $interpreter
    set result
} [list\
    {stooop::record invoked from top level}\
    {stooop::printObjects invoked from top level:}\
    {::aa(1) + top level}\
    {::ab(2) + top level}\
    {stooop::printObjects invoked from top level:}\
    {::ab(2) + top level}\
    {::bb(3) + top level}\
    {stooop::report invoked from top level:}\
    {+ ::aa(1) + top level}\
    {+ ::ab(2) + top level}\
    {stooop::report invoked from top level:}\
    {+ ::ab(2) + top level}\
    {+ ::bb(3) + top level}\
    {stooop::record invoked from top level}\
    {stooop::report invoked from top level:}\
    {- ::aa(1) - top level + top level}\
    {- ::ab(2) - top level + top level}\
    {stooop::report invoked from top level:}\
    {- ::ab(2) - top level + top level}\
    {- ::bb(3) - top level + top level}\
]

test stooop-101 {
    check that new lines within base class constructors arguments work without
    spacing
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p q} {
            set ($this,m) $p
            set ($this,n) $q
        }
        class b {}
        proc b::b {this p q r} a {
        $p
        $q
        } {
            set ($this,o) $r
        }
        new b {x y} z {1 2}
        eval lappend ::result [dumpArrays a:: b::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = x y}\
    {a::(1,n) = z}\
    {b::(1,o) = 1 2}\
]

test stooop-102 {
    check that new lines within base class constructors arguments work without
    spacing, with a DOS formatted file
} {
    set interpreter [interp create]
    $interpreter eval "source $source; namespace import stooop::*"
    $interpreter eval $dumpArraysCode
    set result [$interpreter eval {
        class a {}
        proc a::a {this p q} {
            set ($this,m) $p
            set ($this,n) $q
        }
        class b {}
        proc b::b {this p q r} a {
        $p
        $q
        } {
            set ($this,o) $r
        }
        new b {x y} z {1 2}
        eval lappend ::result [dumpArrays a:: b::]

        set ::result
    }]
    interp delete $interpreter
    set result
} [list\
    {a::(1,_derived) = ::b}\
    {a::(1,m) = x y}\
    {a::(1,n) = z}\
    {b::(1,o) = 1 2}\
]


cleanupTests
return
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/stooop/stooop_man.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
<!-- Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]> -->
<!--$Id: stooop_man.html,v 1.1 2003/04/01 19:39:06 andreas_kupries Exp $-->
<html lang="en">
<head>
   <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
   <title>stooop (Simple Tcl Only Object Oriented Programming)</title>
</head>
<body>

<center><h1>stooop</h1></center>

<center><h2>(Simple Tcl Only Object Oriented Programming)</h2></center>

Stooop is an extension to the great Tcl language written in Tcl itself. The object oriented features of stooop are modeled after the C++ programming language while following the Tcl language philosophy.

<h3>Contents</h3>

<ul>
  <li><a href="#about">About this document</a>
  <li><a href="#introduction">Introduction</a>
  <li><a href="#simple">Simple example</a>
  <li><a href="#conventions">Coding conventions</a><ul>
    <li><a href="#definition">Class definition</a>
    <li><a href="#procedures">Member procedures</a><ul>
      <li><a href="#constructor">Constructor</a>
      <li><a href="#destructor">Destructor</a>
      <li><a href="#proceduresnonstatic">Non static</a>
      <li><a href="#proceduresstatic">Static</a>
      <li><a href="#copy">Copy constructor</a>
    </ul>
    <li><a href="#data">Member data</a><ul>
      <li><a href="#datanonstatic">Non static</a>
      <li><a href="#datastatic">Static</a>
    </ul>
  </ul>
  <li><a href="#keywords">Commands</a><ul>
    <li><a href="#class">class</a>
    <li><a href="#new">new</a>
    <li><a href="#delete">delete</a>
    <li><a href="#virtual">virtual</a>
    <li><a href="#classof">classof</a>
  </ul>
  <li><a href="#package">Package</a><ul>
    <li><a href="#installation">Installation</a>
    <li><a href="#creation">Creation</a>
  </ul>
  <li><a href="#examples">Examples</a><ul>
    <li><a href="#parallel">Parallel with C++</a>
    <li><a href="#graphical">Graphical demonstration</a>
    <li><a href="#widget">Widget class</a>
    <li><a href="#array">Member array</a>
  </ul>
  <li><a href="#utility">Utility classes</a><ul>
    <li><a href="#switched">switched</a>
  </ul>
  <li><a href="#debugging">Debugging</a><ul>
    <li><a href="#check">member check</a><ul>
      <li><a href="#procedurecheck">procedure</a>
      <li><a href="#datacheck">data</a>
    </ul>
    <li><a href="#trace">member trace</a><ul>
      <li><a href="#proceduretrace">procedure</a>
      <li><a href="#datatrace">data</a>
    </ul>
    <li><a href="#objects">objects</a><ul>
      <li><a href="#objects.printing">printing</a>
      <li><a href="#objects.recording">recording</a>
      <li><a href="#objects.reporting">reporting</a>
    </ul>
  </ul>
  <li><a href="#notes">Notes</a><ul>
    <li><a href="#design">On design choices</a>
    <li><a href="#implementation">On implementation</a>
  </ul>
  <li><a href="#misc">Miscellaneous information</a>
</ul>

<h3><a name="about"></a>About this document</h3>

This document contains general information, reference information and many examples designed to help the programmer understand and use the stooop extension (version 4.1.1 and above).

<p>A working knowledge of object oriented programming techniques and a related programming language (C++, Java, ...) significantly helps understand this document.

<h3><a name="introduction"></a>Introduction</h3>

After some time writing Tcl/Tk code, I felt that I needed a way to improve the structure of my code, and why not use an object oriented approach, since I knew (but does anybody really? :-) C++. As I have used Tcl quite extensively in several commercial applications running on different operating systems and hardware, I decided to use a strict Tcl implementation for my object oriented extension. Consequently, stooop is compatible with all the Tcl ports (UNIX, Windows, MacIntosh).

<p>Great care was taken so that this extension would no adverse impact on performance. Furthermore, designing your code in an object oriented should improve its performance, by focusing on well written pieces of reusable code.

<p>Stooop only introduces a few new commands: <a href="#class">class</a>, <a href="#new">new</a>, <a href="#delete">delete</a>, <a href="#virtual">virtual</a> and <a href="#classof">classof</a>. Along with a few coding conventions, that is basically all you need to know to use stooop. Stooop is meant to be as simple to use as possible.

<p>Starting with stooop version 3.2, nested classes are supported (see <a href="#class">class</a>), whereas version 3.3 and above support procedure and data members checking as well as tracing (see <a href="#debugging">debugging</a>).

<p>Tcl version 8.2 and above supports the empty name array syntax, as in:

<pre>set (m) 0 ;# set member m of array {} to 0
set n $(m) ;# which actually sets n to 0</pre>

This feature greatly simplifies class member manipulation in stooop classes and significantly improves performance. Stooop version 4.0 and above also uses this feature internally for further improvements, without sacrificing backward compatibility: code written against stooop versions 3.7 and below still works with stooop version 4.0 and above, but can be gradually moved to the simpler syntax when convenient.<br>
Stooop 4.1 and above will only work out of the box with Tcl 8.3 and above.

<h3><a name="simple"></a>Simple example</h3>

Let us start with a code sample that will give you some feeling on how stooop works:

<pre>package require stooop 4                                  ;# load stooop package
namespace import stooop::*                ;# and import class, new, ... commands</pre>

<pre>class shape {                                           ;# base class definition
    proc shape {this x y} {                            ;# base class constructor
        set ($this,x) $x                           ;# data member initialization
        set ($this,y) $y
    }
    proc ~shape {this} {}                               ;# base class destructor
    # pure virtual draw: must be implemented in derived classes
    virtual proc draw {this}
    virtual proc rotate {this angle} {}                 ;# do nothing by default
}
proc shape::move {this x y} {            ;# external member procedure definition
    set ($this,x) $x
    set ($this,y) $y
    draw $this               ;# shape::draw invokes derived class implementation
}

class triangle {                                             ;# class definition
    proc triangle {this x y} shape {$x $y} {               ;# derived from shape
        # triangle constructor implementation
    }
    proc ~triangle {this} {}
    proc draw {this} {
        # triangle specific implementation
    }
    proc rotate {this angle} {
        # triangle specific implementation
    }
}

class circle {}        ;# empty class definition, procedures are defined outside
proc circle::circle {this x y} shape {$x $y} {             ;# derived from shape
    # circle constructor implementation
}
proc circle::~circle {this} {}
proc circle::draw {this} {
    # circle specific implementation
}
# circle::rotate procedure is a noop, no need to overload

lappend shapes [new circle 20 20] [new triangle 80 20]
foreach object $shapes {
    shape::draw $object
    shape::rotate $object 45
}
eval delete $shapes</pre>

<h3><a name="conventions"></a>Coding conventions</h3>

I have tried to make stooop Tcl code look like C++ code. There are exceptions of course.

<h4><a name="definition"></a>Class definition</h4>

The syntax is very simple:

<pre>class className { ...</pre>

<p>The member procedures are then defined, inside or outside the class definition (see below). Note that the base classes if any are defined within the constructor declaration where they are required for eventually passing constructor parameters, not in the actual class declaration where they would then be redundant.

<p>As a class is a namespace, it is just as easy to nest classes as it is namespaces.

<h4><a name="procedures"></a>Member procedures</h4>

They can be defined inside or outside their class definition. When defined inside the class definition, the class name qualifier (<i>shape::</i> for example) before the procedure name must be omitted (a class is a Tcl namespace). When defined outside the class definition, the class name qualifier must be present (same reason). You may notice that the class definition and the related member procedures look very much like the Tcl <i>namespace</i> feature: it is because classes are indeed namespaces with a few more features added to support object orientation.

<p>Member procedures are named as in C++ (for example, the <i>rotate</i> procedure of the class <i>shape</i> is referred to as <i>shape::rotate</i> in the global namespace). They are defined using the Tcl <i>proc</i> command, which is redefined by stooop in order to do some specific additional processing. Of course, global level and other namespaces procedures are not affected by stooop.

<h5><a name="constructor"></a>Constructor</h5>

A constructor is used to initialize an object of its class. The constructor is invoked by the <a href="#new">new</a> operator when an object of the class is created (instanciated in OO terms). The constructor is named as in C++ (for example, the <i>shape</i> constructor fully qualified name is <i>shape::shape</i>).

<p>The constructor always takes the object identifier (a unique value generated by the command new) as the first parameter, plus eventually additional parameters as in the normal Tcl proc command. Arguments with default values are allowed, and so are variable number of arguments (see below). In all cases, the first parameter must be named <b>this</b>.

<p><i><b>Note</b>: the object identifier is a unique integer value which is internally incremented by stooop each time a new object is created. Consequently, the greater the object identifier, the younger the object.</i>

<p>Sample code of a constructor of a simple class with no base class:

<pre>class shape {
    proc shape {this x y} {
        # implementation here
    }
}</pre>

If a class is derived from one or more base classes, the derived class constructor defines the base classes and their constructor arguments before the actual body of the constructor.

<p><i><b>Note</b>: base classes are not defined at the class command level, because it would be redundant with the constructor definition, which is mandatory.</i>

<p>The derived class constructor parameters are followed by "base class names / constructor arguments" pairs. For each base class, there must be a corresponding list of constructor arguments to be used when the object is constructed when the new operator is invoked with the derived class name as argument.

<p>Sample code for a class constructor with a single base class:

<pre>class circle {}
proc circle::circle {this x y} shape {$x $y} {
    # circle constructor implementation
}</pre>

Sample code for a class constructor with multiple base classes:

<pre>class hydroplane {
    proc hydroplane {this wingspan length} plane {
        $wingspan $length
    } boat {
        $length
    {
        # constructor implementation
    }
}</pre>

The base class constructor arguments must be prefixed with dollar signs since they will be evaluated at the time the object is constructed, right before the base class constructor is invoked. This technique allows, as in C++, some actual processing to be done on the base class arguments at construction time. The <b>this</b> argument to the base class constructor must not be specified for it is automatically generated by stooop.

<p>Sample code for a derived class constructor with base class constructor arguments processing:

<pre>class circle {
    proc circle {this x y} shape {
        [expr round($x)] [expr round($y)]
    } {
        # constructor implementation
    }
}</pre>

The base class(es) constructor(s) is(are) automatically invoked before the derived class constructor body is evaluated. Thus layered object construction occurs in the same order as in C++.

<p>Variable length arguments are a special case and depend on both the derived class constructor arguments and those of the base class.

<p>If both derived and base class constructors take a variable number of arguments (through the <i>args</i> special argument (see Tcl proc manual page)), the base class constructor will also see the variable arguments part as separate arguments. In other words, the following works as expected:

<pre>class base {}
proc base::base {this parameter args} {
    array set options $args
}
class derived {}
proc derived::derived {this parameter args} base {
    $parameter $args
} {}
new derived someData -option value -otherOption otherValue</pre>

Actually, if you want to get fancy, to allow some processing on the derived class constructor variable arguments, the last element (and only the last) of the derived class constructor arguments is considered variable if it contains the string <i>$args</i>. For example:

<pre>class base {
    proc base {this parameter args} {
        array set options $args
    }
}
class derived {
    proc derived {this parameter args} base {
        $parameter [process $args]
    } {}
    proc process {arguments} {
        # do some processing on arguments list
        return $arguments
    }
}
new derived someData -option value -otherOption otherValue</pre>

<h5><a name="destructor"></a>Destructor</h5>

The destructor is used to clean up an object before it is removed from memory. The destructor is invoked by the <a href="#delete">delete</a> operator when an object of the class is deleted. The destructor is named as in C++ (for example, the shape constructor fully qualified name is <i>shape::~shape</i>).

<p>The destructor always takes the object identifier (a unique value previously generated and returned by the operator new) as the only parameter, which must be named <b>this</b>.

<p>The base class(es) destructor(s) is(are) invoked at the end of the derived class destructor body. Thus layered object destruction occurs in the same order as in C++.

<p>Sample code of a class destructor:

<pre>class shape {
    proc ~shape {this} {
        # implementation here
    }
}</pre>

Contrary to C++, a destructor cannot (nor does it need to) be <a href="#virtual">virtual</a>. Even if it does nothing, a destructor <b>must</b> always be defined.

<h5><a name="proceduresnonstatic"></a>Non static</h5>

A <i>non static</i> member procedure performs some action on an object of a class. The member procedure is named as a member function in C++ (for example, the shape class move member procedure is known as <i>shape::move</i> in the Tcl global namespace).

<p>The member procedure always takes the object identifier (a unique value generated and returned by the operator new) as the first parameter, plus eventually additional parameters as in the normal Tcl proc command. Arguments with default values are allowed, and so are variable number of arguments. In all cases, the first parameter must be named <b>this</b>.

<p>Sample code of a member procedure:

<pre>proc shape::move {this x y} {
    set ($this,x) $x
    set ($this,y) $y
    draw $this       ;# invoke another member procedure
}</pre>

A non static member procedure may be a <a href="#virtual">virtual</a> procedure.

<h5><a name="proceduresstatic"></a>Static</h5>

A <i>static</i> member procedure performs some action independently of the individual objects of a class. The member procedure is named as a member function in C++ (for example, the shape class add static member procedure is defined as <i>shape::add</i> outside its class definition, <i>add</i> inside).

<p>However, with stooop, there is no static specifier: a member procedure is considered static if its first parameter is not named <b>this</b>. Arguments to the procedure are allowed as in the normal Tcl proc command. Arguments with default values are also allowed, and so are variable number of arguments.

<p>Sample code of a static member procedure:

<pre>proc shape::add {newShape} {
    # append new shape to global list of shape
    lappend ($shapes) $newShape
}</pre>

Often, static member procedures access static member data (see <a href="#datastatic">Static Member Data</a>).

<p>A static member procedure may not be a virtual procedure.

<h5><a name="copy"></a>Copy constructor</h5>

<i><b>Note</b>: if you never create objects by copying (which is generally the case), you can skip this section.</i>

<p>Let us start by making it clear that stooop generates a default copy constructor whenever a class main constructor is defined. This default copy constructor just performs a simple per data member copy, as does C++.

<p>The user defined class copy constructor is optional as in C++. If it exists, it will be invoked (instead of the default copy constructor) when the operator <a href="#new">new</a> is invoked on an object of the class or a derived class.

<p>The copy constructor takes 2 arguments: the <i>this</i> object identifier used to initialize the data members of the object to be copied to, and the <i>copy</i> identifier of the object to be copied from, as in:

<pre>proc plane::plane {this copy} {
    set ($this,wingspan) $($copy,wingspan)
    set ($this,length) $($copy,length)
    set ($this,engine) [new $($copy,engine)]
}</pre>

As in regular member procedures, the first parameter name must be <b>this</b>, whereas the second parameter must be named <b>copy</b> to differentiate from the class constructor. In other words, the copy constructor always takes 2 and only 2 arguments (named this and copy).

<p>The copy constructor must be defined when the default behavior (straightforward data members copy) (see the <a href="#new">new operator</a>) is not sufficient, as in the example above. It is most often used when the class object contains sub objects. As in C++ when sub objects are referenced through pointers, only the sub object identifiers (see them as pointers) are copied when an object is copied, not the objects they point to. It is then necessary to define a copy procedure that will actually create new sub objects instead of just defaulting to copying identifiers.

<p>If the class has one or more base classes, then the copy constructor must pass arguments to the base class(es) constructor(s), just as the main constructor does, as in the following example:

<pre>class ship {
    proc ship {this length} {}
}
class carrier {}
proc carrier::carrier {this length} ship {$length} {}
proc carrier::carrier {this copy} ship {
    $ship::($copy,length)
} {
    set ship::($this,planes) {}
    foreach plane $ship($copy,planes) {                   ;# copy all the planes
        lappend ship($this,planes) [new $plane]
    }
}</pre>

The stooop library checks that the copy constructor properly initializes the base class(es) through its(their) constructor(s) by using the regular constructor as reference. Obviously and consequently, stooop also checks that the regular constructor is defined prior to the copy constructor.

<p>If you use <a href="#array">member arrays</a>, you must copy them within the copy constructor, as they are not automatically handled by stooop, which only knows <a href="#data">member data</a> in the automatically generated default copy constructor.

<h4><a name="data"></a>Member data</h4>

All class and object data is stored in an associative array local to the class namespace (remember, a class is actually a namespace). The array name is empty, and the corresponding Tcl variable declaration is automatically inserted within class namespace and procedures (but you do not need to worry about this transparent operation).

<p>Sample code:

<pre>class shape {}
proc shape::shape {this x y} {
    # set a few members of the class namespace empty named array
    set ($this,x) $x
    set ($this,y) $y
    # now read them
    puts "coordinates: $($this,x), $($this,y)"
}</pre>
In order to access other classes data, whether they are base classes or
not, a fully qualified name is always required, whereas no special declaration
(global, variable, ...) is required.
<p>Sample code:
<pre>proc circle::circle {this x y diameter} shape {$x $y} {
    set ($this,diameter) $diameter
    puts "coordinates: $shape::($this,x), $shape::($this,y)"
}</pre>

<h5><a name="datanonstatic"></a>Non static</h5>

Non static data is indexed within the class array by prepending the object identifier (return value of the <i>new</i> operator) to the actual member name. A comma is used to separate the identifier and the member name.

<p>Much as an object pointer in C++ is unique, the object identifier in <i>stooop</i> is also unique. Access to any base class data is thus possible by directly indexing the base class array.

<p>Sample code:

<pre>proc shape::shape {this x y} {
    set ($this,x) $x
    set ($this,y) $y
}
proc circle::circle {this x y diameter} shape {$x $y} {
    set ($this,diameter) $diameter
}
proc circle::print {this} {
    puts "circle $this data:"
    puts "diameter: $($this,diameter)"
    puts "coordinates: $shape::($this,x), $shape::($this,y)"
}</pre>

<h5><a name="datastatic"></a>Static</h5>

<i>Static</i> (as in C++) data members are simply stored without prepending the object identifier to the member name, as in:

<pre>proc shape::register {newShape} {
    lappend (list) $newShape ;# append new shape to global list of shapes
}</pre>

<h3><a name="keywords"></a>Commands</h3>

Only 4 new commands <a href="#class">class</a>, <a href="#new">new</a>, <a href="#delete">delete</a> and <a href="#virtual">virtual</a> need to be known in order to use <i>stooop</i>. Furthermore, their meaning should be obvious to C++ programmers. There is also a <a href="#classof">classof</a> command that you can use if you need RTTI (runtime type identification).

<h4><a name="class"></a>class</h4>

The <b>class</b> command introduces a new class declaration.

<p>A class is also a namespace although you do not need to worry about it, but it does have some nice side effects. The following code works as expected:

<pre>class shape {
    set (list) {} ;# initialize list of shapes, a static data member
    proc shape {this x y} {
        lappend (list) $this             ;# keep track of new shapes
    }
    ...
}</pre>

This works because all data for the class (static and non static) is held in the empty named array, which the class command declares as a variable (see the corresponding Tcl command) for the class namespace and within every member procedure.

<p>Starting with version 3.2, nested classes are allowed, which makes the following code possible:

<pre>class car {
    proc car {this manufacturer type} {
        set ($this,wheels) [list\
            [new wheel 18] [new wheel 18] [new wheel 18] [new wheel 18]\
        ]
        ...
    }
    ...
    class part {
        ...
    }
    class wheel {
        proc wheel {this diameter} car::part {} {
            set ($this,diameter) $diameter
            ...
        }
        proc print {this} {
            puts "wheel of $($this,diameter) diameter"
        }
        ...
    }
}</pre>

There is quite a lot to say about the example above.

<p>First, why would I use a nested class? Because it is cleaner that creating <i>carPart</i> and <i>carWheel</i> classes and saves on global namespace pollution.

<p>Second, why does "<i>new wheel</i>" work from inside the car constructor? Because it invokes the <i>wheel::wheel</i> constructor, visible from the car namespace.

<p>Third, why can't I simply derive wheel from <i>part</i> instead of <i>car::part</i>? Well, you must fully qualify the class that you derive from because the <i>part::part</i> constructor is not visible from within the wheel namespace.

<p>Whenever you have a problem with nested classes, think in terms of namespaces, as classes are indeed namespaces (it should be clear to you by now :-).

<h4><a name="new"></a>new</h4>

The <i>new</i> operator is used to create an object of a class, either by explicit construction, or by copying an existing object.

<p>When explicitly creating an object, the first argument is the class name and is followed by the arguments needed by the class constructor. New when invoked generates a unique identifier for the object to be created. This identifier is the value of the <b>this</b> parameter, first argument to the class constructor, which is invoked by new.

<p>Sample code:

<pre>proc shape::shape {this x y} {
    set ($this,x) $x
    set ($this,y) $y
}
set object [<b>new</b> shape 100 50]</pre>

new generates a new object identifier, say 1234. shape constructor is then called, as in:

<pre>shape::shape 1234 100 50</pre>

If the class is derived from one or more base classes, the base class(es) constructor(s) will be automatically called in the proper order, as in:

<pre>proc hydroplane::hydroplane {this wingspan length} plane {
    $wingspan $length
} boat {
    $length
} {}
set object [<b>new</b> hydroplane 10 7]</pre>

new generates a new object identifier, say 1234, plane constructor is called, as in:

<pre>plane::plane 1234 10 7</pre>

then boat constructor is called, as in:

<p>boat::boat 1234 7

<p>finally hydroplane constructor is called, as in:

<p>hydroplane::hydroplane 1234 10 7

<p>The new operator can also be used to copy objects when an object identifier is its only argument. A new object of the same class is then created, copy of the original object.

<p>An object is copied by copying all its data members (but not including <a href="#array">member arrays</a>) starting from the base class layers. If the copy constructor procedure exists for any class layer, it is invoked by the <i>new</i> operator <b>instead</b> of the default data member copy procedure (see the <a href="#copy">copy constructor</a> section for examples).

<p>Sample code:

<pre>set plane [new plane 100 57 RollsRoyce]
set planes [list $plane [new $plane] [new $plane]]</pre>

<h4><a name="delete"></a>delete operator</h4>

The <i>delete</i> operator is used to delete one or several objects. It takes one or more object identifiers as argument(s). Each object identifier is the value returned by <i>new</i> when the object was created. Delete invokes the class destructor for each object to be deleted.

<p>Sample code:

<pre>proc shape::shape {this x y} {}
proc shape::~shape {this} {

proc triangle::triangle {this x y} shape {$x $y} {}
proc triangle::~triangle {this} {}

proc circle::circle {this x y} shape {$x $y} {}
proc circle::~circle {this} {}

set circle [new circle 100 50]
set triangle [new triangle 200 50]
<b>delete</b> $circle $triangle</pre>

circle identifier is set to, say 1234, triangle identifier is set to, say 1235. delete circle object first, circle destructor is invoked, as in:

<pre>circle::~circle 1234</pre>

then shape destructor is invoked, as in:

<p>shape::~shape 1234

<p>then delete triangle object...

<p>For each object class, if it is derived from one or more base classes, the base class(es) destructor(s) are automatically called in reverse order of the construction order for base class(es) constructor(s), as in C++.

<p>If an error occurs during the deletion process, an error is returned and the remaining delete argument objects are left undeleted.

<h4><a name="virtual"></a>virtual specifier</h4>

The <i>virtual</i> specifier may be used on member procedures to achieve dynamic binding. A procedure in a base class can then be redefined (overloaded) in the derived class(es).

<p>If the base class procedure is invoked on an object, it is actually the derived class procedure which is invoked, if it exists<b>*</b>. If the base class procedure has no body, then it is considered to be a pure virtual and the derived class procedure is always invoked.

<p><b>*</b> <i>as in C++, virtual procedures invoked from the base class constructor result in the base class procedure being invoked, not the derived class procedure. In stooop, an error always occurs when pure virtual procedures are invoked from the base class constructor (whereas in C++, behavior is undefined).</i><br>
<i>* but there is a small difference with C++ behavior: for a virtual procedure to keep his nature down the derived classes hierarchy, it must be defined at each derivation level. That is, the virtual nature may be lost, for example in indirectly derived classes (see example below). Fixing this difference would have a non negligible impact on performance for a small gain in usefulness.</i>

<p>Sample code:

<pre>class shape {
    proc shape {this x y} {}
    # pure virtual draw: must be implemented in derived classes
    <b>virtual</b> proc draw {this}
    <b>virtual</b> proc transform {this x y} {
        # base implementation
    }
}
class circle {}
proc circle::circle {this x y} shape {$x $y} {}
proc circle::draw {this} {
    # circle specific implementation
}
proc circle::transform {this} {
    shape::_transform $this ;# use base class implementation
    # add circle specific implementation here...
}

lappend shapes [new circle 100 50]
foreach object $shapes {
    # draw and move each shape
    shape::draw $object
    shape::move $object 20 10
}</pre>

It is possible to invoke a virtual procedure as a non virtual one, which is handy when the derived class procedure must use the base class procedure. In this case, directly invoking the virtual base class procedure would result in an infinite loop. The non virtual base class procedure name is simply the virtual procedure name with 1 underscore ( _ ) prepended to the member procedure name (see sample code above).

<p>Constructors, destructors and static member procedures cannot be <i>virtual</i>.

<p>Sample code highlighting small difference with C++:

<pre>class A {
    proc A {this} {}
    proc ~A {this} {}
    <b>virtual</b> proc p {this} {puts A}
}
class B {
    proc B {this} A {} {}
    proc ~B {this} {}
}
class C {
    proc C {this} B {}{}
    proc ~C {this} {}
    <b>virtual</b> proc p {this} {puts C}
}

set object [new C]
A::p $object ;# prints "A" instead of "C"

<b>virtual</b> proc B::p {this} {puts B}

A::p $object ;# now prints "C"</pre>

<h4><a name="classof"></a>classof operator</h4>

The <i>classof</i> command takes an object identifier as its only argument. It returns the class name of the object (name used with new when the object was created). Thus if needed, RTTI (runtime type identification) can be used as in C++, for example to create "virtual constructors".

<pre>proc shape::shape {this x y} {}
set id [new shape 100 50]
puts "object $id class name is [<b>classof</b> $id]"</pre>

<h3><a name="package"></a>Package</h3>

For general information about the Tcl (version 7.5 and above) <i>package</i> facilities, refer to the corresponding manual pages.

<h4><a name="installation"></a>Installation</h4>

A <i>pkgIndex.tcl</i> file is provided so that stooop and the <a href="#switched">switched</a> class can be installed as a package. Refer to the <a href="INSTALL">INSTALL</a> file for complete instructions and examples.

<h4><a name="creation"></a>Creation</h4>

Before creating a package that uses stooop, stooop itself <b>must</b> be installed as a package (see above).

<p>If you have created an object oriented library which uses stooop, you may want to make a package out of it. Unfortunately, using the default Tcl <i>pkg_mkIndex</i> procedure (see the corresponding manual page) will not work.

<p>Stooop checks that a base class constructor is defined before any of its derived classes constructors. Thus, the first time a derived class object is created, the base class definition file must be sourced to avoid an error. The specific <i>mkpkgidx.tcl</i> utility handles such cases and must be used to create stooop compatible package index files.

<p>Let us suppose that you created a library with different classes spread in different source files: <i>lib1.tcl</i>, <i>lib2.tcl</i>, ..., <i>libn.tcl</i>. Of course, some of these files may contain base classes for derived classes in other files. As recommended in the pkg_mkIndex Tcl manual page, each source file should contain a <b>package provide</b> command (although it seems to be needed only in the first source file). For example, if your package name is <i>foo</i> and the version <i>1.2</i>, the following line should appear around the beginning of each of the libn.tcl files:

<pre>package provide foo 1.2</pre>

It is now time to create the <i>pkgIndex.tcl</i> file, which is the missing piece for your foo package, with the <i>mkpkgidx.tcl</i> utility. The syntax is:

<pre>interpreter mkpkgidx.tcl packageName file [file ...]</pre>

where <i>interpreter</i> can be either tclsh or wish depending on whether your library uses Tk or not.

<p>Enter the following command in the directory where the libn.tcl files reside:

<pre>$ tclsh mkpkgidx.tcl foo lib1.tcl lib2.tcl ... libn.tcl</pre>

or

<pre>$ wish mkpkgidx.tcl foo lib1.tcl lib2.tcl ... libn.tcl</pre>

For this to work, the source files must be ordered so that base classes are defined before any of their derived classes. If not the case, such errors are automatically caught by the stooop package index utility, which uses the stooop library itself.

<p>If your package requires other packages and you do not wish to add the corresponding "package require" to your package source files, use the -p option, as in:

<pre>$ wish mkpkgidx.tcl -p ppp.1 -p qqq -p rrr.3.2 foo lib1.tcl lib2.tcl ... libn.tcl</pre>

Note that you may use as many -p option / value pairs as needed. Each package name is optionally followed by its version number after a . separator. If specified, the version number follows the same rules as the "package require" Tcl command. Of course, each specified package must be installed and working properly before attempting the mkpkgidx.tcl utility.

<p>Once this is done, a pkgIndex.tcl file will have been created in the current directory. To install the package, enter for example:

<pre>$ mkdir /usr/local/lib/foo
$ cp pkgIndex.tcl lib1.tcl lib2.tcl ... libn.tcl /usr/local/lib/foo/</pre>

You may of course install the foo package in another directory: refer to the pkg_mkIndex Tcl manual page for further instructions.

<p>Now in order to use your newly created packaged library in your application, just insert the following 3 lines at the beginning of the application source file:

<pre>package require stooop
namespace import stooop::*
package require foo 1.2</pre>

<h3><a name="examples"></a>Examples</h3>

<h4><a name="parallel"></a>Parallel with C++</h4>

For C++ programmers, this simple parallel with C++ may make things easier to understand. First without virtual functions:

<p><b>C++:</b>

<pre>    class className {
    public:
        someType someMember;
        className(someType parameter)
        {
            someMember = parameter;
        }
        className(className &amp;object)
        {
            ...
        }
        doSomething(someType parameter);
        ~className(void) {
            ...
        }
    };
    someType className::doSomething(someType parameter)
    {
        ...
    }
    someType someValue;
    className *someObject = new className(someValue);
    someType a = someObject->doSomething(someValue);
    someType b = someObject->someMember;
    className *otherObject = new className(*someObject);
    delete someObject;</pre>

<b>(stooop'd up :) Tcl:</b>

<pre>    class className {
        proc className {this parameter} {
            # new keeps track of object identifiers and passes a unique one
            # to the constructor
            set ($this,someMember) $parameter
        }
        proc className {this copy} {
            # copy constructor
            ...
        }
        proc ~className {this} {
            # delete invokes this procedure then takes care of deallocating
            # className array data members for this object identifier
            ...
        }
    }
    proc className::doSomething {this parameter} {
        ...
    }
    set someObject [new className $someValue]
    # invokes className::className
    set a [className::doSomething $someObject $someValue]
    set b $className::($someObject,someMember)
    # copy object, className copy constructor is invoked
    set otherObject [new $someObject]
    delete $someObject
    # invokes className::~className then frees members data</pre>

Now, with virtual functions:

<p><b>C++:</b>

<pre>    class baseClassName {
    public:
        virtual void doSomething(someType) {}
        baseClassName(void) {}
        virtual ~baseClassName(void) {}
    };
    class derivedClassName: public baseClassName {
    public:
        void doSomething(someType);
        derivedClassName(void) {}
        ~derivedClassName(void) {}
    };
    void derivedClassName::doSomething(someType parameter)
    {
        ...
    }
    derivedClassName *someObject = new derivedClassName();
    someObject->doSomething(someValue);      // derived function actually called
    cout &lt;&lt; typeid(*someObject).name() &lt;&lt; endl;       // print object class name
    delete someObject;                        // derived destructor called first</pre>

<b>Tcl with stooop:</b>

<pre>    class baseClassName {
        proc baseClassName {this} {
            # sub-class is remembered so that virtual procedures may be used
            ...
        }
        proc ~baseClassName {this} {
            # cleanup at base level here...
        }
        virtual proc doSomething {this parameter} {
            # derived class procedure with the same name may be invoked
            # any code that follows is not executed if this procedure is
            # overloaded in derived class
            ...
        }
    }
    class derivedClassName {
        proc derivedClassName {this} baseClassName {} {
            # base class constructor is automatically invoked
            ...
        }
        proc ~derivedClassName {this} {
            # cleanup at derived level here...
            # base class destructor is automatically invoked
        }
    }
    proc derivedClassName::doSomething {this parameter} {
        # code that follows is executed when base class procedure is called
        ...
    }
    set someObject [new derivedClassName]
    # access object as base object, derived class procedure is actually invoked
    baseClassName::doSomething $someObject $someValue
    puts [classof $someObject]                        ;# print object class name
    delete $someObject                                          ;# delete object</pre>

<h4><a name="graphical"></a>Graphical demonstration</h4>

A demonstration using the Composite pattern from the great book Design Patterns, Elements of Reusable Object Oriented Software, which I heartily recommend.

<p>The pattern is used to define a class hierarchy of the graphic base class, picture, oval and rectangle derived classes. A picture object can contain any number of other graphic objects, thus allowing graphical composition.

<p>The following paragraphs drawn from the book best describe what the Composite pattern does:

<blockquote><i>Compose objects into tree structures to represent part-whole hierarchies. Composite lets clients treat individual objects and compositions of objects uniformly.</i>

<p><i>The key to the Composite pattern is an abstract class that represents both primitives and their containers. For the graphic system, this class is Graphic. Graphic declares operations like Draw that are specific to graphical objects. It also declares operations that all composite objects share, such as operations for accessing and managing its children.</i>

<p><i>Gamma/Helm/Johnson/Vlissides, DESIGN PATTERNS, ELEMENTS OF REUSABLE OBJECT-ORIENTED SOFTWARE, (c) 1995 by Addison-Wesley Publishing Company, Reprinted by permission of Addison-Wesley Publishing Company, Inc.</i></blockquote>

Instructions:

<p>Run gdemo as in:

<pre>$ wish gdemo</pre>

Several buttons are placed below a canvas area. Picture, Rectangle and Oval are used to create Graphic objects. Clear is used to delete all the objects created so far, Exit is self explanatory.

<p>A Picture object can contain any number of Graphic objects, such as other Picture objects, Rectangle objects, ...

<p>For each Graphic object, the point used for moving and for the object coordinates is the upper left corner of the object.

<p>First create a Picture object by clicking on the Picture button. Move the red rectangle that appears by drag clicking on any of its edges. Then create a Rectangle object by clicking on the Rectangle button. Drag the Rectangle object in the Picture object, it is then a child of the Picture object.

<p>Move the Picture object to verify that its Rectangle child moves along.

<p>Create another Picture object and place an Oval object within.

<p>Move that Picture object to verify that its Oval child moves along.

<p>Now move the upper left corner of that last Picture within the first Picture area.

<p>Then move that Picture to verify that all the Graphic objects move along.

<h4><a name="widget"></a>Widget class</h4>

A widget usually can take a variable number of option / value pairs as arguments when created and any time later when configured. It is a good application for the variable number of arguments technique.

<p>Sample code (without error checking):

<pre>class widget {
    proc widget {this parent args} {
        # create Tk widget(s)
        # set widget options default in an array
        array set options {-background white -width 10}
        array set options $args              ;# then overwrite with user options
        eval configure $this [array get options]               ;# then configure
    }
    virtual proc configure {this args} {
        foreach {option value} $args {
            switch -- $option {
                -background {             ;# filter widget specific options here
                    set ($this,background) $value
                    # configure Tk widget(s)
                }
                ...
            }
        }
    }
}

class gizmo {}
proc gizmo::gizmo {this parent args} widget {$parent $args} {
    # create more Tk widget(s)
    # set gizmo options default in an array
    array set options {-spacetimecoordinates {0 0 0 now}}
    array set options $args                  ;# then overwrite with user options
    eval ownConfigure $this [array get options]                ;# then configure
}
proc gizmo::ownConfigure {this args} {
    foreach {option value} $args {
        switch -- $option {                ;# filter gizmo specific options here
            -spacetimecoordinates {
                set ($this,location) $value
                # configure Tk widget(s)
            }
            ...
        }
    }
}
proc gizmo::configure {this args} {
    eval ownConfigure $this $args                    ;# configure at gizmo level
    eval widget::_configure $this $args             ;# configure at widget level
}

new gizmo . -width 20 -spacetimecoordinates {1p 10ly 2p 24.2y}</pre>

In this example, invalid (unknown) options are simply ignored.

<h4><a name="array"></a>Member array</h4>

You simply cannot use a member array, as member data is already held in an array. But you can use a namespace array, with a name specific to the object, including the object identifier. Just make sure the array is deleted in the destructor.

<p>Sample code:

<pre>class container {
    proc container {this} {}
    proc ~container {this} {
        variable ${this}data
        unset ${this}data
    }
    proc container::add {this item id} {
        variable ${this}data
        set ${this}data($id) $item
    }
}</pre>

Memory management of the array is the programmer's responsibility, as is its duplication when copying objects. For example, use the following code if you ever copy objects with member arrays:

<pre>class container {
    proc container {this} {                                  ;# main constructor
        ...
    }               ;# default copy constructor has been generated at this point
    proc container {this copy} {      ;# copy constructor (replaces default one)
        variable ${this}data
        variable ${copy}data
        array set ${this}data [array get ${copy}data]       ;# copy member array
    }
    ...
}</pre>

<h3><a name="utility"></a>Utility classes</h3>

<h4><a name="switched"></a>switched</h4>

<i><b>Note</b>: if you have been using scwoop (a stooop based mega widget extension to the Tk widget library), you must certainly know about the composite class. The switched class is a generic (not widget oriented) derivative of the composite class.</i>

<p>Find the complete documentation <a href="switched.html">here</a>.

<h3><a name="debugging"></a>Debugging</h3>

As stooop is meant to be lean and fast, no checking is done during run-time, that is after all classes and their procedures have been defined.

<p>Starting from version 3.3, debugging aids were added to the stooop library (still held in a single file). Member checking insures that basic object oriented concepts and rules are applied. Tracing provides means for member procedures and data access logging to a file or to the screen.

<p>The above features are triggered and configured using environment variables. When not in use, they have absolutely no impact on stooop's performance (however, if you are really picky, you could say that since the stooop.tcl file has grown larger, load time got longer :).

<p>Please note that any stooop debugging environment variable must be set <b>prior</b> to the stooop library being loaded:

<pre>$ STOOOPTRACEDATA=stdout
$ export STOOOPTRACEDATA
$ tclsh myfile.tcl</pre>
around the beginning of myfile.tcl:
<pre>...
set env(STOOOPCHECKPROCEDURES) 1
source stooop.tcl
namespace import stooop::*
set env(STOOOPCHECKDATA) 1
...</pre>

In the example above, data tracing is enabled as well as procedure checking, but data checking is not turned on.

<h4><a name="check"></a>Member check</h4>

Both procedure and data member checking can be activated by setting the single environment variable STOOOPCHECKALL to a true value (<i>1</i>, <i>true</i> or <i>on</i>). Of course only one of those features can be activated as described below.

<p><i>Note: if you have an idea about any other thing that could be checked in the following sections, please share it with <a href="mailto:[email protected]">me</a>.</i>

<h5><a name="procedurecheck"></a>Procedure</h5>

Procedure checking is activated by setting the environment variable STOOOPCHECKPROCEDURES to a true value. The stooop library will then generate an error while the application is running in the following cases:

<ul>
  <li>an invalid <i>this</i> parameter (a non existing object identifier) is passed as argument to a non static member procedure
  <li>the object identified by the <i>this</i> parameter passed as argument to a class non static member procedure is neither an instance of the procedure class nor an instance of a derived class (at any level of derivation) of the procedure class.
  <li>a pure interface class (a class with at least 1 pure virtual member procedure) is instanciated
</ul>

<h5><a name="datacheck"></a>Data</h5>

Procedure checking is activated by setting the environment variable STOOOPCHECKDATA to a true value. The stooop library will then generate an error while the application is running in the following cases:

<ul>
  <li>in a class namespace but outside a member procedure, a data member of another class is written or unset
  <li>in a class member procedure (static or not), a data member of another class is written or unset
  <li>in a non static member procedure, a data member of an object different from the object identified by the <i>this</i> parameter passed as argument is written or unset
</ul>

<h4><a name="trace"></a>Member trace</h4>

Tracing is activated by setting a specific environment variable to either <i>stdout</i>, <i>stderr</i> or any file name that can be created and written to by the user. Setting the STOOOPTRACEALL variable enables both procedure and data tracing. Of course only one of those features can be activated as described below.

<h5><a name="proceduretrace"></a>Procedure</h5>

Procedure tracing is activated by setting the environment variable STOOOPTRACEPROCEDURES to either <i>stdout</i>, <i>stderr</i> or a file name. The stooop library will then output to the specified channel 1 line of informational text for each member procedure invocation.

<p>The user can define the output format by redefining the STOOOPTRACEPROCEDURESFORMAT (look at the beginning of the stooop.tcl file for the default format). The following substitutions will be performed prior to the output:

<ul>
  <li><b>%C</b> by the fully qualified class name
  <li><b>%c</b> by the class name (tail of the fully qualified class name)
  <li><b>%P</b> by the fully qualified procedure name
  <li><b>%p</b> by the procedure name (tail of the fully qualified procedure name)
  <li><b>%O</b> by the object identifier (<i>this</i> value)
  <li><b>%a</b> by the remaining procedure arguments (not including <i>this</i>)
</ul>

At the time this document is being written, the default format is:

<pre>class: %C, procedure: %p, object: %O, arguments: %a</pre>

example output from the gdemo application:

<pre>class: picture, procedure: constructor, object: 1, arguments: .canvas
class: graphic, procedure: constructor, object: 1, arguments: .canvas 1
class: rectangle, procedure: constructor, object: 2, arguments: .canvas
class: graphic, procedure: constructor, object: 2, arguments: .canvas 2
class: graphic, procedure: moveTo, object: 2, arguments: 13 4
class: graphic, procedure: _moveTo, object: 2, arguments: 13 4
class: graphic, procedure: moveTo, object: 2, arguments: 18 9
class: graphic, procedure: add, object: 1, arguments: 2
class: picture, procedure: add, object: 1, arguments: 2
class: graphic, procedure: add, object: 2, arguments: 2
class: rectangle, procedure: add, object: 2, arguments: 2
class: picture, procedure: destructor, object: 1, arguments:
class: graphic, procedure: destructor, object: 1, arguments:
class: rectangle, procedure: destructor, object: 2, arguments:
class: graphic, procedure: destructor, object: 2, arguments:</pre>

<h5><a name="datatrace"></a>Data</h5>

Data tracing is activated by setting the environment variable STOOOPTRACEDATA to either <i>stdout</i>, <i>stderr</i> or a file name. The stooop library will then output to the specified channel 1 line of informational text for each member data access. By default, all read, write and unsetting accesses are reported, but the user can set the STOOOPTRACEDATAOPERATIONS environment variable to any combination of the <i>r</i>, <i>w</i> and <i>u</i> letters for more specific tracing (please refer to the <i>trace</i> Tcl manual page for more information).

<p>Note that operations internal to the stooop library, such as automatic unsetting of data members during objects destruction do not appear in the trace.

<p>The user can define the output format by redefining the STOOOPTRACEDATAFORMAT (look at the beginning of the stooop.tcl file for the default format). The following substitutions will be performed prior to the output:

<ul>
  <li><b>%C</b> by the fully qualified class name
  <li><b>%c</b> by the class name (tail of the fully qualified class name)
  <li><b>%P</b> by the fully qualified procedure name
  <li><b>%p</b> by the procedure name (tail of the fully qualified procedure name)
  <li><b>%A</b> by the fully qualified array name
  <li><b>%m</b> by the data member name (right after the <i>this,</i> array name part for a non static data member)
  <li><b>%O</b> by the object identifier (<i>this</i> value or empty for a static procedure)
  <li><b>%o</b> by the access operation (<i>read</i>, <i>write</i> or <i>unset</i>)
  <li><b>%v</b> by the new or current value (empty for an <i>unset</i> operation)
</ul>

At the time this document is being written, the default format is:

<pre>class: %C, procedure: %p, array: %A, object: %O, member: %m, operation: %o, value: %v</pre>

example output from the gdemo application:

<pre>class: graphic, procedure: constructor, array: graphic::, object: 1, member: canvas, operation: write, value: .canvas
class: graphic, procedure: constructor, array: graphic::, object: 1, member: item, operation: write, value: 1
class: picture, procedure: constructor, array: picture::, object: 1, member: graphics, operation: write, value: 
class: picture, procedure: moveTo, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
class: picture, procedure: moveTo, array: graphic::, object: 1, member: item, operation: read, value: 1
class: picture, procedure: moveBy, array: picture::, object: 1, member: graphics, operation: read, value: 
class: graphic, procedure: _moveBy, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
class: graphic, procedure: _moveBy, array: graphic::, object: 1, member: item, operation: read, value: 1
class: graphic, procedure: constructor, array: graphic::, object: 2, member: canvas, operation: write, value: .canvas
class: graphic, procedure: constructor, array: graphic::, object: 2, member: item, operation: write, value: 2
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
class: graphic, procedure: _moveTo, array: graphic::, object: 2, member: item, operation: read, value: 2
class: picture, procedure: add, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
class: picture, procedure: add, array: graphic::, object: 1, member: item, operation: read, value: 2
class: picture, procedure: add, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
class: picture, procedure: add, array: graphic::, object: 1, member: item, operation: read, value: 1
class: graphic, procedure: destructor, array: graphic::, object: 1, member: canvas, operation: read, value: .canvas
class: graphic, procedure: destructor, array: graphic::, object: 1, member: item, operation: read, value: 1
class: graphic, procedure: destructor, array: graphic::, object: 2, member: canvas, operation: read, value: .canvas
class: graphic, procedure: destructor, array: graphic::, object: 2, member: item, operation: read, value: 2</pre>

<h4><a name="objects"></a>Objects</h4>

Objects checking can be activated by setting the single environment variable STOOOPCHECKOBJECTS to a true value. The following stooop namespace procedures then become available for debugging; <i>printObjects</i>, <i>record</i> and <i>report</i>.

<p>Before outputting any data, all the object checking procedures print which procedure they were invoked from, or the namespace name if invoked from a namespace body or "<i>top level</i>" if invoked outside any procedure or namespace.

<h5><a name="objects.printing"></a>Printing</h5>

The <i>stooop::printObjects</i> procedure when invoked prints an ordered list of existing objects with their creation location (a fully qualified procedure name or "<i>top level</i>") after a <b>+</b> sign. The objects are printed in creation order, with the oldest (lowest identifier) first. The printObjects procedure takes an optional class pattern (as in the Tcl "<i>array names</i>" or "<i>string match</i>" commands) for limiting the output to objects of certain classes, as the following example shows (classes are assumed to exist and be valid):

<pre>% new foo
1
% stooop::printObjects
stooop::printObjects invoked from top level:
::foo(1) + top level
% new bar
2
% stooop::printObjects
stooop::printObjects invoked from top level:
::foo(1) + top level
::bar(2) + top level
% new Foo
3
% stooop::printObjects ::?oo
stooop::printObjects invoked from top level:
::foo(1) + top level
::Foo(3) + top level
% new barmaid
4
% stooop::printObjects ::bar*
stooop::printObjects invoked from top level:
::bar(2) + top level
::barmaid(4) + top level</pre>

Please note that all object classes are always fully qualified, so do not forget about the <b>::</b> header in the patterns.

<h5><a name="objects.recording"></a>Recording</h5>

By invoking the <i>stooop::record</i> procedure, you take a snapshot of all existing stooop objects at the time of invocation. Reporting can then be used at a later time to see which objects were created or deleted in the interval.

<p>The record procedure does not take any arguments and it only prints its context of invocation.

<h5><a name="objects.reporting"></a>Reporting</h5>

The <i>stooop::report</i> procedure prints the created and deleted objects since the stooop::record procedure was invoked last. It optionally takes a pattern argument in order to limit the output to a specific set of classes, as for the printObjects procedure. A <b>+</b> sign is placed at the beginning of each created object description line in the output trace, followed by another <b>+</b> sign and the creation location (a fully qualified procedure name or "<i>top level</i>"). A <b>-</b> sign is placed at the beginning of each deleted object description line in the output trace, followed by another <b>-</b> sign, the deletion location (a fully qualified procedure name or "<i>top level</i>"), a <b>+</b> sign and the creation location (a fully qualified procedure name or "<i>top level</i>").

<p>Reporting is typically used between 2 spots in the debugged application code: the first spot where a bunch of objects (which can include sub objects) are created, the second spot where all or most of these objects are supposed to be deleted. On the first spot, stooop::record is invoked whereas on the second spot, the stooop::report invocation will print the created and/or deleted objects, in other words the "object difference" between the 2 spots. In most cases, the programmer would expect a difference of 0 objects, sign of a well behaved application, memory wise.

<p>Consider the following example:

<pre>class foo {
    proc foo {this} {}
    proc ~foo {this} {}
}
class bar {
    proc bar {this} {
        new foo
    }
    proc ~bar {this} {}
}
stooop::record
delete [new bar]
stooop::report
stooop::record
delete 2
stooop::report</pre>

It gives the following result:

<pre>stooop::record invoked from top level
stooop::report invoked from top level:
+ ::foo(2) + ::bar::bar
stooop::record invoked from top level
stooop::report invoked from top level:
- ::foo(2) - top level + ::bar::bar</pre>

Examining the printout, one can see that the bar class does not properly clean things up as the foo sub object is left undeleted.

<h3><a name="notes"></a>Notes</h3>

<h4><a name="design"></a>On design choices</h4>

Performance would have to as good as possible.

<p>A familiar C++ syntax should serve as a model (not all, though, I didn't feel like writing 700 pages of documentation :-).

<p>Tcl being a non declarative language (which I really enjoy), stooop would have to try to comply with that approach.

<p>Error checking would have to be strong with little impact on performance.

<h4><a name="implementation"></a>On implementation</h4>

For a Tcl only extension, I think performance is the main issue. The performance / functionality compromise was handled by moving as much processing as possible to the preprocessing stage, handled by the proc and virtual commands. Furthermore, all the costly error checking could be done there as well, having no impact on runtime performance.

<p>The delete operation was greatly simplified, especially for classes that would require a virtual destructor in C++, by storing in an array the class of each object. It then became trivial to delete any object from its identifier only. This approach has an impact on memory use, though, but I consider that one is not very likely to create a huge number of objects in a Tcl application. Furthermore, a classof RTTI operator was then added with no effort.

<p>Stooop learns class hierarchies through the constructor definition whichserves as an implementation as well, thus (kind of) better fitting the non declarative nature of Tcl.

<p>All member data is public but access control is somewhat enforced by having to explicitly name the class layer of external data being accessed.

<p>Since, for performance reasons, the stooop library performs very little checking during run-time (after all classes and their procedures were defined), debugging aids are provided starting from version 3.3. They attempt to insure that your code is well written in an object oriented sense. They also provide means for tracing data access and procedures.

<h3><a name="misc"></a>Miscellaneous information</h3>

For downloading other Tcl software (such as scwoop, moodss, ...), visit my <a href="http://jfontain.free.fr/">web page</a>.

<p>Send your comments, complaints, ... to <a href="mailto:[email protected]">Jean-Luc Fontaine</a>.

</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/stooop/switched.html.

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

<center>
<dt>
<b><font size=+4>the switched class</font></b></dt></center>

<p>&nbsp;
<br>&nbsp;
<br>
<p>The <b>switched</b> class serves as base class for user classes with
switch / option configuration method. It provides facilities for managing
options through a simple interface.
<p>For example:
<pre>set vehicle [new car -length 4.5 -width 2 -power 100 -fuel diesel]
puts "my car was running on [switched::cget $vehicle -fuel]"
switched::configure $vehicle -power 40 -fuel electricity
puts "but is now running on clean [switched::cget $vehicle -fuel]"</pre>
Of course, as you might have guessed, the <b>car</b> class is derived from
the <b>switched</b> class. Let us see how it works:
<pre>class car {
&nbsp;&nbsp;&nbsp; proc car {this args} switched {$args} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; # car specific initialization code here
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; switched::complete $this
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
}</pre>
The switched class constructor takes the optional configuration option
/ value pairs as parameters. The switched class layer then completely manages
the switched options: it checks their validity, stores their values and
provides a clean interface to the user layer configuration setting procedures.
<p>The switched class members available to the programmer are:
<p><b>switched</b>
<ul>
<li>
complete{}</li>

<li>
<i>options{}</i></li>

<li>
<i>set-option{}</i></li>

<li>
...</li>

<li>
complete</li>

<li>
-option</li>

<li>
...</li>
</ul>
The <b>complete</b> procedure is used to tell the switched layer that the
derived class object (a car in the examples) is completely built. At that
time, the initial configuration of the switched object occurs, using default
option values (see <b>options</b> procedure) eventually overridden by construction
time values, passed at the time of the <i>new</i> operator invocation.
The complete procedure must be called once only, usually around or at the
end of the derived class constructor. <i>(<b>Note</b>: also check the <b>complete</b>
data member later in this chapter)</i>
<p>The <b>options</b> procedure must return the configuration description
for <b>all</b> options that the switched object will accept. It is a pure
virtual member procedure and therefore its implementation is <b>mandatory</b>
in the derived class layer. The procedure must return a list of lists.
Each list pertains to a single option and is composed of the switch name,
the default value for the option and an optional initial value. For example:
<pre>class car {
&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; proc options {this} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; return [list\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -fuel petrol petrol]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -length {} {}]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -power {} {}]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -width {} {}]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ]
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; proc set-fuel {this value} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
}</pre>
In this case, 4 options are specified: <i>fuel</i>, <i>length</i>, <i>power</i>
and <i>width</i>. The default and initial values for the <i>fuel</i> option
are identical and set to <i>petrol</i>. For the other options, values are
all empty.
<p>For each option, there must be a corresponding set-<i>option</i> procedure
defined in the derived class layer. For example, since we defined a <i>fuel</i>
option, there is a set-<i>fuel</i> procedure in the car class. The parameters
always are the object identifier (since this is not a static procedure,
but rather a dynamically defined virtual one), followed by the new value
for the option. The set-<i>option</i> procedure is only invoked if the
new value differs from the current one (a cache scheme for improving performance),
or if there is no initial value set in the options procedure for that option.
<p>In the options procedure, if the initial value differs from&nbsp; the
default value or is omitted, then initial configuration is forced and the
corresponding set-<i>option</i> procedure is invoked by the switched <i>complete</i>
procedure located at the end of the derived class constructor. For example:
<pre>class car {
&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; proc options {this} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; return [list\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -fuel petrol]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -length {} {}]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -power 100 50]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -width {} {}]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ]
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
}</pre>
In this case, configuration is forced on the <i>fuel</i> and <i>power</i>
options, that is the corresponding set-<i>option</i> procedures will be
invoked when the switched object is constructed (see set-<i>option</i>
procedures documentation below).
<p>For the <i>fuel</i> option, since there is no initial value, the set-<i>fuel</i>
procedure is called with the default value (<i>petrol</i>) as argument.
For the <i>power</i> option, since the initial value differs from the default
value, the set-<i>power</i> procedure is called with the initial value
as argument (<i>50</i>).
<p>For the other options, since the initial values (last elements of the
option lists) are identical to their default values, the corresponding
set-<i>option</i> procedures will not be invoked. It is the programmer's
responsibility to insure that the initial option values are correct.
<p>The <b>set-<i>option</i></b> procedures may be viewed as dynamic virtual
functions. There must be one implementation per supported option, as returned
by the <i>options</i> procedure. For example:
<pre>class car {
&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; proc options {this} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; return [list\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -width {} {}]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ]
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; proc set-width {this value} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
}</pre>
Since the <i>-width</i> option was listed in the options procedure, a <i>set-width</i>
procedure implementation is provided, which of course would proceed to
set the width of the car (and would modify the looks of a graphical representation,
for example).
<p>As you add a supported <i>option</i> in the list returned by the options
procedure, the corresponding set-<i>option</i> procedure may be called
as soon as the switched object is complete, which occurs when the switched
level <i>complete</i> procedure is invoked. For example:
<br>&nbsp;
<pre>class car {
&nbsp;&nbsp;&nbsp; proc car {this args} switched {args} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; switched::complete $this
&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; proc options {this} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; return [list\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -fuel petrol]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -length 4.5]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -power 350]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; [list -width 1.8]\
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ]
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; proc set-fuel {this value} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; proc set-length {this value} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; proc set-power {this value} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; proc set-width {this value} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
}</pre>

<pre>new car</pre>
In this case, a new car is created with no options, which causes the car
constructor to be called, which in turns calls the switched level <i>complete</i>
procedure after the car object layer is completely initialized. At this
point, since there are no initial values in any option list in the options
procedure, the set-fuel procedure is called with its default value of <i>petrol</i>
as parameter, followed by the set-length call with <i>4.5</i> value, set-power
with <i>350</i> value and finally with set-width with <i>1.8</i> as parameter.
This is a good way to test the set-option procedures when debugging, and
when done, just fill-in the initial option values.
<p>The switched layer checks that an option is valid (that is, listed in
the options procedure) but obviously does not check the validity of the
value passed to the set-<i>option</i> procedure, which should throw an
error (for example by using the Tcl error command) if the value is invalid.
<p>The switched layer also keeps track of the options current values, so
that a set-<i>option</i> procedure is called only when the corresponding
option value passed as parameter is different from the current value (see
<i>-option</i>
data members description).
<p>The <b><i>-option</i></b> data member is the option current value. There
is one for each option listed in the options procedure. It is a read-only
value which the switched layer checks against when an option is changed.
It is rarely used at the layer derived from switched, except in the few
cases, such as in the following example:
<pre>...</pre>

<pre>proc car::options {this} {
&nbsp;&nbsp;&nbsp; return {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; {-manufacturer {} {}}
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ...
&nbsp;&nbsp;&nbsp; }
}</pre>

<pre>proc car::set-manufacturer {this value} {}</pre>

<pre>proc car::printData {this} {
&nbsp;&nbsp;&nbsp; puts "manufacturer: $switched::($this,-manufacturer)"
&nbsp;&nbsp;&nbsp; ...
}</pre>
In this case, the manufacturer's name is stored at the switched layer level
(this is why the set-manufacturer procedure has nothing to do) and later
retrieved in the printData procedure.
<p>The <b>complete</b> data member (not to be confused with the complete
procedure) is a boolean. Its initial value is <i>false</i> and it is set
to <i>true</i> at the very end of the switched complete procedure. It becomes
useful when some options should be set at construction time only and not
dynamically, as the following example shows:
<pre>proc car::set-width {this value} {
&nbsp;&nbsp;&nbsp; if {$switched::($this,complete)} {
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; error {option -width cannot be set dynamically}
&nbsp;&nbsp;&nbsp; }
&nbsp;&nbsp;&nbsp; ...
}</pre>

</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































Deleted modules/stooop/switched.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
# The switched class (for the stooop object oriented extension)
#
# Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: switched.tcl,v 1.2 2001/11/27 11:46:52 jfontain Exp $

package provide switched 2.2


::stooop::class switched {

    proc switched {this args} {            ;# arguments are option / value pairs
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        set ($this,complete) 0
        # delay arguments processing till completion as pure virtual procedure
        # invocations do not work from base class constructor
        set ($this,arguments) $args
    }

    proc ~switched {this} {}

    # derived class implementation must return a list of
    # {name "default value" "initial value"} lists
    ::stooop::virtual proc options {this}

    # must be invoked once only at the end of derived class constructor so that
    # configuration occurs once derived object is completely built:
    proc complete {this} {
        foreach description [options $this] {
            set option [lindex $description 0]
            # by default always set option to default value:
            set ($this,$option) [set default [lindex $description 1]]
            if {[llength $description]<3} {
                # no initial value so force initialization with default value
                set initialize($option) {}
            } elseif {![string equal $default [lindex $description 2]]} {
                set ($this,$option) [lindex $description 2]
                # initial value different from default value so force
                # initialization
                set initialize($option) {}
            }
        }
        # check validity of constructor options, which always take precedence
        # for initialization
        foreach {option value} $($this,arguments) {
            if {[catch {string compare $($this,$option) $value} different]} {
                error "$($this,_derived): unknown option \"$option\""
            }
            if {$different} {
                set ($this,$option) $value
                set initialize($option) {}
            }
        }
        unset ($this,arguments)
        # all option values are initialized before any of the set procedures are
        # called
        foreach option [array names initialize] {
            $($this,_derived)::set$option $this $($this,$option)
        }
        set ($this,complete) 1
    }

    proc configure {this args} {      ;# should not be invoked before completion
        if {[llength $args]==0} {
            return [descriptions $this]
        }
        foreach {option value} $args {
            # check all options validity before doing anything else
            if {![info exists ($this,$option)]} {
                error "$($this,_derived): unknown option \"$option\""
            }
        }
        if {[llength $args]==1} {
            return [description $this [lindex $args 0]]
        }
        if {([llength $args]%2)!=0} {
            error "value for \"[lindex $args end]\" missing"
        }
        # derived (dynamic virtual) procedure must either accept (or eventually
        # adjust) the value or throw an error
        # option data member is set prior to invoking the procedure in case
        # other procedures are invoked and expect the new value
        foreach {option value} $args {
            if {![string equal $($this,$option) $value]} {
                $($this,_derived)::set$option $this [set ($this,$option) $value]
            }
        }
    }

    proc cget {this option} {
        if {[catch {set value $($this,$option)}]} {
            error "$($this,_derived): unknown option \"$option\""
        }
        return $value                   ;# return specified option current value
    }

    proc description {this option} {  ;# build specified option description list
        foreach description [options $this] {
            if {[string equal [lindex $description 0] $option]} {
                if {[llength $description]<3} {              ;# no initial value
                    lappend description $($this,$option) ;# append current value
                    return $description
                } else {
                    # set current value:
                    return [lreplace $description 2 2 $($this,$option)]
                }
            }
        }
    }

    # build option descriptions list for all supported options:
    proc descriptions {this} {
        set descriptions {}
        foreach description [options $this] {
            if {[llength $description]<3} {                  ;# no initial value
                # append current value:
                lappend description $($this,[lindex $description 0])
                lappend descriptions $description
            } else {
                # set current value:
                lappend descriptions [lreplace\
                    $description 2 2 $($this,[lindex $description 0])\
                ]
            }
        }
        return $descriptions
    }

}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































Deleted modules/stooop/xifo.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
# The lifo and fifo classes (for the stooop object oriented extension)
#
# Copyright (c) 2001 by Jean-Luc Fontaine <[email protected]>.
# This code may be distributed under the same terms as Tcl.
#
# $Id: xifo.tcl,v 1.2 2001/11/27 11:46:52 jfontain Exp $


# Here is a sample FIFO/LIFO implementation with stooop.
# Sample test code is at the bottom of this file.


# Uncomment the following lines for the bottom sample code to work:
# package require stooop
# namespace import stooop::*

::stooop::class xifo {
    proc xifo {this size} {
        set ($this,size) $size
        empty $this
    }

    proc ~xifo {this} {
        variable ${this}data
        catch {unset ${this}data}
    }

    proc in {this data} {
        variable ${this}data
        tidyUp $this
        if {[array size ${this}data]>=$($this,size)} {
            unset ${this}data($($this,first))
            incr ($this,first)
        }
        set ${this}data([incr ($this,last)]) $data
    }

    proc tidyUp {this} {                       ;# warning: for internal use only
        variable ${this}data
        catch {
            unset ${this}data($($this,unset))
            unset ($this,unset)
        }
    }

    proc empty {this} {
        variable ${this}data
        catch {unset ${this}data}
        catch {unset ($this,unset)}
        set ($this,first) 0
        set ($this,last) -1
    }

    proc isEmpty {this} {
        variable ${this}data
        return [expr {[array size ${this}data]==0}]
    }

    ::stooop::virtual proc out {this}

    ::stooop::virtual proc data {this}
}

::stooop::class lifo {
    proc lifo {this {size 2147483647}} xifo {$size} {}

    proc ~lifo {this} {}

    proc out {this} {
        xifo::tidyUp $this
        if {[array size xifo::${this}data]==0} {
            error "lifo $this out error, empty"
        }
        # delay unsetting popped data to improve performance by avoiding a data
        # copy:
        set xifo::($this,unset) $xifo::($this,last)
        incr xifo::($this,last) -1
        return [set xifo::${this}data($xifo::($this,unset))]
    }

    proc data {this} {
        set list {}
        set first $xifo::($this,first)
        for {set index $xifo::($this,last)} {$index>=$first} {incr index -1} {
            lappend list [set xifo::${this}data($index)]
        }
        return $list
    }
}

::stooop::class fifo {
    proc fifo {this {size 2147483647}} xifo {$size} {}

    proc ~fifo {this} {}

    proc out {this} {
        xifo::tidyUp $this
        if {[array size xifo::${this}data]==0} {
            error "fifo $this out error, empty"
        }
        # delay unsetting popped data to improve performance by avoiding a data
        # copy:
        set xifo::($this,unset) $xifo::($this,first)
        incr xifo::($this,first)
        return [set xifo::${this}data($xifo::($this,unset))]
    }

    proc data {this} {
        set list {}
        set last $xifo::($this,last)
        for {set index $xifo::($this,first)} {$index<=$last} {incr index} {
            lappend list [set xifo::${this}data($index)]
        }
        return $list
    }
}

# Here are a few lines of sample code:
#    proc exercise {id} {
#        for {set u 0} {$u<10} {incr u} {
#            xifo::in $id $u
#        }
#        puts [xifo::out $id]
#        puts [xifo::data $id]
#        xifo::in $id $u
#        xifo::in $id [incr u]
#        puts [xifo::data $id]
#    }
#    set id [stooop::new lifo 10]
#    exercise $id
#    stooop::delete $id
#    set id [stooop::new fifo 10]
#    exercise $id
#    stooop::delete $id
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































Deleted modules/struct/ChangeLog.

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

	* prioqueue.tcl (__elementcompare): Failures in testsuite fixed,
	  patch provided by original author, Michael Schlenker
	  <[email protected]>.

2003-04-15  Andreas Kupries  <[email protected]>

	* skiplist.man:
	* skiplist.tcl:
	* skiplist.test: New files. Patch #553980 submitted by Eric Melski
	  <[email protected]> on behalf of Keith Vetter.

	* prioqueue.tcl:
	* prioqueue.test: New files. Patch #607085 submitted by Michael
	  Schlenker <[email protected]>.

2003-04-15  Andreas Kupries  <[email protected]>

	* tcllib_list.man: Changed name to struct_list.man. Allows for
	  usage of struct outside of tcllib, not as big a coupling.

	* graph.tcl: Redone the setting up of namespace a bit to prevent
	  problem with the generation of a master package
	  index. strcut.tcl bailed out with an error because the namespace
	  was net set up when using [pkg_mkIndex] in this directory.

2003-04-13  Andreas Kupries  <[email protected]>

	* graph.test:
	* graph.man:
	* graph.tcl: Added code to look for the C-implementation, cgraph,
	  first, and to fall back to the Tcl implementation if cgraph is
	  not present (#720348). The documentation links to the place
	  where cgraph can be had from. Note presence of cgraph when
	  executing the testsuite.

2003-04-12  Andreas Kupries  <[email protected]>

	* list.man: Changed name to tcllib_list.man to prevent a clash
	  with tcl's manpages.

2003-04-11  Andreas Kupries  <[email protected]>

	* struct.tcl:
	* list.man:
	* matrix.man:
	* pool.man:
	* queue.man:
	* record.man:
	* stack.man:
	* tree.man:
	* pkgIndex.tcl:  Set version of the package to 1.3.

2003-04-09  Andreas Kupries  <[email protected]>

	* list.man:
	* list.test:
	* list.tcl: Added 'lcsInvertMerge'.

2003-04-08  Andreas Kupries  <[email protected]>

	* list.man:
	* list.test:
	* list.tcl: Added and documented commands [iota], [equal], and
	  [repeat]. Extended the testsuite.

2003-04-02  Andreas Kupries  <[email protected]>

	* list.cl:
	* list.test: Fixed SF tcllib bug #714209.

	* ../../../examples/struct: Added example applications for usage
	  of longestCommonSubsequence and lcsInvert.

	* struct.tcl: Integrated new list commands.

	* list.tcl:  Added commands 'reverse', 'assign', 'flatten',
	* list.man:  'map', and 'fold' to the suite of list functions.
	* list.test: 

2003-04-01  Andreas Kupries  <[email protected]>

	* list.man:  New files, extended list manipulation
	* list.tcl:  facilities. Started out with Kevin Kenny's
	* list.test: implementation of the algorithm to find the longest
	             common subsequence of two sequences, aka lists.
		     Added myself a method to invert a LCS into a
		     description of differences instead.

2003-04-01  Andreas Kupries  <[email protected]>

	* record.test: Applied changes provided by Brett Schwarz
	  <[email protected]>. His comments: I had changed
	  the return when encountering a circular record; previously I
	  returned "", but now I return an error. This fixes record.test
	  to reflect the change. Part of fix for Tcllib SF Bug #709375.

	  Additional changes by myself: Reformatted (proper tcl
	  indentations). Renumbered so that all tests have unique id
	  numbers (Before all tests had id 0.1).

2003-02-25  David N. Welton  <[email protected]>

	* matrix.tcl: Require Tcl 8.2 because of string map.  Use string
	map instead of regexp.

2003-01-16  Andreas Kupries  <[email protected]>

	* graph.man: More semantic markup, less visual one.
	* matrix.man:
	* pool.man:
	* record.man:
	* tree.man:

2002-11-06  Brett Schwarz  <[email protected]>

        * record.tcl: cleaned up code based on output from frink

2002-11-05  Brett Schwarz  <[email protected]>

        * struct.tcl: modified to include record.tcl

        * record.man:
        * record.html:
        * record.n:
        * record.test:
        * record.tcl: new data structure

2002-10-16  Andreas Kupries  <[email protected]>

	* graph.test: 
	* graph.man:
	* graph.tcl: Implemented FR 603924. getall, keys, keyexists
	  methods for keys of the whole graph.

2002-08-08  Andreas Kupries  <[email protected]>

	* tree.test: Followup to fix for bug SF #587533. Had to update the
	  test suite too.

2002-08-06  Andreas Kupries  <[email protected]>

	* tree.tcl (lappend): Fixed bug SF #587533 reported by Evan Rempel
	  <[email protected]>.

	* pool.tcl: Fixed bug SF #585093, reported by Michael Cleverly
	  <[email protected]>. Patch provided by Michael too.

2002-07-08  Andreas Kupries  <[email protected]>

	* tree.man: Updated the documentation to clarify the behaviour.

	* test.tcl: Updated testsuite, part of the patch below.

	* tree.tcl (_move): Accepted patch by Brian Theado
	  <[email protected]> fixing the behaviour of mov, SF
	  bug #578460. The command now also validates all nodes before
	  trying to move any of them.

2002-05-27  Andreas Kupries  <[email protected]>

	* matrix.man: Fixed typo (graph -> matrix).

	* struct.tcl: Added pool files to list of files to source.

	* pool.man: New documentation for pool based upon the original
	  HTML manpage.

	* pool.html:
	* pooltest.tcl:
	* pool.tcl: New data structure, pool, by Erik Leunissen
	  <[email protected]>. Modified code to be a sub-namespace of
	  ::struct, made it a part of the struct package. No regular
	  testsuite yet (see pooltest.tcl for the irregular testsuite).

2002-05-08  Andreas Kupries  <[email protected]>

	* graph.n: This file is out of sync.
	* graph.man:
	* graph.test:
	* graph.tcl: See tree, for arcs and nodes.

	* tree.man:
	* tree.n:
	* tree.test:
	* tree.tcl: Accepted FR #552972 (new methods append, lappend,
	  getall, keys, keyexists) for tree structures.

2002-04-01  Andreas Kupries  <[email protected]>

	* matrix.tcl: Fixed SF Tcllib #532791 about unsetting of elements
	  in linked arrays as reported by Ken Jones
	  <[email protected]>. Unsetting an element in a linked
	  array now sets the corresponding cell in the matrix to the empty
	  string, and the corresponding elements in other linked arrays
	  are now unset too.

	* tree.man: New file, doctools manpage.

2002-03-25  Andreas Kupries  <[email protected]>

	* matrix.tcl: Fixed bug #532783 reported by Ken Jones
	  <[email protected]>. Any operation adding new material
	  to a linked matrix causes a circular trace (op -> "MatTraceOut"
	  -> "MatTraceIn" -> set cell) and the inbound trace fails because
	  the data structures are not uptodate causing the range checks in
	  "set cell" to fail. Fixed by breaking the cycle. Calls to
	  "MatTraceIn" are now disabled while we are in "MatTraceOut".

2002-03-15  Andreas Kupries  <[email protected]>

	* matrix.man: Added example of formatting a matrix using tabular
	  reports (See tcllib module "reports" too.). Fixes #530207.

2002-03-09  Andreas Kupries  <[email protected]>

	* matrix.n:
	* matrix.man:
	* matrix.test:
	* matrix.tcl: Accepted FR #524430 and added option -nocase to the
	  'search' method.

	* matrix.man: Added doctools manpage.

2002-03-02  Andreas Kupries  <[email protected]>

	* graph.man: Added doctools manpage.

2002-02-14  Andreas Kupries  <[email protected]>

	* matrix.tcl: Frink run.

2002-02-01  Andreas Kupries  <[email protected]>

	* Version up to 1.2.1 to differentiate development from the
	  version in the tcllib 1.2 release.

	* matrix.test:
	* matrix.tcl: See below, but not complete.
	* queue.test
	* stack.test:
	* graph.tcl: 
	* graph.test: 
	* tree.tcl: 
	* tree.test: Updated code and tests to cover all paths through the
	  code.

2002-01-15  Andreas Kupries  <[email protected]>

	* Bumped version to 1.2

2001-11-26  Andreas Kupries  <[email protected]>

	* matrix.tcl (add rows): Indices were transposed. Fixed.

2001-11-23  Andreas Kupries  <[email protected]>

	* matrix.test:
	* matrix.n:
	* matrix.tcl: Implementation of FR #481022: matrix printing and
	  searching.

2001-11-19  Andreas Kupries  <[email protected]>

	* graph.test:
	* graph.n:
	* graph.tcl: Applied patch #483125 provided by Frank Pilhofer
	  <[email protected]>. The patch adds key/value information for the whole
	  graph and extends the selection methods 'arcs' and 'nodes' to
	  allow selection based on keys and their values.

2001-10-16  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl:
	* struct.tcl:
	* graph.n:
	* matrix.n:
	* queue.n:
	* stack.n:
	* tree.n: Version up to 1.1.1

2001-09-05  Andreas Kupries  <[email protected]>

	* The changes below fix bug [458011].

	* tree.test (6.16): New test. Checks verificator of forbidden names.

	* tree.tcl (::struct::tree::_insert): Added verification that node
	  names do not contain forbidden characters.

	* tree.n: Documented limitations on node names. Documented allowed
	  index "end" for insert.

2001-07-10  Andreas Kupries <[email protected]>

	* matrix.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* tree.tcl:
	* graph.tcl: Fixed dubious code reported by frink.

2001-06-19  Andreas Kupries <[email protected]>

	* matrix.n: Fixed nroff trouble.

2001-05-20  Andreas Kupries <[email protected]>

	* matrix.tcl (insert row/column): Fixed wrong references to the
	  internal add row/column procedures.

	* modules/struct/matrix.test: Added 8.11 and 8.12 to test the case
	  of 'insert FOO' devolving to 'add FOO'.

2001-05-01  Andreas Kupries <[email protected]>

	* Committed changes (matrix) to CVS head at SF.

2001-04-17  Andreas Kupries <[email protected]>

	* matrix.n: updated and completed documentation
	* matrix:test: Added testsuite
	* matrix.tcl: Added the implementation.

2001-04-12  Andreas Kupries <[email protected]>

	* struct.tcl: Added loading of the matrix definition.

	* matrix.n: Adding matrix structure.

2000-04-07  Eric Melski  <[email protected]>

	* stack.test: 
	* queue.test: Changed "package require struct" to "source [file
	  join [file dirname [info script]] xxxx.tcl]", which is more reliable.

	* tree.test: 
	* tree.tcl: Added support for different walk orders (post,
	  in, and both) [RFE: 4420].  Added support for percent substitution
	  on walk command.  (WalkCall) Added protection against node/tree
	  names with spaces.

	* graph.tcl: 
	* graph.test: 
	* graph.n: Graph implementation from Andreas Kupries.

2000-03-20  Eric Melski  <[email protected]>

	* tree.test: 
	* tree.n: 
	* tree.tcl: Added support for inserting/moving multiple nodes at
	  once.  Changed behavior of insert with respect to inserting nodes
	  that already exist; instead of an error, it will move the node.

2000-03-14  Eric Melski  <[email protected]>

	* tree.n: Added a brief description of what a tree is.

2000-03-10  Eric Melski  <[email protected]>

	* tree.n: 
	* tree.tcl: 
	* tree.test: Applied patch from [RFE: 4337], with enhancements for
	  better efficiency, and additional test cases; adds cut and splice
	  functions to tree.

2000-03-09  Eric Melski  <[email protected]>

	* tree.n: 
	* tree.tcl: 
	* tree.test: Applied patch from [RFE: 4338]; adds index function to
	  tree.  Applied patch from [RFE: 4339], with slight modification; adds
	  numchildren function to tree.  Applied patch from [RFE: 4336],
	  with additional error checks and test cases; adds next, previous
	  functions to tree.  Added extra tests for walk command.

	* tree.tcl: Added isleaf function and tests [RFE: 4340]

	* struct.tcl: Changed order of namespace import/namespace export
	  calls.  Added -force to namespace import calls.

	* tree.test: 
	* stack.test: 
	* queue.test: Adapted tests to run in/out of tcllib test framework.

	* tree.test:
	* tree.tcl: Added code to auto-generate node names on insert if no
	  name is given [RFE: 4345]

2000-03-08  Eric Melski  <[email protected]>

	* tree.test:
	* tree.tcl: Added check for node existance in children function
	  [Bug: 4341]

2000-03-03  Eric Melski  <[email protected]>

	* tree.tcl: Changed usage information for tree::_walk.

	* tree.n: Enhanced description of walk function, fixed a typo.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/graph.man.

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

The [cmd ::struct::graph] command creates a new graph object with an
associated global Tcl command whose name is [arg graphName].  This
command may be used to invoke various operations on the graph.  It has
the following general form:

[list_begin definitions]
[call [cmd graphName] [arg option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.

[list_end]

[para]

[emph Note:] A C-implementation of the command can be had from the
location [uri http://physnet.uni-oldenburg.de/~schlenk/tcl/graph/].
This implementation uses a bit less memory than the tcl version
provided here directly, and is faster.


[para]

A directed graph is a structure containing two collections of
elements, called [emph nodes] and [emph arcs] respectively, together
with a relation ("connectivity") that places a general structure upon
the nodes and arcs.

[para]

Each arc is connected to two nodes, one of which is called the

[emph source] and the other the [emph target]. This imposes a
direction upon the arc, which is said to go from the source to the
target. It is allowed that source and target of an arc are the same
node. Such an arc is called a [emph loop]. Whenever a node is source
or target of an arc both are said to be [emph adjacent]. This extends
into a relation between nodes, i.e. if two nodes are connected through
at least one arc they are said to be [emph adjacent] too.

[para]

Each node can be the source and target for any number of arcs. The
former are called the [emph {outgoing arcs}] of the node, the latter
the [emph {incoming arcs}] of the node. The number of edges in either
set is called the [emph in-] resp. the [emph out-degree] of the node.

[para]

In addition to maintaining the node and arc relationships, this graph
implementation allows any number of keyed values to be associated with
each node and arc.

[para]

The following commands are possible for graph objects:

[list_begin definitions]

[call [arg graphName] [method destroy]]

Destroy the graph, including its storage space and associated command.

[call [arg graphName] [method {arc append}] [arg arc] [opt "-key [arg key]"] [arg value]]

Appends a [arg value] to one of the keyed values associated with an
[arg arc]. If no [arg key] is specified, the key [const data] is
assumed.


[call [arg graphName] [method {arc delete}] [arg arc] [opt "[arg arc] ..."]]

Remove the specified arcs from the graph.


[call [arg graphName] [method {arc exists}] [arg arc]]

Return true if the specified [arg arc] exists in the graph.


[call [arg graphName] [method {arc get}] [arg arc] [opt "-key [arg key]"]]

Return the value associated with the key [arg key] for the [arg arc].
If no key is specified, the key [const data] is assumed.

[call [arg graphName] [method {arc getall}] [arg arc]]

Returns a serialized list of key/value pairs (suitable for use with
[lb][cmd {array set}][rb]) for the [arg arc].


[call [arg graphName] [method {arc keys}] [arg arc]]

Returns a list of keys for the [arg arc].


[call [arg graphName] [method {arc keyexists}] [arg arc] [opt "-key [arg key]"]]

Return true if the specified [arg key] exists for the [arg arc]. If no
[arg key] is specified, the key [const data] is assumed.


[call [arg graphName] [method {arc insert}] [arg start] [arg end] [opt [arg child]]]

Insert an arc named [arg child] into the graph beginning at the node
[arg start] and ending at the node [arg end]. If the name of the new
arc is not specified the system will generate a unique name of the
form [emph arc][arg x].


[call [arg graphName] [method {arc lappend}] [arg arc] [opt "-key [arg key]"] [arg value]]

Appends a [arg value] (as a list) to one of the keyed values
associated with an [arg arc].  If no [arg key] is specified, the key
[const data] is assumed.


[call [arg graphName] [method {arc set}] [arg arc] [opt "-key [arg key]"] [opt [arg value]]]

Set or get one of the keyed values associated with an arc.  If no key
is specified, the key [const data] is assumed.  Each arc that is
added to a graph has the empty string assigned to the key

[const data] automatically.  An arc may have any number of keyed
values associated with it.  If [arg value] is not specified, this
command returns the current value assigned to the key; if [arg value]
is specified, this command assigns that value to the key.


[call [arg graphName] [method {arc source}] [arg arc]]

Return the node the given [arg arc] begins at.


[call [arg graphName] [method {arc target}] [arg arc]]

Return the node the given [arg arc] ends at.


[call [arg graphName] [method {arc unset}] [arg arc] [opt "-key [arg key]"]]

Remove a keyed value from the arc [arg arc].  If no key is specified,
the key [const data] is assumed.


[call [arg graphName] [method arcs] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-in|-out|-adj|-inner|-embedding [arg nodelist]"]]

Return a list of arcs in the graph. If no restriction is specified a
list containing all arcs is returned. Restrictions can limit the list
of returned arcs based on the nodes that are connected by the arc, on
the keyed values associated with the arc, or both. The restrictions
that involve connected nodes have a list of nodes as argument,
specified after the name of the restriction itself.

[list_begin definitions]
[lst_item [option -in]]

Return a list of all arcs whose target is one of the nodes in the
[arg nodelist].

[lst_item [option -out]]

Return a list of all arcs whose source is one of the nodes in the
[arg nodelist].

[lst_item [option -adj]]

Return a list of all arcs adjacent to at least one of the nodes in the
[arg nodelist]. This is the union of the nodes returned by

[option -in] and [option -out].

[lst_item [option -inner]]

Return a list of all arcs adjacent to two of the nodes in the

[arg nodelist]. This is the set of arcs in the subgraph spawned by the
specified nodes.

[lst_item [option -embedding]]

Return a list of all arcs adjacent to exactly one of the nodes in the
[arg nodelist]. This is the set of arcs connecting the subgraph
spawned by the specified nodes to the rest of the graph.

[lst_item "[option -key] [arg key]"]

Limit the list of arcs that are returned to those arcs that have an
associated key [arg key].

[lst_item "[option -value] [arg value]"]

This restriction can only be used in combination with

[option -key]. It limits the list of arcs that are returned to those
arcs whose associated key [arg key] has the value [arg value].

[list_end]

[call [arg graphName] [method {node append}] [arg node] [opt "-key [arg key]"] [arg value]]

Appends a [arg value] to one of the keyed values associated with an
[arg node]. If no [arg key] is specified, the key [const data] is
assumed.


[call [arg graphName] [method {node degree}] [opt -in|-out] [arg node]]

Return the number of arcs adjacent to the specified [arg node]. If one
of the restrictions [option -in] or [option -out] is given only the
incoming resp. outgoing arcs are counted.


[call [arg graphName] [method {node delete}] [arg node] [opt "[arg node] ..."]]

Remove the specified nodes from the graph.  All of the nodes' arcs
will be removed as well to prevent unconnected arcs.


[call [arg graphName] [method {node exists}] [arg node]]

Return true if the specified [arg node] exists in the graph.


[call [arg graphName] [method {node get}] [arg node] [opt "-key [arg key]"]]

Return the value associated with the key [arg key] for the [arg node].
If no key is specified, the key [const data] is assumed.

[call [arg graphName] [method {node getall}] [arg node]]

Returns a serialized list of key/value pairs (suitable for use with
[lb][cmd {array set}][rb]) for the [arg node].


[call [arg graphName] [method {node keys}] [arg node]]

Returns a list of keys for the [arg node].


[call [arg graphName] [method {node keyexists}] [arg node] [opt "-key [arg key]"]]

Return true if the specified [arg key] exists for the [arg node]. If
no [arg key] is specified, the key [const data] is assumed.


[call [arg graphName] [method {node insert}] [opt [arg child]]]

Insert a node named [arg child] into the graph. The nodes has no arcs
connected to it. If the name of the new child is not specified the
system will generate a unique name of the form [emph node][arg x].

[call [arg graphName] [method {node lappend}] [arg node] [opt "-key [arg key]"] [arg value]]

Appends a [arg value] (as a list) to one of the keyed values
associated with an [arg node]. If no [arg key] is specified, the key
[const data] is assumed.


[call [arg graphName] [method {node opposite}] [arg node] [arg arc]]

Return the node at the other end of the specified [arg arc], which has
to be adjacent to the given [arg node].


[call [arg graphName] [method {node set}] [arg node] [opt "-key [arg key]"] [opt [arg value]]]

Set or get one of the keyed values associated with a node.  If no key
is specified, the key [const data] is assumed.  Each node that is
added to a graph has the empty string assigned to the key

[const data] automatically.  A node may have any number of keyed
values associated with it.  If [arg value] is not specified, this
command returns the current value assigned to the key; if [arg value]
is specified, this command assigns that value to the key.


[call [arg graphName] [method {node unset}] [arg node] [opt "-key [arg key]"]]

Remove a keyed value from the node [arg node].  If no key is
specified, the key [method data] is assumed.

[call [arg graphName] [method nodes] [opt "-key [arg key]"] [opt "-value [arg value]"] [opt "-in|-out|-adj|-inner|-embedding [arg nodelist]"]]

Return a list of nodes in the graph. Restrictions can limit the list
of returned nodes based on neighboring nodes, or based on the keyed
values associated with the node. The restrictions that involve
neighboring nodes have a list of nodes as argument, specified after
the name of the restriction itself.

[nl]

The possible restrictions are the same as for method

[method arcs]. The set of nodes to return is computed as the union of
all source and target nodes for all the arcs satisfying the
restriction as defined for [method arcs].


[call [arg graphName] [method get] [opt "-key [arg key]"]]

Return the value associated with the key [arg key] for the graph. If
no key is specified, the key [const data] is assumed.


[call [arg graphName] [method getall]]

Returns a serialized list of key/value pairs (suitable for use with
[lb][cmd {array set}][rb]) for the whole graph.


[call [arg graphName] [method keys]]

Returns a list of keys for the whole graph.


[call [arg graphName] [method keyexists] [opt "-key [arg key]"]]

Return true if the specified [arg key] exists for the whole graph. If no
[arg key] is specified, the key [const data] is assumed.


[call [arg graphName] [method set] [opt "-key [arg key]"] [opt [arg value]]]

Set or get one of the keyed values associated with a graph. If no key
is specified, the key [const data] is assumed. Each graph has the
empty string assigned to the key [const data] automatically. A graph
may have any number of keyed values associated with it. If [arg value]
is not specified, this command returns the current value assigned to
the key; if [arg value] is specified, this command assigns that value
to the key.


[call [arg graphName] [method swap] [arg node1] [arg node2]]

Swap the position of [arg node1] and [arg node2] in the graph.


[call [arg graphName] [method unset] [opt "-key [arg key]"]]

Remove a keyed value from the graph. If no key is specified, the key
[const data] is assumed.

[call [arg graphName] [method walk] [arg node] [opt "-order [arg order]"] [opt "-type [arg type]"] [opt "-dir [arg direction]"] -command [arg cmd]]

Perform a breadth-first or depth-first walk of the graph starting at
the node [arg node] going in either the direction of outgoing or
opposite to the incoming arcs.

[nl]

The type of walk, breadth-first or depth-first, is determined by the
value of [arg type]; [const bfs] indicates breadth-first,

[const dfs] indicates depth-first.  Depth-first is the default.

[nl]

The order of the walk, pre-order, post-order or both-order is
determined by the value of [arg order]; [const pre] indicates
pre-order, [const post] indicates post-order, [const both] indicates
both-order. Pre-order is the default. Pre-order walking means that a
node is visited before any of its neighbors (as defined by the

[arg direction], see below). Post-order walking means that a parent is
visited after any of its neighbors. Both-order walking means that a
node is visited before [emph and] after any of its neighbors. The
combination of a bread-first walk with post- or both-order is illegal.

[nl]

The direction of the walk is determined by the value of [arg dir];
[const backward] indicates the direction opposite to the incoming
arcs, [const forward] indicates the direction of the outgoing arcs.

[nl]

As the walk progresses, the command [arg cmd] will be evaluated at
each node, with the mode of the call ([const enter] or
[const leave]) and values [arg graphName] and the name of the current
node appended. For a pre-order walk, all nodes are [const enter]ed, for a
post-order all nodes are left. In a both-order walk the first visit of
a node [const enter]s it, the second visit [const leave]s it.

[list_end]

[keywords graph cgraph]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/graph.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: graph.n,v 1.8 2002/02/01 22:59:08 andreas_kupries Exp $
'\" 
.so man.macros
.TH graph n 1.2.1 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::graph \- Create and manipulate directed graph objects
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require struct ?1.2.1?\fR
.sp
\fB::struct::graph\fR \fIgraphName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::graph\fR command creates a new graph object with an
associated global Tcl command whose name is \fIgraphName\fR.  This command
may be used to invoke various operations on the graph.
It has the
following general form:
.CS
\fIgraphName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.
.PP
A directed graph is a structure containing two collections of
elements, called \fInodes\fR and \fIarcs\fR resp., together with a
relation ("connectivity") that places a general structure upon the
nodes and arcs.

Each arc is connected to two nodes, one of which is called the
\fIsource\fR and the other the \fItarget\fR. This imposes a direction
upon the arc, which is said to go from the source to the target. It is
allowed that source and target of an arc are the same node. Such an
arc is called a \fIloop\fR. Whenever a node is source or target of an
arc both are said to be \fIadjacent\fR. This extends into a relation
between nodes, i.e. if two nodes are connected through at least one
arc they are said to be \fIadjacent\fR too.

Each node can be the source and target for any number of arcs. The
former are called the \fIoutgoing arcs\fR of the node, the latter the
\fIincoming arcs\fR of the node. The number of edges in either set is
called the \fIin-\fR resp. the \fIout-degree\fR of the node.

In addition to maintaining the node and arc relationships, this graph
implementation allows any number of keyed values to be associated with
each node and arc.
.PP
The following commands are possible for graph objects:
.TP
\fIgraphName \fBdestroy\fR
Destroy the graph, including its storage space and associated command.
.TP
\fIgraphName\fR \fBarc delete\fR \fIarc\fR ?\fIarc\fR ...?
Remove the specified arcs from the graph.
.TP
\fIgraphName\fR \fBarc exists\fR \fIarc\fR
Return true if the specified \fIarc\fR exists in the graph.
.TP
\fIgraphName\fR \fBarc get\fR \fIarc\fR ?\fI-key key\fR?
Return the value associated with the key \fIkey\fR for the
\fIarc\fR.  If no key is specified, the key \fBdata\fR is assumed.
.TP
\fIgraphName \fBarc insert\fR \fIstart\fR \fIend\fR ?\fIchild\fR?
Insert an arc named \fIchild\fR into the graph beginning at the node
\fIstart\fR and ending at the node \fIend\fR. If the name of the new
arc is not specified the system will generate a unique name of the
form \fBarc\fR\fIx\fR.
.TP
\fIgraphName\fR \fBarc set\fR \fIarc\fR ?\fI-key key\fR? ?\fIvalue\fR?
Set or get one of the keyed values associated with an arc.  If no key
is specified, the key \fBdata\fR is assumed.  Each arc that is added
to a graph has the value "" assigned to the key \fBdata\fR
automatically.  An arc may have any number of keyed values associated
with it.  If \fIvalue\fR is not specified, this command returns the
current value assigned to the key; if \fIvalue\fR is specified, this
command assigns that value to the key.
.TP
\fIgraphName\fR \fBarc source\fR \fIarc\fR
Return the node the given \fIarc\fR begins at.
.TP
\fIgraphName\fR \fBarc target\fR \fIarc\fR
Return the node the given \fIarc\fR ends at.
.TP
\fIgraphName\fR \fBarc unset\fR \fIarc\fR ?\fI-key key\fR?
Remove a keyed value from the arc \fIarc\fR.  If no key is
specified, the key \fBdata\fR is assumed.
.TP
\fIgraphName\fR \fBarcs\fR ?-key \fIkey\fR? ?-value \fIvalue\fR? ?-in|-out|-adj|-inner|-embedding \fInodelist\fR?
Return a list of arcs in the graph. If no restriction is specified a
list containing all arcs is returned. Restrictions can limit the list
of returned arcs based on the nodes that are connected by the arc, on
the keyed values associated with the arc, or both. The restrictions
that involve connected nodes have a list of nodes as argument,
specified after the name of the restriction itself.
.RS
.TP
\fB-in\fR
Return a list of all arcs whose target is one of the nodes in the
\fInodelist\fR.
.TP
\fB-out\fR
Return a list of all arcs whose source is one of the nodes in the
\fInodelist\fR.
.TP
\fB-adj\fR
Return a list of all arcs adjacent to at least one of the nodes in
the \fInodelist\fR. This is the union of the nodes returned by
\fB-in\fR and \fB-out\fR.
.TP
\fB-inner\fR
Return a list of all arcs adjacent to two of the nodes in the
\fInodelist\fR. This is the set of arcs in the subgraph spawned by
the specified nodes.
.TP
\fB-embedding\fR
Return a list of all arcs adjacent to exactly one of the nodes in the
\fInodelist\fR. This is the set of arcs connecting the subgraph
spawned by the specified nodes to the rest of the graph.
.TP
\fB-key\fR \fIkey\fR
Limit the list of arcs that are returned to those arcs that have an
associated key \fIkey\fR.
.TP
\fB-value\fR \fIvalue\fR
This restriction can only be used in combination with \fB-key\fR. It
limits the list of arcs that are returned to those arcs whose
associated key \fIkey\fR has the value \fIvalue\fR.
.RE
.TP
\fIgraphName\fR \fBnode degree\fR ?-in|-out? \fInode\fR
Return the number of arcs adjacent to the specified \fInode\fR. If
one of the restrictions \fB-in\fR or \fB-out\fR is given only the
incoming resp. outgoing arcs are counted.
.TP
\fIgraphName\fR \fBnode delete\fR \fInode\fR ?\fInode\fR ...?
Remove the specified nodes from the graph.  All of the nodes' arcs
will be removed as well to prevent unconnected arcs.
.TP
\fIgraphName\fR \fBnode exists\fR \fInode\fR
Return true if the specified \fInode\fR exists in the graph.
.TP
\fIgraphName\fR \fBnode get\fR \fInode\fR ?\fI-key key\fR?
Return the value associated with the key \fIkey\fR for the
\fInode\fR.  If no key is specified, the key \fBdata\fR is assumed.
.TP
\fIgraphName \fBnode insert\fR ?\fIchild\fR?
Insert a node named \fIchild\fR into the graph. The nodes has no arcs
connected to it. If the name of the new child is not specified the
system will generate a unique name of the form \fBnode\fR\fIx\fR.
.TP
\fIgraphName\fR \fBnode opposite\fR \fInode\fR \fIarc\fR
Return the node at the other end of the specified \fIarc\fR, which
has to be adjacent to the given \fInode\fR.
.TP
\fIgraphName\fR \fBnode set\fR \fInode\fR ?\fI-key key\fR? ?\fIvalue\fR?
Set or get one of the keyed values associated with a node.  If no key
is specified, the key \fBdata\fR is assumed.  Each node that is added
to a graph has the value "" assigned to the key \fBdata\fR
automatically.  A node may have any number of keyed values associated
with it.  If \fIvalue\fR is not specified, this command returns the
current value assigned to the key; if \fIvalue\fR is specified, this
command assigns that value to the key.
.TP
\fIgraphName\fR \fBnode unset\fR \fInode\fR ?\fI-key key\fR?
Remove a keyed value from the node \fInode\fR.  If no key is
specified, the key \fBdata\fR is assumed.
.TP
\fIgraphName\fR \fBnodes\fR ?-key \fIkey\fR? ?-value \fIvalue\fR? ?-in|-out|-adj|-inner|-embedding \fInodelist\fR?
Return a list of nodes in the graph. Restrictions can limit the list
of returned nodes based on neighboring nodes, or based on the keyed
values associated with the node. The restrictions that involve
neighboring nodes have a list of nodes as argument, specified after
the name of the restriction itself.
.sp
The possible restrictions are the same as for method \fBarcs\fR. The
set of nodes to return is computed as the union of all source and
target nodes for all the arcs satisfying the restriction as defined
for \fBarcs\fR.
.TP
\fIgraphName\fR \fBget\fR ?\fI-key key\fR?
Return the value associated with the key \fIkey\fR for the graph. If
no key is specified, the key \fBdata\fR is assumed.
.TP
\fIgraphName\fR \fBset\fR ?\fI-key key\fR? ?\fIvalue\fR?
Set or get one of the keyed values associated with a graph. If no key
is specified, the key \fBdata\fR is assumed. Each graph has the value
"" assigned to the key \fBdata\fR automatically. A graph may have any
number of keyed values associated with it. If \fIvalue\fR is not
specified, this command returns the current value assigned to the key;
if \fIvalue\fR is specified, this command assigns that value to the
key.
.TP
\fIgraphName\fR \fBswap\fR \fInode1\fR \fInode2\fR
Swap the position of \fInode1\fR and \fInode2\fR in the graph.
.TP
\fIgraphName\fR \fBunset\fR ?\fI-key key\fR?
Remove a keyed value from the graph. If no key is specified, the key
\fBdata\fR is assumed.
.TP
\fIgraphName\fR \fBwalk\fR \fInode\fR ?\fI-order order\fR? ?\fI-type type\fR? ?\fI-dir direction\fR? \fI-command cmd\fR

Perform a breadth-first or depth-first walk of the graph starting at
the node \fInode\fR going in either the direction of outgoing or
opposite to the incoming arcs.

The type of walk, breadth-first or depth-first, is determined by the
value of \fItype\fR; \fBbfs\fR indicates breadth-first, \fBdfs\fR
indicates depth-first.  Depth-first is the default.

The order of the walk, pre-order, post-order or both-order is
determined by the value of \fIorder\fR; \fBpre\fR indicates pre-order,
\fBpost\fR indicates post-order, \fBboth\fR indicates
both-order. Pre-order is the default. Pre-order walking means that a
node is visited before any of its neighbors (as defined by the
\fIdirection\fR, see below). Post-order walking means that a parent is
visited after any of its neighbors. Both-order walking means that a
node is visited before \fBand\fR after any of its neighbors. The
combination of a bread-first walk with post- or both-order is illegal.

The direction of the walk is determined by the value of \fIdir\fR;
\fBbackward\fR indicates the direction opposite to the incoming arcs,
\fBforward\fR indicates the direction of the outgoing arcs.

As the walk progresses, the command \fIcmd\fR will be evaluated at
each node, with the mode of the call (\fBenter\fR or \fBleave\fR) and
values \fIgraphName\fR and the name of the current node appended. For
a pre-order walk all nodes are Bentered, for a post-order all nodes
are left. In a both-order walk the first visit of a node \fBenter\fRs
it, the second visit \fBleave\fRs it.

.SH KEYWORDS
graph
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































Deleted modules/struct/graph.tcl.

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

# Create the namespace before determining cgraph vs. tcl
# Otherwise the loading 'struct.tcl' may get into trouble
# when trying to import commands from them

namespace eval ::struct {}
namespace eval ::struct::graph {}

# Try to load the cgraph package
# Get it at http://physnet.uni-oldenburg.de/~schlenk/tcl/graph/ 

if {![catch {package require cgraph 0.6}]} {
    # the cgraph package takes over, so we can return
    return
}

namespace eval ::struct {}
namespace eval ::struct::graph {
    # Data storage in the graph module
    # -------------------------------
    #
    # There's a lot of bits to keep track of for each graph:
    #	nodes
    #	node values
    #	node relationships (arcs)
    #   arc values
    #
    # It would quickly become unwieldy to try to keep these in arrays or lists
    # within the graph namespace itself.  Instead, each graph structure will
    # get its own namespace.  Each namespace contains:
    #	node:$node	array mapping keys to values for the node $node
    #	arc:$arc	array mapping keys to values for the arc $arc
    #	inArcs		array mapping nodes to the list of incoming arcs
    #	outArcs		array mapping nodes to the list of outgoing arcs
    #	arcNodes	array mapping arcs to the two nodes (start & end)
    
    # counter is used to give a unique name for unnamed graph
    variable counter 0

    # commands is the list of subcommands recognized by the graph
    variable commands [list	\
	    "arc"		\
	    "arcs"		\
	    "destroy"		\
	    "get"		\
	    "getall"		\
	    "keys"		\
	    "keyexists"		\
	    "node"		\
	    "nodes"		\
	    "set"		\
	    "swap"		\
	    "unset"             \
	    "walk"		\
	    ]

    variable arcCommands [list	\
	    "append"	\
	    "delete"	\
	    "exists"	\
	    "get"	\
	    "getall"	\
	    "insert"	\
	    "keys"	\
	    "keyexists"	\
	    "lappend"	\
	    "set"	\
	    "source"	\
	    "target"	\
	    "unset"	\
	    ]

    variable nodeCommands [list	\
	    "append"	\
	    "degree"	\
	    "delete"	\
	    "exists"	\
	    "get"	\
	    "getall"	\
	    "insert"	\
	    "keys"	\
	    "keyexists"	\
	    "lappend"	\
	    "opposite"	\
	    "set"	\
	    "unset"	\
	    ]

    # Only export one command, the one used to instantiate a new graph
    namespace export graph
}

# ::struct::graph::graph --
#
#	Create a new graph with a given name; if no name is given, use
#	graphX, where X is a number.
#
# Arguments:
#	name	name of the graph; if null, generate one.
#
# Results:
#	name	name of the graph created

proc ::struct::graph::graph {{name ""}} {
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "graph${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create graph"
    }

    # Set up the namespace
    namespace eval ::struct::graph::graph$name {

	# Set up the map for values associated with the graph itself
	variable graphData
	array set graphData {data ""}

	# Set up the map from nodes to the arcs coming to them
	variable  inArcs
	array set inArcs {}

	# Set up the map from nodes to the arcs going out from them
	variable  outArcs
	array set outArcs {}

	# Set up the map from arcs to the nodes they touch.
	variable  arcNodes
	array set arcNodes {}

	# Set up a value for use in creating unique node names
	variable nextUnusedNode
	set nextUnusedNode 1

	# Set up a value for use in creating unique arc names
	variable nextUnusedArc
	set nextUnusedArc 1
    }

    # Create the command to manipulate the graph
    interp alias {} ::$name {} ::struct::graph::GraphProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::graph::GraphProc --
#
#	Command that processes all graph object commands.
#
# Arguments:
#	name	name of the graph object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::graph::GraphProc {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 ::struct::graph::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::graph::_$cmd $name] $args
}

# ::struct::graph::_arc --
#
#	Dispatches the invocation of arc methods to the proper handler
#	procedure.
#
# Arguments:
#	name	name of the graph.
#	cmd	arc command to invoke
#	args	arguments to propagate to the handler for the arc command
#
# Results:
#	As of the invoked handler.

proc ::struct::graph::_arc {name cmd args} {

    # Split the args into command and args components
    if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } {
	variable arcCommands
	set optlist [join $arcCommands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }

    eval [list ::struct::graph::__arc_$cmd $name] $args
}

# ::struct::graph::__arc_delete --
#
#	Remove an arc from a graph, including all of its values.
#
# Arguments:
#	name	name of the graph.
#	args	list of arcs to delete.
#
# Results:
#	None.

proc ::struct::graph::__arc_delete {name args} {

    foreach arc $args {
	if { ![__arc_exists $name $arc] } {
	    error "arc \"$arc\" does not exist in graph \"$name\""
	}
    }

    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs
    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    foreach arc $args {
	foreach {source target} $arcNodes($arc) break ; # lassign

	unset arcNodes($arc)
	# FRINK: nocheck
	unset ::struct::graph::graph${name}::arc$arc

	# Remove arc from the arc lists of source and target nodes.

	set index            [lsearch -exact $outArcs($source) $arc]
	set outArcs($source) [lreplace       $outArcs($source) $index $index]

	set index            [lsearch -exact $inArcs($target)  $arc]
	set inArcs($target)  [lreplace       $inArcs($target)  $index $index]
    }

    return
}

# ::struct::graph::__arc_exists --
#
#	Test for existance of a given arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to look for.
#
# Results:
#	1 if the arc exists, 0 else.

proc ::struct::graph::__arc_exists {name arc} {
    return [info exists ::struct::graph::graph${name}::arcNodes($arc)]
}

# ::struct::graph::__arc_get --
#
#	Get a keyed value from an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::arc${arc} data

    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for arc \"$arc\""
    }

    return $data($key)
}

# ::struct::graph::__arc_getall --
#
#	Get a serialized array of key/value pairs from an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#
# Results:
#	value	serialized array of key/value pairs.

proc ::struct::graph::__arc_getall {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    if { [llength $args] } {
	error "wrong # args: should be none"
    }
    
    upvar ::struct::graph::graph${name}::arc${arc} data

    return [array get data]
}

# ::struct::graph::__arc_keys --
#
#	Get a list of keys for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__arc_keys {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    if { [llength $args] } {
	error "wrong # args: should be none"
    }    

    upvar ::struct::graph::graph${name}::arc${arc} data

    return [array names data]
}

# ::struct::graph::__arc_keyexists --
#
#	Test for existance of a given key for a given arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	1 if the key exists, 0 else.

proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    if { ![string equal $flag "-key"] } {
	error "invalid option \"$flag\": should be -key"
    }
    
    upvar ::struct::graph::graph${name}::arc${arc} data

    return [info exists data($key)]
}

# ::struct::graph::__arc_insert --
#
#	Add an arc to a graph.
#
# Arguments:
#	name		name of the graph.
#	source		source node of the new arc
#	target		target node of the new arc
#	args		arc to insert; must be unique.  If none is given,
#			the routine will generate a unique node name.
#
# Results:
#	arc		The name of the new arc.

proc ::struct::graph::__arc_insert {name source target args} {

    if { [llength $args] == 0 } {
	# No arc name was given; generate a unique one
	set arc [__generateUniqueArcName $name]
    } else {
	set arc [lindex $args 0]
    }

    if { [__arc_exists $name $arc] } {
	error "arc \"$arc\" already exists in graph \"$name\""
    }
    
    if { ![__node_exists $name $source] } {
	error "source node \"$source\" does not exist in graph \"$name\""
    }
    
    if { ![__node_exists $name $target] } {
	error "target node \"$target\" does not exist in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::inArcs    inArcs
    upvar ::struct::graph::graph${name}::outArcs   outArcs
    upvar ::struct::graph::graph${name}::arcNodes  arcNodes
    upvar ::struct::graph::graph${name}::arc${arc} data

    # Set up the new arc
    set data(data)       ""
    set arcNodes($arc) [list $source $target]

    # Add this arc to the arc lists of its source resp. target nodes.
    lappend outArcs($source) $arc
    lappend inArcs($target)  $arc

    return $arc
}

# ::struct::graph::__arc_set --
#
#	Set or get a value for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify or query.
#	args	?-key key? ?value?
#
# Results:
#	val	value associated with the given key of the given arc

proc ::struct::graph::__arc_set {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arc$arc data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name arc set $arc ?-key key?\
		?value?\""
    }
    
    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for arc \"$arc\""
	}
	return $data($key)
    }
}

# ::struct::graph::__arc_append --
#
#	Append a value for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given arc

proc ::struct::graph::__arc_append {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arc$arc data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name arc append $arc ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [append data($key) $value]
}

# ::struct::graph::__arc_lappend --
#
#	lappend a value for an arc in a graph.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given arc

proc ::struct::graph::__arc_lappend {name arc args} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arc$arc data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name arc lappend $arc ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [lappend data($key) $value]
}

# ::struct::graph::__arc_source --
#
#	Return the node at the beginning of the specified arc.
#
# Arguments:
#	name	name of the graph object.
#	arc	arc to look up.
#
# Results:
#	node	name of the node.

proc ::struct::graph::__arc_source {name arc} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arcNodes arcNodes
    return [lindex $arcNodes($arc) 0]
}

# ::struct::graph::__arc_target --
#
#	Return the node at the end of the specified arc.
#
# Arguments:
#	name	name of the graph object.
#	arc	arc to look up.
#
# Results:
#	node	name of the node.

proc ::struct::graph::__arc_target {name arc} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arcNodes arcNodes
    return [lindex $arcNodes($arc) 1]
}

# ::struct::graph::__arc_unset --
#
#	Remove a keyed value from a arc.
#
# Arguments:
#	name	name of the graph.
#	arc	arc to modify.
#	args	additional args: ?-key key?
#
# Results:
#	None.

proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} {
    if { ![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name arc unset\
		$arc ?-key key?\""
    }

    upvar ::struct::graph::graph${name}::arc${arc} data
    if { [info exists data($key)] } {
	unset data($key)
    }
    return
}

# ::struct::graph::_arcs --
#
#	Return a list of all arcs in a graph satisfying some
#	node based restriction.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	arcs	list of arcs

proc ::struct::graph::_arcs {name args} {

    # Discriminate between conditions and nodes

    set haveCond 0
    set haveKey 0
    set haveValue 0
    set cond "none"
    set condNodes [list]

    for {set i 0} {$i < [llength $args]} {incr i} {
	set arg [lindex $args $i]
	switch -glob -- $arg {
	    -in -
	    -out -
	    -adj -
	    -inner -
	    -embedding {
		set haveCond 1
		set cond [string range $arg 1 end]
	    }
	    -key {
		incr i
		set key [lindex $args $i]
		set haveKey 1
	    }
	    -value {
		incr i
		set value [lindex $args $i]
		set haveValue 1
	    }
	    -* {
		error "invalid restriction \"$arg\": should be -in, -out,\
			-adj, -inner, -embedding, -key or -value"
	    }
	    default {
		lappend condNodes $arg
	    }
	}
    }

    # Validate that there are nodes to use in the restriction.
    # otherwise what's the point?
    if {$haveCond} {
	if {[llength $condNodes] == 0} {
	    set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"
	    error "no nodes specified: should be \"$usage\""
	}

	# Make sure that the specified nodes exist!
	foreach node $condNodes {
	    if { ![__node_exists $name $node] } {
		error "node \"$node\" does not exist in graph \"$name\""
	    }
	}
    }

    # Now we are able to go to work
    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs
    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    set       arcs [list]

    switch -exact -- $cond {
	in {
	    # Result is all arcs going to at least one node
	    # in the list of arguments.

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    # As an arc has only one destination, i.e. is the
		    # in-arc of exactly one node it is impossible to
		    # count an arc twice. IOW the [info exists] below
		    # is never true. Found through coverage analysis
		    # and then trying to think up a testcase invoking
		    # the continue.
		    # if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    #set     coll($e) .
		}
	    }
	}
	out {
	    # Result is all arcs coming from at least one node
	    # in the list of arguments.

	    foreach node $condNodes {
		foreach e $outArcs($node) {
		    # See above 'in', same reasoning, one source per arc.
		    # if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    #set     coll($e) .
		}
	    }
	}
	adj {
	    # Result is all arcs coming from or going to at
	    # least one node in the list of arguments.

	    array set coll  {}
	    # Here we do need 'coll' as each might be an in- and
	    # out-arc for one or two nodes in the list of arguments.

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
		foreach e $outArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	inner {
	    # Result is all arcs running between nodes in the list.

	    array set coll  {}
	    # Here we do need 'coll' as each might be an in- and
	    # out-arc for one or two nodes in the list of arguments.

	    array set group {}
	    foreach node $condNodes {
		set group($node) .
	    }

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    set     coll($e) .
		}
	    }
	}
	embedding {
	    # Result is all arcs from -adj minus the arcs from -inner.
	    # IOW all arcs going from a node in the list to a node
	    # which is *not* in the list

	    # This also means that no arc can be counted twice as it
	    # is either going to a node, or coming from a node in the
	    # list, but it can't do both, because then it is part of
	    # -inner, which was excluded!

	    array set group {}
	    foreach node $condNodes {
		set group($node) .
	    }

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists group($n)]} {continue}
		    # if {[info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    # set     coll($e) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists group($n)]} {continue}
		    # if {[info exists coll($e)]}  {continue}
		    lappend arcs    $e
		    # set     coll($e) .
		}
	    }
	}
	none {
	    set arcs [array names arcNodes]
	}
	default {error "Can't happen, panic"}
    }

    #
    # We have a list of arcs that match the relation to the nodes.
    # Now filter according to -key and -value.
    #

    set filteredArcs [list]

    if {$haveKey} {
	foreach arc $arcs {
	    catch {
		set aval [__arc_get $name $arc -key $key]
		if {$haveValue} {
		    if {$aval == $value} {
			lappend filteredArcs $arc
		    }
		} else {
		    lappend filteredArcs $arc
		}
	    }
	}
    } else {
	set filteredArcs $arcs
    }

    return $filteredArcs
}

# ::struct::graph::_destroy --
#
#	Destroy a graph, including its associated command and data storage.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	None.

proc ::struct::graph::_destroy {name} {
    namespace delete ::struct::graph::graph$name
    interp alias {} ::$name {}
}

# ::struct::graph::__generateUniqueArcName --
#
#	Generate a unique arc name for the given graph.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	arc	name of a arc guaranteed to not exist in the graph.

proc ::struct::graph::__generateUniqueArcName {name} {
    upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc
    while {[__arc_exists $name "arc${nextUnusedArc}"]} {
	incr nextUnusedArc
    }
    return "arc${nextUnusedArc}"
}

# ::struct::graph::__generateUniqueNodeName --
#
#	Generate a unique node name for the given graph.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	node	name of a node guaranteed to not exist in the graph.

proc ::struct::graph::__generateUniqueNodeName {name} {
    upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode
    while {[__node_exists $name "node${nextUnusedNode}"]} {
	incr nextUnusedNode
    }
    return "node${nextUnusedNode}"
}

# ::struct::graph::_get --
#
#	Get a keyed value from the graph itself
#
# Arguments:
#	name	name of the graph.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::_get {name {flag -key} {key data}} {
    upvar ::struct::graph::graph${name}::graphData data

    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for graph \"$name\""
    }

    return $data($key)
}

# ::struct::graph::_getall --
#
#	Get a serialized list of key/value pairs from a graph.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::_getall {name args} { 
    if { [llength $args] } {
	error "wrong # args: should be none"
    }
    
    upvar ::struct::graph::graph${name}::graphData data
    return [array get data]
}

# ::struct::graph::_keys --
#
#	Get a list of keys from a graph.
#
# Arguments:
#	name	name of the graph.
#
# Results:
#	value	list of known keys

proc ::struct::graph::_keys {name args} { 
    if { [llength $args] } {
	error "wrong # args: should be none"
    }

    upvar ::struct::graph::graph${name}::graphData data
    return [array names data]
}

# ::struct::graph::_keyexists --
#
#	Test for existance of a given key in a graph.
#
# Arguments:
#	name	name of the graph.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	1 if the key exists, 0 else.

proc ::struct::graph::_keyexists {name {flag -key} {key data}} {
    if { ![string equal $flag "-key"] } {
	error "invalid option \"$flag\": should be -key"
    }
    
    upvar ::struct::graph::graph${name}::graphData data
    return [info exists data($key)]
}

# ::struct::graph::_node --
#
#	Dispatches the invocation of node methods to the proper handler
#	procedure.
#
# Arguments:
#	name	name of the graph.
#	cmd	node command to invoke
#	args	arguments to propagate to the handler for the node command
#
# Results:
#	As of the the invoked handler.

proc ::struct::graph::_node {name cmd args} {

    # Split the args into command and args components
    if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } {
	variable nodeCommands
	set optlist [join $nodeCommands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }

    eval [list ::struct::graph::__node_$cmd $name] $args
}

# ::struct::graph::__node_degree --
#
#	Return the number of arcs adjacent to the specified node.
#	If one of the restrictions -in or -out is given only
#	incoming resp. outgoing arcs are counted.
#
# Arguments:
#	name	name of the graph.
#	args	option, followed by the node.
#
# Results:
#	None.

proc ::struct::graph::__node_degree {name args} {

    if {([llength $args] < 1) || ([llength $args] > 2)} {
	error "wrong # args: should be \"$name node degree ?-in|-out? node\""
    }

    switch -exact -- [llength $args] {
	1 {
	    set opt {}
	    set node [lindex $args 0]
	}
	2 {
	    set opt  [lindex $args 0]
	    set node [lindex $args 1]
	}
	default {error "Can't happen, panic"}
    }

    # Validate the option.

    switch -exact -- $opt {
	{}   -
	-in  -
	-out {}
	default {
	    error "invalid option \"$opt\": should be -in or -out"
	}
    }

    # Validate the node

    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs

    switch -exact -- $opt {
	-in  {
	    set result [llength $inArcs($node)]
	}
	-out {
	    set result [llength $outArcs($node)]
	}
	{} {
	    set result [expr {[llength $inArcs($node)] \
		    + [llength $outArcs($node)]}]

	    # loops count twice, don't do <set> arithmetics, i.e. no union!
	    if {0} {
		array set coll  {}
		set result [llength $inArcs($node)]

		foreach e $inArcs($node) {
		    set coll($e) .
		}
		foreach e $outArcs($node) {
		    if {[info exists coll($e)]} {continue}
		    incr result
		    set     coll($e) .
		}
	    }
	}
	default {error "Can't happen, panic"}
    }

    return $result
}

# ::struct::graph::__node_delete --
#
#	Remove a node from a graph, including all of its values.
#	Additionally removes the arcs connected to this node.
#
# Arguments:
#	name	name of the graph.
#	args	list of the nodes to delete.
#
# Results:
#	None.

proc ::struct::graph::__node_delete {name args} {

    foreach node $args {
	if { ![__node_exists $name $node] } {
	    error "node \"$node\" does not exist in graph \"$name\""
	}
    }

    upvar ::struct::graph::graph${name}::inArcs  inArcs
    upvar ::struct::graph::graph${name}::outArcs outArcs

    foreach node $args {
	# Remove all the arcs connected to this node
	foreach e $inArcs($node) {
	    __arc_delete $name $e
	}
	foreach e $outArcs($node) {
	    # Check existence to avoid problems with
	    # loops (they are in and out arcs! at
	    # the same time and thus already deleted)
	    if { [__arc_exists $name $e] } {
		__arc_delete $name $e
	    }
	}

	unset inArcs($node)
	unset outArcs($node)
	# FRINK: nocheck
	unset ::struct::graph::graph${name}::node$node
    }

    return
}

# ::struct::graph::__node_exists --
#
#	Test for existance of a given node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to look for.
#
# Results:
#	1 if the node exists, 0 else.

proc ::struct::graph::__node_exists {name node} {
    return [info exists ::struct::graph::graph${name}::inArcs($node)]
}

# ::struct::graph::__node_get --
#
#	Get a keyed value from a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__node_get {name node {flag -key} {key data}} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::node${node} data

    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for node \"$node\""
    }

    return $data($key)
}

# ::struct::graph::__node_getall --
#
#	Get a serialized list of key/value pairs from a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__node_getall {name node args} { 
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }

    if { [llength $args] } {
	error "wrong # args: should be none"
    }
    
    upvar ::struct::graph::graph${name}::node${node} data

    return [array get data]
}

# ::struct::graph::__node_keys --
#
#	Get a list of keys from a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::__node_keys {name node args} { 
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if { [llength $args] } {
	error "wrong # args: should be none"
    }

    upvar ::struct::graph::graph${name}::node${node} data

    return [array names data]
}

# ::struct::graph::__node_keyexists --
#
#	Test for existance of a given key for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to query.
#	flag	-key; anything else is an error
#	key	key to lookup; defaults to data
#
# Results:
#	1 if the key exists, 0 else.

proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if { ![string equal $flag "-key"] } {
	error "invalid option \"$flag\": should be -key"
    }
    
    upvar ::struct::graph::graph${name}::node${node} data

    return [info exists data($key)]
}

# ::struct::graph::__node_insert --
#
#	Add a node to a graph.
#
# Arguments:
#	name		name of the graph.
#	args		node to insert; must be unique.  If none is given,
#			the routine will generate a unique node name.
#
# Results:
#	node		The namee of the new node.

proc ::struct::graph::__node_insert {name args} {

    if { [llength $args] == 0 } {
	# No node name was given; generate a unique one
	set node [__generateUniqueNodeName $name]
    } else {
	set node [lindex $args 0]
    }

    if { [__node_exists $name $node] } {
	error "node \"$node\" already exists in graph \"$name\""
    }
    
    upvar ::struct::graph::graph${name}::inArcs      inArcs
    upvar ::struct::graph::graph${name}::outArcs     outArcs
    upvar ::struct::graph::graph${name}::node${node} data

    # Set up the new node
    set inArcs($node)  [list]
    set outArcs($node) [list]
    set data(data) ""

    return $node
}

# ::struct::graph::__node_opposite --
#
#	Retrieve node opposite to the specified one, along the arc.
#
# Arguments:
#	name		name of the graph.
#	node		node to look up.
#	arc		arc to look up.
#
# Results:
#	nodex	Node opposite to <node,arc>

proc ::struct::graph::__node_opposite {name node arc} {
    if {![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if {![__arc_exists $name $arc] } {
	error "arc \"$arc\" does not exist in graph \"$name\""
    }

    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    # Node must be connected to at least one end of the arc.

    if {[string equal $node [lindex $arcNodes($arc) 0]]} {
	set result [lindex $arcNodes($arc) 1]
    } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} {
	set result [lindex $arcNodes($arc) 0]
    } else {
	error "node \"$node\" and arc \"$arc\" are not connected\
		in graph \"$name\""
    }

    return $result
}

# ::struct::graph::__node_set --
#
#	Set or get a value for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify or query.
#	args	?-key key? ?value?
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::graph::__node_set {name node args} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    upvar ::struct::graph::graph${name}::node$node data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name node set $node ?-key key?\
		?value?\""
    }
    
    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for node \"$node\""
	}
	return $data($key)
    }
}

# ::struct::graph::__node_append --
#
#	Append a value for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::graph::__node_append {name node args} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    upvar ::struct::graph::graph${name}::node$node data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name node append $node ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [append data($key) $value]
}

# ::struct::graph::__node_lappend --
#
#	lappend a value for a node in a graph.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify or query.
#	args	?-key key? value
#
# Results:
#	val	value associated with the given key of the given node

proc ::struct::graph::__node_lappend {name node args} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    upvar ::struct::graph::graph${name}::node$node data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name node lappend $node ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [lappend data($key) $value]
}

# ::struct::graph::__node_unset --
#
#	Remove a keyed value from a node.
#
# Arguments:
#	name	name of the graph.
#	node	node to modify.
#	args	additional args: ?-key key?
#
# Results:
#	None.

proc ::struct::graph::__node_unset {name node {flag -key} {key data}} {
    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name node unset\
		$node ?-key key?\""
    }

    upvar ::struct::graph::graph${name}::node${node} data
    if { [info exists data($key)] } {
	unset data($key)
    }
    return
}

# ::struct::graph::_nodes --
#
#	Return a list of all nodes in a graph satisfying some restriction.
#
# Arguments:
#	name	name of the graph.
#	args	list of options and nodes specifying the restriction.
#
# Results:
#	nodes	list of nodes

proc ::struct::graph::_nodes {name args} {

    # Discriminate between conditions and nodes

    set haveCond 0
    set haveKey 0
    set haveValue 0
    set cond "none"
    set condNodes [list]

    for {set i 0} {$i < [llength $args]} {incr i} {
	set arg [lindex $args $i]
	switch -glob -- $arg {
	    -in -
	    -out -
	    -adj -
	    -inner -
	    -embedding {
		set haveCond 1
		set cond [string range $arg 1 end]
	    }
	    -key {
		incr i
		set key [lindex $args $i]
		set haveKey 1
	    }
	    -value {
		incr i
		set value [lindex $args $i]
		set haveValue 1
	    }
	    -* {
		error "invalid restriction \"$arg\": should be -in, -out,\
			-adj, -inner, -embedding, -key or -value"
	    }
	    default {
		lappend condNodes $arg
	    }
	}
    }

    # Validate that there are nodes to use in the restriction.
    # otherwise what's the point?
    if {$haveCond} {
	if {[llength $condNodes] == 0} {
	    set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"
	    error "no nodes specified: should be \"$usage\""
	}

	# Make sure that the specified nodes exist!
	foreach node $condNodes {
	    if { ![__node_exists $name $node] } {
		error "node \"$node\" does not exist in graph \"$name\""
	    }
	}
    }

    # Now we are able to go to work
    upvar ::struct::graph::graph${name}::inArcs   inArcs
    upvar ::struct::graph::graph${name}::outArcs  outArcs
    upvar ::struct::graph::graph${name}::arcNodes arcNodes

    set       nodes [list]
    array set coll  {}

    switch -exact -- $cond {
	in {
	    # Result is all nodes with at least one arc going to
	    # at least one node in the list of arguments.

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	out {
	    # Result is all nodes with at least one arc coming from
	    # at least one node in the list of arguments.

	    foreach node $condNodes {
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	adj {
	    # Result is all nodes with at least one arc coming from
	    # or going to at least one node in the list of arguments.

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists coll($n)]} {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	inner {
	    # Result is all nodes from the list! with at least one arc
	    # coming from or going to at least one node in the list of
	    # arguments.

	    array set group {}
	    foreach node $condNodes {
		set group($node) .
	    }

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {![info exists group($n)]} {continue}
		    if { [info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	embedding {
	    # Result is all nodes with at least one arc coming from
	    # or going to at least one node in the list of arguments,
	    # but not in the list itself!

	    array set group {}
	    foreach node $condNodes {
		set group($node) .
	    }

	    foreach node $condNodes {
		foreach e $inArcs($node) {
		    set n [lindex $arcNodes($e) 0]
		    if {[info exists group($n)]} {continue}
		    if {[info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
		foreach e $outArcs($node) {
		    set n [lindex $arcNodes($e) 1]
		    if {[info exists group($n)]} {continue}
		    if {[info exists coll($n)]}  {continue}
		    lappend nodes    $n
		    set     coll($n) .
		}
	    }
	}
	none {
	    set nodes [array names inArcs]
	}
	default {error "Can't happen, panic"}
    }

    #
    # We have a list of nodes that match the relation to the nodes.
    # Now filter according to -key and -value.
    #

    set filteredNodes [list]

    if {$haveKey} {
	foreach node $nodes {
	    catch {
		set nval [__node_get $name $node -key $key]
		if {$haveValue} {
		    if {$nval == $value} {
			lappend filteredNodes $node
		    }
		} else {
		    lappend filteredNodes $node
		}
	    }
	}
    } else {
	set filteredNodes $nodes
    }

    return $filteredNodes
}

# ::struct::graph::_set --
#
#	Set or get a keyed value from the graph itself
#
# Arguments:
#	name	name of the graph.
#	flag	-key; anything else is an error
#	args	?-key key? ?value?
#
# Results:
#	value	value associated with the key given.

proc ::struct::graph::_set {name args} {
    upvar ::struct::graph::graph${name}::graphData data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name set ?-key key?\
		?value?\""
    }

    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for graph \"$name\""
	}
	return $data($key)
    }
}

# ::struct::graph::_swap --
#
#	Swap two nodes in a graph.
#
# Arguments:
#	name	name of the graph.
#	node1	first node to swap.
#	node2	second node to swap.
#
# Results:
#	None.

proc ::struct::graph::_swap {name node1 node2} {
    # Can only swap two real nodes
    if { ![__node_exists $name $node1] } {
	error "node \"$node1\" does not exist in graph \"$name\""
    }
    if { ![__node_exists $name $node2] } {
	error "node \"$node2\" does not exist in graph \"$name\""
    }

    # Can't swap a node with itself
    if { [string equal $node1 $node2] } {
	error "cannot swap node \"$node1\" with itself"
    }

    # Swapping nodes means swapping their labels, values and arcs
    upvar ::struct::graph::graph${name}::outArcs      outArcs
    upvar ::struct::graph::graph${name}::inArcs       inArcs
    upvar ::struct::graph::graph${name}::arcNodes     arcNodes
    upvar ::struct::graph::graph${name}::node${node1} node1Vals
    upvar ::struct::graph::graph${name}::node${node2} node2Vals

    # Redirect arcs to the new nodes.

    foreach e $inArcs($node1) {
	set arcNodes($e) [lreplace $arcNodes($e) end end $node2]
    }
    foreach e $inArcs($node2) {
	set arcNodes($e) [lreplace $arcNodes($e) end end $node1]
    }
    foreach e $outArcs($node1) {
	set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2]
    }
    foreach e $outArcs($node2) {
	set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1]
    }

    # Swap arc lists

    set tmp            $inArcs($node1)
    set inArcs($node1) $inArcs($node2)
    set inArcs($node2) $tmp

    set tmp             $outArcs($node1)
    set outArcs($node1) $outArcs($node2)
    set outArcs($node2) $tmp

    # Swap the values
    set   value1        [array get node1Vals]
    unset node1Vals
    array set node1Vals [array get node2Vals]
    unset node2Vals
    array set node2Vals $value1

    return
}

# ::struct::graph::_unset --
#
#	Remove a keyed value from the graph itself
#
# Arguments:
#	name	name of the graph.
#	flag	-key; anything else is an error
#	args	additional args: ?-key key?
#
# Results:
#	None.

proc ::struct::graph::_unset {name {flag -key} {key data}} {
    upvar ::struct::graph::graph${name}::graphData data
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name unset\
		?-key key?\""
    }

    if { [info exists data($key)] } {
	unset data($key)
    }

    return
}

# ::struct::graph::_walk --
#
#	Walk a graph using a pre-order depth or breadth first
#	search. Pre-order DFS is the default.  At each node that is visited,
#	a command will be called with the name of the graph and the node.
#
# Arguments:
#	name	name of the graph.
#	node	node at which to start.
#	args	additional args: ?-order pre|post|both? ?-type {bfs|dfs}?
#		-command cmd
#
# Results:
#	None.

proc ::struct::graph::_walk {name node args} {
    set usage "$name walk $node ?-dir forward|backward?\
	    ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd"

    if {[llength $args] > 8 || [llength $args] < 2} {
	error "wrong # args: should be \"$usage\""
    }

    if { ![__node_exists $name $node] } {
	error "node \"$node\" does not exist in graph \"$name\""
    }

    # Set defaults
    set type  dfs
    set order pre
    set cmd   ""
    set dir   forward

    # Process specified options
    for {set i 0} {$i < [llength $args]} {incr i} {
	set flag [lindex $args $i]
	incr i
	if { $i >= [llength $args] } {
	    error "value for \"$flag\" missing: should be \"$usage\""
	}
	switch -glob -- $flag {
	    "-type" {
		set type [string tolower [lindex $args $i]]
	    }
	    "-order" {
		set order [string tolower [lindex $args $i]]
	    }
	    "-command" {
		set cmd [lindex $args $i]
	    }
	    "-dir" {
		set dir [string tolower [lindex $args $i]]
	    }
	    default {
		error "unknown option \"$flag\": should be \"$usage\""
	    }
	}
    }
    
    # Make sure we have a command to run, otherwise what's the point?
    if { [string equal $cmd ""] } {
	error "no command specified: should be \"$usage\""
    }

    # Validate that the given type is good
    switch -glob -- $type {
	"dfs" {
	    set type "dfs"
	}
	"bfs" {
	    set type "bfs"
	}
	default {
	    error "invalid search type \"$type\": should be dfs, or bfs"
	}
    }
    
    # Validate that the given order is good
    switch -glob -- $order {
	"both" {
	    set order both
	}
	"pre" {
	    set order pre
	}
	"post" {
	    set order post
	}
	default {
	    error "invalid search order \"$order\": should be both,\
		    pre or post"
	}
    }

    # Validate that the given direction is good
    switch -glob -- $dir {
	"forward" {
	    set dir -out
	}
	"backward" {
	    set dir -in
	}
	default {
	    error "invalid search direction \"$dir\": should be\
		    forward or backward"
	}
    }

    # Do the walk

    set st [list ]
    lappend st $node
    array set visited {}

    if { [string equal $type "dfs"] } {
	if { [string equal $order "pre"] } {
	    # Pre-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex   $st end]
		set st   [lreplace $st end end]

		# Evaluate the command at this node
		set cmdcpy $cmd
		lappend cmdcpy enter $name $node
		uplevel 2 $cmdcpy

		set visited($node) .

		# Add this node's neighbours (according to direction)
		#  Have to add them in reverse order
		#  so that they will be popped left-to-right

		set next [_nodes $name $dir $node]
		set len  [llength $next]

		for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
		    set nextnode [lindex $next $i]
		    if {[info exists visited($nextnode)]} {
			# Skip nodes already visited
			continue
		    }
		    lappend st $nextnode
		}
	    }
	} elseif { [string equal $order "post"] } {
	    # Post-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex $st end]

		if {[info exists visited($node)]} {
		    # Second time we are here, pop it,
		    # then evaluate the command.

		    set st [lreplace $st end end]

		    # Evaluate the command at this node
		    set cmdcpy $cmd
		    lappend cmdcpy leave $name $node
		    uplevel 2 $cmdcpy
		} else {
		    # First visit. Remember it.
		    set visited($node) .
	    
		    # Add this node's neighbours.
		    set next [_nodes $name $dir $node]
		    set len  [llength $next]

		    for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
			set nextnode [lindex $next $i]
			if {[info exists visited($nextnode)]} {
			    # Skip nodes already visited
			    continue
			}
			lappend st $nextnode
		    }
		}
	    }
	} else {
	    # Both-order Depth-first search

	    while { [llength $st] > 0 } {
		set node [lindex $st end]

		if {[info exists visited($node)]} {
		    # Second time we are here, pop it,
		    # then evaluate the command.

		    set st [lreplace $st end end]

		    # Evaluate the command at this node
		    set cmdcpy $cmd
		    lappend cmdcpy leave $name $node
		    uplevel 2 $cmdcpy
		} else {
		    # First visit. Remember it.
		    set visited($node) .

		    # Evaluate the command at this node
		    set cmdcpy $cmd
		    lappend cmdcpy enter $name $node
		    uplevel 2 $cmdcpy
	    
		    # Add this node's neighbours.
		    set next [_nodes $name $dir $node]
		    set len  [llength $next]

		    for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
			set nextnode [lindex $next $i]
			if {[info exists visited($nextnode)]} {
			    # Skip nodes already visited
			    continue
			}
			lappend st $nextnode
		    }
		}
	    }
	}

    } else {
	if { [string equal $order "pre"] } {
	    # Pre-order Breadth first search
	    while { [llength $st] > 0 } {
		set node [lindex $st 0]
		set st   [lreplace $st 0 0]
		# Evaluate the command at this node
		set cmdcpy $cmd
		lappend cmdcpy enter $name $node
		uplevel 2 $cmdcpy
	    
		set visited($node) .

		# Add this node's neighbours.
		foreach child [_nodes $name $dir $node] {
		    if {[info exists visited($child)]} {
			# Skip nodes already visited
			continue
		    }
		    lappend st $child
		}
	    }
	} else {
	    # Post-order Breadth first search
	    # Both-order Breadth first search
	    # Haven't found anything in Knuth
	    # and unable to define something
	    # consistent for myself. Leave it
	    # out.

	    error "unable to do a ${order}-order breadth first walk"
	}
    }
    return
}

# ::struct::graph::Union --
#
#	Return a list which is the union of the elements
#	in the specified lists.
#
# Arguments:
#	args	list of lists representing sets.
#
# Results:
#	set	list representing the union of the argument lists.

proc ::struct::graph::Union {args} {
    switch -- [llength $args] {
	0 {
	    return {}
	}
	1 {
	    return [lindex $args 0]
	}
	default {
	    foreach set $args {
		foreach e $set {
		    set tmp($e) .
		}
	    }
	    return [array names tmp]
	}
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/graph.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] graph.tcl]
namespace import ::struct::graph::graph

catch {puts "-- cgraph [package present cgraph]"}



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

test graph-0.1 {graph errors} {
    graph mygraph
    catch {graph mygraph} msg
    mygraph destroy
    set msg
} "command \"mygraph\" already exists, unable to create graph"

test graph-0.2 {graph errors} {
    graph mygraph
    catch {mygraph} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph option ?arg arg ...?\""

test graph-0.3 {graph errors} {
    graph mygraph
    catch {mygraph foo} msg
    mygraph destroy
    set msg
} "bad option \"foo\": must be arc, arcs, destroy, get, getall, keys, keyexists, node, nodes, set, swap, unset, or walk"

test graph-0.4 {graph errors} {
    catch {graph set} msg
    set msg
} "command \"set\" already exists, unable to create graph"

test graph-0.5 {graph errors} {
    graph mygraph
    catch {mygraph arc foo} msg
    mygraph destroy
    set msg
} "bad option \"foo\": must be append, delete, exists, get, getall, insert, keys, keyexists, lappend, set, source, target, or unset"

test graph-0.6 {graph errors} {
    graph mygraph
    catch {mygraph node foo} msg
    mygraph destroy
    set msg
} "bad option \"foo\": must be append, degree, delete, exists, get, getall, insert, keys, keyexists, lappend, opposite, set, or unset"

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

test graph-1.1 {create} {
    graph mygraph
    set result [string equal [info commands ::mygraph] "::mygraph"]
    mygraph destroy
    set result
} 1

test graph-1.2 {create} {
    set name [graph]
    set result [list $name [string equal [info commands ::$name] "::$name"]]
    $name destroy
    set result
} [list graph1 1]

test graph-1.3 {destroy} {
    graph mygraph
    mygraph destroy
    string equal [info commands ::mygraph] ""
} 1

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

test graph-2.1 {arc delete} {
    graph mygraph
    catch {mygraph arc delete arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-2.2 {arc delete} {
    graph mygraph

    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    mygraph arc  delete arc0

    set result [mygraph arc exists arc0]
    mygraph destroy
    set result
} {0}

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

test graph-3.1 {arc exists} {
    graph mygraph
    set     result [list]
    lappend result [mygraph arc exists arc1]
    mygraph node insert node1
    mygraph node insert node2
    mygraph arc  insert node1 node2 arc1
    lappend result [mygraph arc exists arc1]
    mygraph arc  delete arc1
    lappend result [mygraph arc exists arc1]
    mygraph destroy
    set     result
} {0 1 0}

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

test graph-4.1 {arc get gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc get arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-4.2 {arc get gives error on bogus key} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc get arc0 -key bogus} msg
    mygraph destroy
    set msg
} "invalid key \"bogus\" for arc \"arc0\""

test graph-4.3 {arc get uses data as default key} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 foobar
    set result [mygraph arc get arc0]
    mygraph destroy
    set result
} "foobar"

test graph-4.4 {arc get respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key boom foobar
    set result [mygraph arc get arc0 -key boom]
    mygraph destroy
    set result
} "foobar"

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

test graph-5.1 {arc insert gives error on duplicate arc name} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc insert node0 node1 arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" already exists in graph \"mygraph\""

test graph-5.2 {arc insert creates and initializes arc} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    set result [list ]
    lappend result [mygraph arc exists arc0]
    lappend result [mygraph arc source arc0]
    lappend result [mygraph arc target arc0]
    lappend result [mygraph arc set arc0]
    mygraph destroy
    set result
} {1 node0 node1 {}}

test graph-5.3 {arc insert arcs in correct location} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1

    mygraph arc insert node0 node1 arc0
    mygraph arc insert node0 node1 arc1
    mygraph arc insert node0 node1 arc2
    set result [lsort [mygraph arcs -out node0]]
    mygraph destroy
    set result
} {arc0 arc1 arc2}

test graph-5.4 {arc insert gives error when trying to insert to a fake node} {
    graph mygraph
    catch {mygraph arc insert node0 node1 arc0} msg
    mygraph destroy
    set msg
} "source node \"node0\" does not exist in graph \"mygraph\""

test graph-5.5 {arc insert gives error when trying to insert to a fake node} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph arc insert node0 node1 arc0} msg
    mygraph destroy
    set msg
} "target node \"node1\" does not exist in graph \"mygraph\""

test graph-5.6 {arc insert generates arc name when none is given} {
    graph mygraph
    mygraph node insert n0

    set     result [list [mygraph arc insert n0 n0]]
    lappend result       [mygraph arc insert n0 n0]
    mygraph                       arc insert n0 n0 arc3
    lappend result       [mygraph arc insert n0 n0]
    mygraph destroy
    set result
} [list arc1 arc2 arc4]

if {0} {
    # if feature used, fix this test...
    test graph-5.6 {arc insert generates arc name when none is given} {
	graph mygraph
	set result [list [mygraph insert root end]]
	lappend result [mygraph insert root end]
	mygraph insert root end arc3
	lappend result [mygraph insert root end]
	mygraph destroy
	set result
    } [list arc1 arc2 arc4] ; # {}
}

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

test graph-6.1 {arc set gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc set arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-6.2 {arc set with arc name gets/sets "data" value} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 foobar
    set result [mygraph arc set arc0]
    mygraph destroy
    set result
} "foobar"

test graph-6.3 {arc set with arc name and key gets/sets key value} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key baz foobar
    set result [list [mygraph arc set arc0] [mygraph arc set arc0 -key baz]]
    mygraph destroy
    set result
} [list "" "foobar"]

test graph-6.4 {arc set with too many args gives error} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc set arc0 foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph arc set arc0 ?-key key? ?value?\""

test graph-6.5 {arc set with bad args} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc set arc0 foo bar} msg
    mygraph destroy
    set msg
} "invalid option \"foo\": should be key"

test graph-6.6 {arc set with bad args} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc set arc0 foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"foo\": should be key"

test graph-6.7 {arc set with bad key gives error} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc set arc0 -key foo} msg
    mygraph destroy
    set msg
} "invalid key \"foo\" for arc \"arc0\""

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

test graph-7.1 {arc source gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc source arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-7.2 {arc source} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    set result [mygraph arc source arc0]
    mygraph destroy
    set result
} node0

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

test graph-8.1 {arc target gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc target arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-8.2 {arc target} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    set result [mygraph arc target arc0]
    mygraph destroy
    set result
} node1

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

test graph-9.1 {arc unset gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc unset arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-9.2 {arc unset does not give error on bogus key} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    set result [catch {mygraph arc unset arc0 -key bogus}]
    mygraph destroy
    set result
} 0

test graph-9.3 {arc unset removes a keyed value from a arc} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    mygraph arc        set arc0 -key foobar foobar
    mygraph arc      unset arc0 -key foobar
    catch {mygraph arc get arc0 -key foobar} msg
    mygraph destroy
    set msg
} "invalid key \"foobar\" for arc \"arc0\""

test graph-9.4 {arc unset requires -key} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    mygraph arc        set arc0 -key foobar foobar
    catch {mygraph arc unset arc0 flaboozle foobar} msg
    mygraph destroy
    set msg
} "invalid option \"flaboozle\": should be \"mygraph arc unset arc0 ?-key key?\""

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

test graph-10.1 {arcs} {
    graph mygraph
    set result [mygraph arcs]
    mygraph destroy
    set result
} {}

test graph-10.2 {arcs} {
    graph mygraph
    catch {mygraph arcs -foo} msg
    mygraph destroy
    set msg
} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value}

test graph-10.3 {arcs} {
    graph mygraph
    catch {mygraph arcs -in} msg
    mygraph destroy
    set msg
} {no nodes specified: should be "mygraph arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"}

test graph-10.4 {arcs} {
    graph mygraph
    catch {mygraph arcs -in node0} msg
    mygraph destroy
    set msg
} {node "node0" does not exist in graph "mygraph"}

test graph-10.5 {arcs} {
    graph mygraph
    mygraph node insert node1
    mygraph node insert node2
    mygraph node insert node3
    mygraph node insert node4
    mygraph node insert node5
    mygraph node insert node6

    mygraph arc insert node4 node1 arcA
    mygraph arc insert node5 node2 arcB
    mygraph arc insert node6 node3 arcC
    mygraph arc insert node3 node1 arcD
    mygraph arc insert node1 node2 arcE
    mygraph arc insert node2 node3 arcF

    set result [list \
	    [lsort [mygraph arcs            ]] \
	    \
	    [lsort [mygraph arcs -in        node1 node2 node3]] \
	    [lsort [mygraph arcs -out       node1 node2 node3]] \
	    [lsort [mygraph arcs -adj       node1 node2 node3]] \
	    [lsort [mygraph arcs -inner     node1 node2 node3]] \
	    [lsort [mygraph arcs -embedding node1 node2 node3]] \
	    \
	    [lsort [mygraph arcs -in        node4 node5 node6]] \
	    [lsort [mygraph arcs -out       node4 node5 node6]] \
	    [lsort [mygraph arcs -adj       node4 node5 node6]] \
	    [lsort [mygraph arcs -inner     node4 node5 node6]] \
	    [lsort [mygraph arcs -embedding node4 node5 node6]] \
    ]
    mygraph destroy
    set result
} [list \
	{arcA arcB arcC arcD arcE arcF}	\
	\
	{arcA arcB arcC arcD arcE arcF}	\
	{arcD arcE arcF}		\
	{arcA arcB arcC arcD arcE arcF}	\
	{arcD arcE arcF}		\
	{arcA arcB arcC}		\
	\
	{}			\
	{arcA arcB arcC}	\
	{arcA arcB arcC}	\
	{}			\
	{arcA arcB arcC}	\
	]

test graph-10.6 {arcs} {
    graph mygraph
    mygraph node insert node1
    mygraph node insert node2
    mygraph arc insert node1 node2 arcE
    mygraph arc insert node2 node1 arcF
    set result [lsort [mygraph arcs -adj node1 node2]]
    mygraph destroy
    set result
} {arcE arcF}

test graph-10.7 {arcs} {
    graph mygraph
    mygraph node insert n0
    mygraph node insert n1
    mygraph arc insert n0 n1 a1
    mygraph arc insert n0 n1 a2
    mygraph arc set a1 -key foobar 1
    mygraph arc set a2 -key blubber 2
    catch {mygraph arcs -key foobar} msg
    mygraph destroy
    set msg
} {a1}

test graph-10.8 {arcs} {
    graph mygraph
    mygraph node insert n0
    mygraph node insert n1
    mygraph arc insert n0 n1 a1
    mygraph arc insert n0 n1 a2
    mygraph arc set a1 -key foobar 1
    mygraph arc set a2 -key foobar 2
    catch {mygraph arcs -key foobar -value 1} msg
    mygraph destroy
    set msg
} {a1}

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

test graph-11.1 {node degree} {
    graph mygraph
    catch {mygraph node degree} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph node degree ?-in|-out? node\""

test graph-11.2 {node degree} {
    graph mygraph
    catch {mygraph node degree foo bar baz} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph node degree ?-in|-out? node\""

test graph-11.3 {node degree} {
    graph mygraph
    catch {mygraph node degree node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-11.4 {node degree} {
    graph mygraph
    catch {mygraph node degree -foo node0} msg
    mygraph destroy
    set msg
} "invalid option \"-foo\": should be -in or -out"

test graph-11.5 {node degree} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph node insert node2
    mygraph node insert node3
    mygraph node insert node4
    mygraph node insert node5

    mygraph arc insert node1 node2 arc0
    mygraph arc insert node3 node3 arc1
    mygraph arc insert node4 node5 arc2
    mygraph arc insert node4 node5 arc3
    mygraph arc insert node4 node5 arc4
    mygraph arc insert node5 node2 arc5

    set result [list	\
	    [mygraph node degree      node0]	\
	    [mygraph node degree -in  node0]	\
	    [mygraph node degree -out node0]	\
	    [mygraph node degree      node1]	\
	    [mygraph node degree -in  node1]	\
	    [mygraph node degree -out node1]	\
	    [mygraph node degree      node2]	\
	    [mygraph node degree -in  node2]	\
	    [mygraph node degree -out node2]	\
	    [mygraph node degree      node3]	\
	    [mygraph node degree -in  node3]	\
	    [mygraph node degree -out node3]	\
	    [mygraph node degree      node4]	\
	    [mygraph node degree -in  node4]	\
	    [mygraph node degree -out node4]	\
	    [mygraph node degree      node5]	\
	    [mygraph node degree -in  node5]	\
	    [mygraph node degree -out node5]	\
	    ]

    mygraph destroy
    set result
} [list	0 0 0 \
	1 0 1 \
	2 2 0 \
	2 1 1 \
	3 0 3 \
	4 3 1
	]

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

test graph-12.1 {node delete} {
    graph mygraph
    catch {mygraph node delete node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-12.2 {node delete} {
    graph mygraph
    mygraph node insert node0
    mygraph node delete node0
    set result [mygraph node exists node0]
    mygraph destroy
    set result
} {0}

test graph-12.3 {node delete} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    mygraph node delete node0

    set result [list \
	    [mygraph node exists node0] \
	    [mygraph node exists node1] \
	    [mygraph arc exists arc0]	\
	    ]
    mygraph destroy
    set result
} {0 1 0}

test graph-12.4 {node delete} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0
    mygraph node delete node1

    set result [list \
	    [mygraph node exists node0] \
	    [mygraph node exists node1] \
	    [mygraph arc exists arc0]	\
	    ]
    mygraph destroy
    set result
} {1 0 0}

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

test graph-13.1 {node exists} {
    graph mygraph
    set     result [list]
    lappend result [mygraph node exists node1]
    mygraph node insert node1
    lappend result [mygraph node exists node1]
    mygraph node delete node1
    lappend result [mygraph node exists node1]
    mygraph destroy
    set     result
} {0 1 0}

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

test graph-14.1 {node get gives error on bogus node} {
    graph mygraph
    catch {mygraph node get node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-14.2 {node get gives error on bogus key} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node get node0 -key bogus} msg
    mygraph destroy
    set msg
} "invalid key \"bogus\" for node \"node0\""

test graph-14.3 {node get uses data as default key} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 foobar
    set result [mygraph node get node0]
    mygraph destroy
    set result
} "foobar"

test graph-14.4 {node get respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key boom foobar
    set result [mygraph node get node0 -key boom]
    mygraph destroy
    set result
} "foobar"

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

test graph-15.1 {node insert gives error on duplicate node name} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node insert node0} msg
    mygraph destroy
    set msg
} "node \"node0\" already exists in graph \"mygraph\""

test graph-15.2 {node insert creates and initializes node} {
    graph mygraph
    mygraph node insert node0
    set result [list ]
    lappend result [mygraph node exists node0]
    lappend result [mygraph node set    node0]
    mygraph destroy
    set result
} {1 {}}

test graph-15.3 {node insert generates node name when none is given} {
    graph mygraph
    set result [list [mygraph node insert]]

    lappend result [mygraph node insert]
    mygraph node insert node3
    lappend result [mygraph node insert]
    mygraph destroy
    set result
} [list node1 node2 node4]

if {0} {
    # fix if this feature is used ...
    test graph-15.x {node insert generates node name when none is given} {
	graph mygraph
	set result [list [mygraph node insert root end]]
	lappend result [mygraph node insert root end]
	mygraph node insert root end node3
	lappend result [mygraph node insert root end]
	mygraph destroy
	set result
    } [list node1 node2 node4] ; # {}
}

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

test graph-16.1 {node opposite gives error on bogus node} {
    graph mygraph
    catch {mygraph node opposite node0 arc0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-16.2 {node opposite gives error on bogus arc} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node opposite node0 arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""

test graph-16.3 {node opposite gives error on bogus node/arc combination} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph node insert node2
    mygraph arc  insert node1 node2 arc0

    catch {mygraph node opposite node0 arc0} msg
    mygraph destroy
    set msg
} "node \"node0\" and arc \"arc0\" are not connected in graph \"mygraph\""

test graph-16.4 {node opposite} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc  insert node0 node1 arc0

    set result [list	\
	    [mygraph node opposite node0 arc0]	\
	    [mygraph node opposite node1 arc0]	\
	    ]
    mygraph destroy
    set result
} {node1 node0}

test graph-16.5 {node opposite} {
    graph mygraph
    mygraph node insert node0
    mygraph arc  insert node0 node0 arc0
    set result [mygraph node opposite node0 arc0]
    mygraph destroy
    set result
} {node0}

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

test graph-17.1 {node set gives error on bogus node} {
    graph mygraph
    catch {mygraph node set node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-17.2 {node set with node name gets/sets "data" value} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 foobar
    set result [mygraph node set node0]
    mygraph destroy
    set result
} "foobar"

test graph-17.3 {node set with node name and key gets/sets key value} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key baz foobar
    set result [list [mygraph node set node0] [mygraph node set node0 -key baz]]
    mygraph destroy
    set result
} [list "" "foobar"]

test graph-17.4 {node set with too many args gives error} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node set node0 foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph node set node0 ?-key key? ?value?\""

test graph-17.5 {node set with bad args} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node set node0 foo bar} msg
    mygraph destroy
    set msg
} "invalid option \"foo\": should be key"

test graph-17.6 {node set with bad args} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node set node0 foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"foo\": should be key"

test graph-17.7 {node set with bad key gives error} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node set node0 -key foo} msg
    mygraph destroy
    set msg
} "invalid key \"foo\" for node \"node0\""

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

test graph-18.1 {node unset gives error on bogus node} {
    graph mygraph
    catch {mygraph node unset node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-18.2 {node unset does not give error on bogus key} {
    graph mygraph
    mygraph node insert node0
    set result [catch {mygraph node unset node0 -key bogus}]
    mygraph destroy
    set result
} 0

test graph-18.3 {node unset removes a keyed value from a node} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key foobar foobar
    mygraph node unset node0 -key foobar
    catch {mygraph node get node0 -key foobar} msg
    mygraph destroy
    set msg
} "invalid key \"foobar\" for node \"node0\""

test graph-18.4 {unset requires -key} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key foobar foobar
    catch {mygraph node unset node0 flaboozle foobar} msg
    mygraph destroy
    set msg
} "invalid option \"flaboozle\": should be \"mygraph node unset node0 ?-key key?\""

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

test graph-19.1 {nodes} {
    graph mygraph
    set result [mygraph nodes]
    mygraph destroy
    set result
} {}

test graph-19.2 {nodes} {
    graph mygraph
    catch {mygraph nodes -foo} msg
    mygraph destroy
    set msg
} {invalid restriction "-foo": should be -in, -out, -adj, -inner, -embedding, -key or -value}

test graph-19.3 {nodes} {
    graph mygraph
    catch {mygraph nodes -in} msg
    mygraph destroy
    set msg
} {no nodes specified: should be "mygraph nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?"}

test graph-19.4 {nodes} {
    graph mygraph
    catch {mygraph nodes -in node0} msg
    mygraph destroy
    set msg
} {node "node0" does not exist in graph "mygraph"}

test graph-19.5 {nodes} {
    graph mygraph
    mygraph node insert node1
    mygraph node insert node2
    mygraph node insert node3
    mygraph node insert node4
    mygraph node insert node5
    mygraph node insert node6

    mygraph arc insert node4 node1 arcA
    mygraph arc insert node5 node2 arcB
    mygraph arc insert node6 node3 arcC
    mygraph arc insert node3 node1 arcD
    mygraph arc insert node1 node2 arcE
    mygraph arc insert node2 node3 arcF

    set result [list \
	    [lsort [mygraph nodes            ]] \
	    \
	    [lsort [mygraph nodes -in        node1 node2 node3]] \
	    [lsort [mygraph nodes -out       node1 node2 node3]] \
	    [lsort [mygraph nodes -adj       node1 node2 node3]] \
	    [lsort [mygraph nodes -inner     node1 node2 node3]] \
	    [lsort [mygraph nodes -embedding node1 node2 node3]] \
	    \
	    [lsort [mygraph nodes -in        node4 node5 node6]] \
	    [lsort [mygraph nodes -out       node4 node5 node6]] \
	    [lsort [mygraph nodes -adj       node4 node5 node6]] \
	    [lsort [mygraph nodes -inner     node4 node5 node6]] \
	    [lsort [mygraph nodes -embedding node4 node5 node6]] \
    ]
    mygraph destroy
    set result
} [list \
	{node1 node2 node3 node4 node5 node6} \
	\
	{node1 node2 node3 node4 node5 node6} \
	{node1 node2 node3} \
	{node1 node2 node3 node4 node5 node6} \
	{node1 node2 node3} \
	{node4 node5 node6} \
	\
	{} \
	{node1 node2 node3} \
	{node1 node2 node3} \
	{} \
	{node1 node2 node3} \
	]

test graph-19.6 {nodes} {
    graph mygraph
    mygraph node insert node1
    mygraph node insert node2
    mygraph node insert node3

    mygraph arc insert node1 node2 arcE
    mygraph arc insert node1 node2 arcD
    mygraph arc insert node2 node3 arcF
    mygraph arc insert node2 node3 arcG

    set result [lsort [mygraph nodes -embedding node1 node3]]
    mygraph destroy
    set result
} {node2}


test graph-19.7 {nodes} {
    graph mygraph
    mygraph node insert n0
    mygraph node insert n1
    mygraph node set n0 -key foobar 1
    mygraph node set n1 -key blubber 2
    catch {mygraph nodes -key foobar} msg
    mygraph destroy
    set msg
} {n0}

test graph-19.8 {nodes} {
    graph mygraph
    mygraph node insert n0
    mygraph node insert n1
    mygraph node set n0 -key foobar 1
    mygraph node set n1 -key foobar 2
    catch {mygraph nodes -key foobar -value 1} msg
    mygraph destroy
    set msg
} {n0}


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

test graph-20.1 {swap gives error when trying to swap non existant node} {
    graph mygraph
    catch {mygraph swap node0 node1} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-20.2 {swap gives error when trying to swap non existant node} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph swap node0 node1} msg
    mygraph destroy
    set msg
} "node \"node1\" does not exist in graph \"mygraph\""

test graph-20.3 {swap gives error when trying to swap node with self} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph swap node0 node0} msg
    mygraph destroy
    set msg
} "cannot swap node \"node0\" with itself"

test graph-20.4 {swap swaps node relationships correctly} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node0.1
    mygraph node insert node0.2
    mygraph node insert node0.1.1
    mygraph node insert node0.1.2

    mygraph arc insert node0 node0.1     a1
    mygraph arc insert node0 node0.2     a2
    mygraph arc insert node0.1 node0.1.1 a3
    mygraph arc insert node0.1 node0.1.2 a4

    mygraph swap node0 node0.1

    set result [list \
	    [lsort [mygraph nodes -out node0]]   \
	    [lsort [mygraph nodes -out node0.1]] \
	    ]
    mygraph destroy
    set result
} {{node0.1.1 node0.1.2} {node0 node0.2}}

test graph-20.5 {swap swaps node relationships correctly} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node0.1
    mygraph node insert node0.2
    mygraph node insert node0.1.1
    mygraph node insert node0.1.2

    mygraph arc insert node0   node0.1   a1
    mygraph arc insert node0   node0.2   a2
    mygraph arc insert node0.1 node0.1.1 a3
    mygraph arc insert node0.1 node0.1.2 a4

    mygraph swap node0 node0.1.1

    set result [list \
	    [lsort [mygraph nodes -out node0]]   \
	    [lsort [mygraph nodes -out node0.1.1]] \
	    ]
    mygraph destroy
    set result
} {{} {node0.1 node0.2}}

test graph-20.6 {swap swaps node relationships correctly} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node0.1
    mygraph node insert node0.2
    mygraph node insert node0.1.1
    mygraph node insert node0.1.2

    mygraph arc insert node0 node0.1     a1
    mygraph arc insert node0 node0.2     a2
    mygraph arc insert node0.1 node0.1.1 a3
    mygraph arc insert node0.1 node0.1.2 a4

    mygraph swap node0.1 node0

    set result [list \
	    [lsort [mygraph nodes -out node0]]   \
	    [lsort [mygraph nodes -out node0.1]] \
	    ]
    mygraph destroy
    set result
} {{node0.1.1 node0.1.2} {node0 node0.2}}

test graph-22.1 {arc getall gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc getall arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""
test graph-22.2 {arc getall gives error when key specified} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc getall arc0 -key data} msg
    mygraph destroy
    set msg
} "wrong # args: should be none"
test graph-22.3 {arc getall with node name returns list of key/value pairs} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 foobar
    mygraph arc set arc0 -key other thing
    set results [mygraph arc getall arc0]
    mygraph destroy
    lsort $results
} "data foobar other thing"   

test graph-23.1 {node getall gives error on bogus node} {
    graph mygraph
    catch {mygraph node getall node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""
test graph-23.2 {node getall gives error when key specified} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node getall node0 -key data} msg
    mygraph destroy
    set msg
} "wrong # args: should be none"
test graph-23.3 {node getall with node name returns list of key/value pairs} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 foobar
    mygraph node set node0 -key other thing
    set results [mygraph node getall node0]
    mygraph destroy
    lsort $results
} "data foobar other thing"   

test graph-24.1 {arc keys gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc keys arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""
test graph-24.2 {arc keys gives error when key specified} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch { mygraph arc keys arc0 -key bogus } msg
    mygraph destroy
    set msg
} "wrong # args: should be none"
test graph-24.3 {arc keys with arc name returns list of keys} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key other things
    set results [mygraph arc keys arc0]
    mygraph destroy
    lsort $results
} "data other"
  
test graph-25.1 {node keys gives error on bogus node} {
    graph mygraph
    catch {mygraph node keys node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""
test graph-25.2 {node keys gives error when key specified} {
    graph mygraph
    mygraph node insert node0
    catch { mygraph node keys node0 -key bogus } msg
    mygraph destroy
    set msg
} "wrong # args: should be none"
test graph-25.3 {node keys with node name returns list of keys} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key other things
    set results [mygraph node keys node0]
    mygraph destroy
    lsort $results
} "data other"

test graph-26.1 {arc keyexists gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc keyexists arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""
test graph-26.2 {arc keyexists returns false on non-existant key} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    set result [mygraph arc keyexists arc0 -key bogus]
    mygraph destroy
    set result
} "0"
test graph-26.3 {arc keyexists uses data as default key} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    set result [mygraph arc keyexists arc0]
    mygraph destroy
    set result
} "1"
test graph-26.4 {arc keyexists respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key boom foobar
    set result [mygraph arc keyexists arc0 -key boom]
    mygraph destroy
    set result
} "1"

test graph-27.1 {node keyexists gives error on bogus node} {
    graph mygraph
    catch {mygraph node keyexists node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""
test graph-27.2 {node keyexists returns false on non-existant key} {
    graph mygraph
    mygraph node insert node0
    set result [mygraph node keyexists node0 -key bogus]
    mygraph destroy
    set result
} "0"
test graph-27.3 {node keyexists uses data as default key} {
    graph mygraph
    mygraph node insert node0
    set result [mygraph node keyexists node0]
    mygraph destroy
    set result
} "1"
test graph-27.4 {node keyexists respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key boom foobar
    set result [mygraph node keyexists node0 -key boom]
    mygraph destroy
    set result
} "1"

test graph-28.1 {arc append gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc append arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""
test graph-28.2 {arc append with arc name appends to "data" value} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 foo
    set result [mygraph arc append arc0 bar]
    mygraph destroy
    set result
} "foobar"
test graph-28.3 {arc append with arc name and key appends key value} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key baz foo
    set result [mygraph arc append arc0 -key baz bar]
    mygraph destroy
    set result
} "foobar"
test graph-28.4 {arc append with too many args gives error} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc append arc0 foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph arc append arc0 ?-key key? value\""
test graph-28.5 {arc append with bad args} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc append arc0 -foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"-foo\": should be -key"
test graph-28.6 {arc append respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key baz foo
    set result [mygraph arc append arc0 -key baz bar]
    mygraph destroy
    set result
} "foobar"

test graph-29.1 {arc lappend gives error on bogus arc} {
    graph mygraph
    catch {mygraph arc lappend arc0} msg
    mygraph destroy
    set msg
} "arc \"arc0\" does not exist in graph \"mygraph\""
test graph-29.2 {arc lappend with node arc lappends to "data" value} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 foo
    set result [mygraph arc lappend arc0 bar]
    mygraph destroy
    set result
} "foo bar"
test graph-29.3 {arc lappend with arc name and key lappends key value} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key baz foo
    set result [mygraph arc lappend arc0 -key baz bar]
    mygraph destroy
    set result
} "foo bar"
test graph-29.4 {arc lappend with too many args gives error} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc lappend arc0 foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph arc lappend arc0 ?-key key? value\""
test graph-29.5 {arc lappend with bad args} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    catch {mygraph arc lappend arc0 -foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"-foo\": should be -key"
test graph-29.6 {arc lappend respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node insert node1
    mygraph arc insert node0 node1 arc0
    mygraph arc set arc0 -key baz foo
    set result [mygraph arc lappend arc0 -key baz bar]
    mygraph destroy
    set result
} "foo bar"

test graph-30.1 {node append gives error on bogus node} {
    graph mygraph
    catch {mygraph node append node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""
test graph-30.2 {node append with node name appends to "data" value} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 foo
    set result [mygraph node append node0 bar]
    mygraph destroy
    set result
} "foobar"
test graph-30.3 {node append with node name and key appends key value} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key baz foo
    set result [mygraph node append node0 -key baz bar]
    mygraph destroy
    set result
} "foobar"
test graph-30.4 {node append with too many args gives error} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node append node0 foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph node append node0 ?-key key? value\""
test graph-30.5 {node append with bad args} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node append node0 -foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"-foo\": should be -key"
test graph-30.6 {node append respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key baz foo
    set result [mygraph node append node0 -key baz bar]
    mygraph destroy
    set result
} "foobar"

test graph-31.1 {node lappend gives error on bogus node} {
    graph mygraph
    catch {mygraph node lappend node0} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""
test graph-32.2 {node lappend with node name lappends to "data" value} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 foo
    set result [mygraph node lappend node0 bar]
    mygraph destroy
    set result
} "foo bar"
test graph-32.3 {node lappend with node name and key lappends key value} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key baz foo
    set result [mygraph node lappend node0 -key baz bar]
    mygraph destroy
    set result
} "foo bar"
test graph-32.4 {node lappend with too many args gives error} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node lappend node0 foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph node lappend node0 ?-key key? value\""
test graph-32.5 {node lappend with bad args} {
    graph mygraph
    mygraph node insert node0
    catch {mygraph node lappend node0 -foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"-foo\": should be -key"
test graph-32.6 {node lappend respects -key flag} {
    graph mygraph
    mygraph node insert node0
    mygraph node set node0 -key baz foo
    set result [mygraph node lappend node0 -key baz bar]
    mygraph destroy
    set result
} "foo bar"


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

proc makegraph {} {
    graph mygraph

    mygraph node insert i
    mygraph node insert ii
    mygraph node insert iii
    mygraph node insert iv
    mygraph node insert v
    mygraph node insert vi
    mygraph node insert vii
    mygraph node insert viii
    mygraph node insert ix

    mygraph arc insert   i    ii  1
    mygraph arc insert   ii  iii  2
    mygraph arc insert   ii  iii  3
    mygraph arc insert   ii  iii  4
    mygraph arc insert  iii   iv  5
    mygraph arc insert  iii   iv  6
    mygraph arc insert   iv    v  7
    mygraph arc insert    v   vi  8
    mygraph arc insert   vi viii  9
    mygraph arc insert viii    i 10
    mygraph arc insert    i   ix 11
    mygraph arc insert   ix   ix 12
    mygraph arc insert    i  vii 13
    mygraph arc insert  vii   vi 14
}


test graph-21.1 {walk with too few args} {badTest} {
    graph mygraph
    catch {mygraph walk} msg
    mygraph destroy
    set msg
} "no value given for parameter \"node\" to \"::struct::graph::_walk\""

test graph-21.2 {walk with too few args} {
    graph mygraph
    catch {mygraph walk node0} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph walk node0 ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\""

test graph-21.3 {walk with too many args} {
    graph mygraph
    catch {mygraph walk node0 -foo bar -baz boo -foo2 boo -foo3 baz -foo4 baz} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph walk node0 ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\""

test graph-21.4 {walk with fake node} {
    graph mygraph
    catch {mygraph walk node0 -command {}} msg
    mygraph destroy
    set msg
} "node \"node0\" does not exist in graph \"mygraph\""

test graph-21.5 {walk using unknown option} {
    makegraph
    catch {mygraph walk i -foo x -command {}} msg
    mygraph destroy
    set msg
} "unknown option \"-foo\": should be \"mygraph walk i ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\""

test graph-21.6 {walk with empty command} {
    makegraph
    catch {mygraph walk i -command {}} msg
    mygraph destroy
    set msg
} "no command specified: should be \"mygraph walk i ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\""

test graph-21.7 {walk with illegal specifications} {
    makegraph
    catch {mygraph walk i -command foo -type foo} msg
    mygraph destroy
    set msg
} "invalid search type \"foo\": should be dfs, or bfs"

test graph-21.8 {walk with illegal specifications} {
    makegraph
    catch {mygraph walk i -command foo -type dfs -dir oneway} msg
    mygraph destroy
    set msg
} "invalid search direction \"oneway\": should be forward or backward"

test graph-21.9 {walk with illegal specifications} {
    makegraph
    catch {mygraph walk i -command foo -type dfs -dir forward -order none} msg
    mygraph destroy
    set msg
} "invalid search order \"none\": should be both, pre or post"


test graph-21.10 {forward pre-order dfs is default walk} {
    makegraph
    set t [list ]
    mygraph walk i -command {lappend t}
    mygraph destroy
    set t
} [list \
	enter mygraph    i enter mygraph ii enter mygraph iii	\
	enter mygraph   iv enter mygraph  v enter mygraph  vi	\
	enter mygraph viii enter mygraph ix enter mygraph vii	\
	]

test graph-21.11 {forward post-order dfs walk} {
    makegraph
    set t [list ]
    mygraph walk i -order post -command {lappend t}
    mygraph destroy
    set t
} [list \
	leave mygraph viii leave mygraph  vi leave mygraph  v	\
	leave mygraph   iv leave mygraph iii leave mygraph ii	\
	leave mygraph   ix leave mygraph vii leave mygraph  i	\
	]

test graph-21.12 {forward both-order dfs walk} {
    makegraph
    set t [list ]
    mygraph walk i -order both -command {lappend t}
    mygraph destroy
    set t
} [list \
	enter mygraph    i enter mygraph   ii enter mygraph iii	\
	enter mygraph   iv enter mygraph    v enter mygraph  vi	\
	enter mygraph viii leave mygraph viii leave mygraph  vi \
	leave mygraph    v leave mygraph   iv leave mygraph iii	\
	leave mygraph   ii enter mygraph   ix leave mygraph  ix	\
	enter mygraph  vii leave mygraph  vii leave mygraph   i	\
	]

test graph-21.13 {forward pre-order bfs walk} {
    makegraph
    set t [list ]
    mygraph walk i -type bfs -command {lappend t}
    mygraph destroy
    set t
} [list \
	enter mygraph   i enter mygraph   ii enter mygraph ix	\
	enter mygraph vii enter mygraph  iii enter mygraph vi	\
	enter mygraph  iv enter mygraph viii enter mygraph  v	\
	]

test graph-21.14 {backward pre-order bfs walk} {
    makegraph
    set t [list ]
    mygraph walk ix -type bfs -dir backward -command {lappend t}
    mygraph destroy
    set t
} [list \
	enter mygraph ix enter mygraph   i enter mygraph viii	\
	enter mygraph vi enter mygraph   v enter mygraph  vii	\
	enter mygraph iv enter mygraph iii enter mygraph   ii	\
	]

test graph-21.15 {backward pre-order dfs walk} {
    makegraph
    set t [list ]
    mygraph walk ix -dir backward -command {lappend t}
    mygraph destroy
    set t
} [list \
	enter mygraph  ix enter mygraph  i enter mygraph viii	\
	enter mygraph  vi enter mygraph  v enter mygraph   iv	\
	enter mygraph iii enter mygraph ii enter mygraph  vii	\
	]

test graph-21.16 {backward post-order dfs walk} {
    makegraph
    set t [list ]
    mygraph walk ix -dir backward -order post -command {lappend t}
    mygraph destroy
    set t
} [list \
	leave mygraph   ii leave mygraph iii leave mygraph   iv	\
	leave mygraph    v leave mygraph vii leave mygraph   vi	\
	leave mygraph viii leave mygraph   i leave mygraph   ix	\
	]

test graph-21.17 {backward both-order dfs walk} {
    makegraph
    set t [list ]
    mygraph walk ix -dir backward -order both -command {lappend t}
    mygraph destroy
    set t
} [list \
	enter mygraph   ix enter mygraph   i enter mygraph viii	\
	enter mygraph   vi enter mygraph   v enter mygraph   iv	\
	enter mygraph  iii enter mygraph  ii leave mygraph   ii	\
	leave mygraph  iii leave mygraph  iv leave mygraph    v	\
	enter mygraph  vii leave mygraph vii leave mygraph   vi	\
	leave mygraph viii leave mygraph   i leave mygraph   ix	\
	]

test graph-21.18 {walk, option without value} {
    makegraph
    catch {mygraph walk ix -type dfs -order} msg
    mygraph destroy
    set msg
} "value for \"-order\" missing: should be \"mygraph walk ix ?-dir forward|backward? ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd\""

test graph-21.19 {forward post-order bfs walk not implemented} {
    makegraph
    catch {mygraph walk i -order post -type bfs -command {lappend t}} msg
    mygraph destroy
    set msg
} {unable to do a post-order breadth first walk}

test graph-21.20 {forward both-order bfs walk not implemented} {
    makegraph
    catch {mygraph walk i -order both -type bfs -command {lappend t}} msg
    mygraph destroy
    set msg
} {unable to do a both-order breadth first walk}

test graph-21.21 {backward post-order bfs walk not implemented} {
    makegraph
    catch {mygraph walk i -dir backward -order post -type bfs -command {lappend t}} msg
    mygraph destroy
    set msg
} {unable to do a post-order breadth first walk}

test graph-21.22 {backward both-order bfs walk not implemented} {
    makegraph
    catch {mygraph walk i -dir backward -order both -type bfs -command {lappend t}} msg
    mygraph destroy
    set msg
} {unable to do a both-order breadth first walk}


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

test graph-33.1 {get gives error on bogus key} {
    graph mygraph
    catch {mygraph get -key bogus} msg
    mygraph destroy
    set msg
} "invalid key \"bogus\" for graph \"mygraph\""

test graph-33.2 {get uses data as default key} {
    graph mygraph
    mygraph set foobar
    set result [mygraph get]
    mygraph destroy
    set result
} "foobar"

test graph-33.3 {get respects -key flag} {
    graph mygraph
    mygraph set -key boom foobar
    set result [mygraph get -key boom]
    mygraph destroy
    set result
} "foobar"

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

test graph-34.1 {set alone gets/sets "data" value} {
    graph mygraph
    mygraph set foobar
    set result [mygraph set]
    mygraph destroy
    set result
} "foobar"

test graph-34.2 {set with key gets/sets key value} {
    graph mygraph
    mygraph set -key baz foobar
    set result [list [mygraph set] [mygraph set -key baz]]
    mygraph destroy
    set result
} [list "" "foobar"]

test graph-34.3 {set with too many args gives error} {
    graph mygraph
    catch {mygraph set foo bar baz boo} msg
    mygraph destroy
    set msg
} "wrong # args: should be \"mygraph set ?-key key? ?value?\""

test graph-34.4 {set with bad args} {
    graph mygraph
    catch {mygraph set foo bar} msg
    mygraph destroy
    set msg
} "invalid option \"foo\": should be key"

test graph-34.5 {set with bad args} {
    graph mygraph
    catch {mygraph set foo bar baz} msg
    mygraph destroy
    set msg
} "invalid option \"foo\": should be key"

test graph-34.6 {set with bad key gives error} {
    graph mygraph
    catch {mygraph set -key foo} msg
    mygraph destroy
    set msg
} "invalid key \"foo\" for graph \"mygraph\""

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

test graph-35.1 {unset does not give error on bogus key} {
    graph mygraph
    set result [catch {mygraph unset -key bogus}]
    mygraph destroy
    set result
} 0

test graph-35.2 {unset removes a keyed value} {
    graph mygraph
    mygraph set -key foobar foobar
    mygraph unset -key foobar
    catch {mygraph get -key foobar} msg
    mygraph destroy
    set msg
} "invalid key \"foobar\" for graph \"mygraph\""

test graph-35.3 {unset requires -key} {
    graph mygraph
    mygraph set -key foobar foobar
    catch {mygraph unset flaboozle foobar} msg
    mygraph destroy
    set msg
} "invalid option \"flaboozle\": should be \"mygraph unset ?-key key?\""

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

test graph-36.1 {getall gives error when key specified} {
    graph mygraph
    catch {mygraph getall -key data} msg
    mygraph destroy
    set msg
} "wrong # args: should be none"
test graph-36.2 {getall returns list of key/value pairs} {
    graph mygraph
    mygraph set foobar
    mygraph set -key other thing
    set results [mygraph getall]
    mygraph destroy
    lsort $results
} "data foobar other thing"

test graph-37.1 {keys gives error when key specified} {
    graph mygraph
    catch { mygraph keys -key bogus } msg
    mygraph destroy
    set msg
} "wrong # args: should be none"
test graph-37.2 {keys returns list of keys} {
    graph mygraph
    mygraph set -key other things
    set results [mygraph keys]
    mygraph destroy
    lsort $results
} "data other"
  
test graph-38.1 {keyexists returns false on non-existant key} {
    graph mygraph
    set result [mygraph keyexists -key bogus]
    mygraph destroy
    set result
} "0"
test graph-38.2 {keyexists uses data as default key} {
    graph mygraph
    set result [mygraph keyexists]
    mygraph destroy
    set result
} "1"
test graph-38.3 {keyexists respects -key flag} {
    graph mygraph
    mygraph set -key boom foobar
    set result [mygraph keyexists -key boom]
    mygraph destroy
    set result
} "1"

# ---------------------------------------------------  
::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/list.tcl.

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

package require Tcl 8.0

namespace eval ::struct { namespace eval list {} }

namespace eval ::struct::list {
    namespace export list

    if 0 {
	# Possibly in the future.
	namespace export LongestCommonSubsequence
	namespace export LongestCommonSubsequence2
	namespace export LcsInvert
	namespace export LcsInvert2
	namespace export LcsInvertMerge
	namespace export LcsInvertMerge2
	namespace export Reverse
	namespace export Assign
	namespace export Flatten
	namespace export Map
	namespace export Fold
	namespace export Iota
	namespace export Equal
	namespace export Repeat
    }
}

##########################
# Public functions

# ::struct::list::list --
#
#	Command that access all list commands.
#
# Arguments:
#	cmd	Name of the subcommand to dispatch to.
#	args	Arguments for the subcommand.
#
# Results:
#	Whatever the result of the subcommand is.

proc ::struct::list::list {cmd args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 1 } {
	return -code error "wrong # args: should be \"$cmd ?arg arg ...?\""
    }
    set sub [string toupper [string index $cmd 0]][string range $cmd 1 end]

    if { [llength [info commands ::struct::list::$sub]] == 0 } {
	set optlist [info commands ::struct::list::L*]
	set xlist {}
	foreach p $optlist {
	    lappend xlist [string tolower [string index $p 0]][string range $p 1 end]
	}
	return -code error \
		"bad option \"$cmd\": must be [linsert [join $xlist ", "] "end-1" "or"]"
    }
    return [eval [linsert $args 0 ::struct::list::$sub]]
}

##########################
# Private functions follow
#
# Do a compatibility version of [lset] for pre-8.4 versions of Tcl.
# This version does not do multi-arg [lset]!

if { [package vcompare [package provide Tcl] 8.4] < 0 } {
    proc ::struct::list::K { x y } { set x }
    proc ::struct::list::lset { var index arg } {
	upvar 1 $var list
	set list [::lreplace [K $list [set list {}]] $index $index $arg]
    }
}

##########################
# Implementations of the functionality.
#

# ::struct::list::LongestCommonSubsequence --
#
#       Computes the longest common subsequence of two lists.
#
# Parameters:
#       sequence1, sequence2 -- Two lists to compare.
#	maxOccurs -- If provided, causes the procedure to ignore
#		     lines that appear more than $maxOccurs times
#		     in the second sequence.  See below for a discussion.
# Results:
#       Returns a list of two lists of equal length.
#       The first sublist is of indices into sequence1, and the
#       second sublist is of indices into sequence2.  Each corresponding
#       pair of indices corresponds to equal elements in the sequences;
#       the sequence returned is the longest possible.
#
# Side effects:
#       None.
#
# Notes:
#
#	While this procedure is quite rapid for many tasks of file
# comparison, its performance degrades severely if the second list
# contains many equal elements (as, for instance, when using this
# procedure to compare two files, a quarter of whose lines are blank.
# This drawback is intrinsic to the algorithm used (see the References
# for details).  One approach to dealing with this problem that is
# sometimes effective in practice is arbitrarily to exclude elements
# that appear more than a certain number of times.  This number is
# provided as the 'maxOccurs' parameter.  If frequent lines are
# excluded in this manner, they will not appear in the common subsequence
# that is computed; the result will be the longest common subsequence
# of infrequent elements.
#
#	The procedure struct::list::LongestCommonSubsequence2
# functions as a wrapper around this procedure; it computes the longest
# common subsequence of infrequent elements, and then subdivides the
# subsequences that lie between the matches to approximate the true
# longest common subsequence.
#
# References:
#	J. W. Hunt and M. D. McIlroy, "An algorithm for differential
#	file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone
#	Laboratories (1976). Available on the Web at the second
#	author's personal site: http://www.cs.dartmouth.edu/~doug/

proc ::struct::list::LongestCommonSubsequence {
    sequence1
    sequence2
    {maxOccurs 0x7fffffff}
} {
    # Construct a set of equivalence classes of lines in file 2

    set index 0
    foreach string $sequence2 {
	lappend eqv($string) $index
	incr index
    }

    # K holds descriptions of the common subsequences.
    # Initially, there is one common subsequence of length 0,
    # with a fence saying that it includes line -1 of both files.
    # The maximum subsequence length is 0; position 0 of
    # K holds a fence carrying the line following the end
    # of both files.

    lappend K [::list -1 -1 {}]
    lappend K [::list [llength $sequence1] [llength $sequence2] {}]
    set k 0

    # Walk through the first file, letting i be the index of the line and
    # string be the line itself.

    set i 0
    foreach string $sequence1 {
	# Consider each possible corresponding index j in the second file.

	if { [info exists eqv($string)]
	     && [llength $eqv($string)] <= $maxOccurs } {

	    # c is the candidate match most recently found, and r is the
	    # length of the corresponding subsequence.

	    set r 0
	    set c [lindex $K 0]

	    foreach j $eqv($string) {
		# Perform a binary search to find a candidate common
		# subsequence to which may be appended this match.

		set max $k
		set min $r
		set s [expr { $k + 1 }]
		while { $max >= $min } {
		    set mid [expr { ( $max + $min ) / 2 }]
		    set bmid [lindex [lindex $K $mid] 1]
		    if { $j == $bmid } {
			break
		    } elseif { $j < $bmid } {
			set max [expr {$mid - 1}]
		    } else {
			set s $mid
			set min [expr { $mid + 1 }]
		    }
		}

		# Go to the next match point if there is no suitable
		# candidate.

		if { $j == [lindex [lindex $K $mid] 1] || $s > $k} {
		    continue
		}

		# s is the sequence length of the longest sequence
		# to which this match point may be appended. Make
		# a new candidate match and store the old one in K
		# Set r to the length of the new candidate match.

		set newc [::list $i $j [lindex $K $s]]
		if { $r >= 0 } {
		    lset K $r $c
		}
		set c $newc
		set r [expr { $s + 1 }]

		# If we've extended the length of the longest match,
		# we're done; move the fence.

		if { $s >= $k } {
		    lappend K [lindex $K end]
		    incr k
		    break
		}
	    }

	    # Put the last candidate into the array

	    lset K $r $c
	}

	incr i
    }

    # Package the common subsequence in a convenient form

    set seta {}
    set setb {}
    set q [lindex $K $k]

    for { set i 0 } { $i < $k } {incr i } {
	lappend seta {}
	lappend setb {}
    }
    while { [lindex $q 0] >= 0 } {
	incr k -1
	lset seta $k [lindex $q 0]
	lset setb $k [lindex $q 1]
	set q [lindex $q 2]
    }

    return [::list $seta $setb]
}

# ::struct::list::LongestCommonSubsequence2 --
#
#	Derives an approximation to the longest common subsequence
#	of two lists.
#
# Parameters:
#	sequence1, sequence2 - Lists to be compared
#	maxOccurs - Parameter for imprecise matching - see below.
#
# Results:
#       Returns a list of two lists of equal length.
#       The first sublist is of indices into sequence1, and the
#       second sublist is of indices into sequence2.  Each corresponding
#       pair of indices corresponds to equal elements in the sequences;
#       the sequence returned is an approximation to the longest possible.
#
# Side effects:
#       None.
#
# Notes:
#	This procedure acts as a wrapper around the companion procedure
#	struct::list::LongestCommonSubsequence and accepts the same
#	parameters.  It first computes the longest common subsequence of
#	elements that occur no more than $maxOccurs times in the
#	second list.  Using that subsequence to align the two lists,
#	it then tries to augment the subsequence by computing the true
#	longest common subsequences of the sublists between matched pairs.

proc ::struct::list::LongestCommonSubsequence2 {
    sequence1
    sequence2
    {maxOccurs 0x7fffffff}
} {
    # Derive the longest common subsequence of elements that occur at
    # most $maxOccurs times

    foreach { l1 l2 } \
	[LongestCommonSubsequence $sequence1 $sequence2 $maxOccurs] {
	    break
	}

    # Walk through the match points in the sequence just derived.

    set result1 {}
    set result2 {}
    set n1 0
    set n2 0
    foreach i1 $l1 i2 $l2 {
	if { $i1 != $n1 && $i2 != $n2 } {
	    # The match points indicate that there are unmatched
	    # elements lying between them in both input sequences.
	    # Extract the unmatched elements and perform precise
	    # longest-common-subsequence analysis on them.

	    set subl1 [lrange $sequence1 $n1 [expr { $i1 - 1 }]]
	    set subl2 [lrange $sequence2 $n2 [expr { $i2 - 1 }]]
	    foreach { m1 m2 } [LongestCommonSubsequence $subl1 $subl2] break
	    foreach j1 $m1 j2 $m2 {
		lappend result1 [expr { $j1 + $n1 }]
		lappend result2 [expr { $j2 + $n2 }]
	    }
	}

	# Add the current match point to the result

	lappend result1 $i1
	lappend result2 $i2
	set n1 [expr { $i1 + 1 }]
	set n2 [expr { $i2 + 1 }]
    }

    # If there are unmatched elements after the last match in both files,
    # perform precise longest-common-subsequence matching on them and
    # add the result to our return.

    if { $n1 < [llength $sequence1] && $n2 < [llength $sequence2] } {
	set subl1 [lrange $sequence1 $n1 end]
	set subl2 [lrange $sequence2 $n2 end]
	foreach { m1 m2 } [LongestCommonSubsequence $subl1 $subl2] break
	foreach j1 $m1 j2 $m2 {
	    lappend result1 [expr { $j1 + $n1 }]
	    lappend result2 [expr { $j2 + $n2 }]
	}
    }

    return [::list $result1 $result2]
}

# ::struct::list::LcsInvert --
#
#	Takes the data describing a longest common subsequence of two
#	lists and inverts the information in the sense that the result
#	of this command will describe the differences between the two
#	sequences instead of the identical parts.
#
# Parameters:
#	lcsData		longest common subsequence of two lists as
#			returned by longestCommonSubsequence(2).
# Results:
#	Returns a single list whose elements describe the differences
#	between the original two sequences. Each element describes
#	one difference through three pieces, the type of the change,
#	a pair of indices in the first sequence and a pair of indices
#	into the second sequence, in this order.
#
# Side effects:
#       None.

proc ::struct::list::LcsInvert {lcsData len1 len2} {
    return [LcsInvert2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2]
}

proc ::struct::list::LcsInvert2 {idx1 idx2 len1 len2} {
    set result {}
    set last1 -1
    set last2 -1

    foreach a $idx1 b $idx2 {
	# Four possible cases.
	# a) last1 ... a and last2 ... b are not empty.
	#    This is a 'change'.
	# b) last1 ... a is empty, last2 ... b is not.
	#    This is an 'addition'.
	# c) last1 ... a is not empty, last2 ... b is empty.
	#    This is a deletion.
	# d) If both ranges are empty we can ignore the
	#    two current indices.

	set empty1 [expr {($a - $last1) <= 1}]
	set empty2 [expr {($b - $last2) <= 1}]

	if {$empty1 && $empty2} {
	    # Case (d), ignore the indices
	} elseif {$empty1} {
	    # Case (b), 'addition'.
	    incr last2 ; incr b -1
	    lappend result [::list added [::list $last1 $a] [::list $last2 $b]]
	    incr b
	} elseif {$empty2} {
	    # Case (c), 'deletion'
	    incr last1 ; incr a -1
	    lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]]
	    incr a
	} else {
	    # Case (q), 'change'.
	    incr last1 ; incr a -1
	    incr last2 ; incr b -1
	    lappend result [::list changed [::list $last1 $a] [::list $last2 $b]]
	    incr a
	    incr b
	}

	set last1 $a
	set last2 $b
    }

    # Handle the last chunk, using the information about the length of
    # the original sequences.

    set empty1 [expr {($len1 - $last1) <= 1}]
    set empty2 [expr {($len2 - $last2) <= 1}]

    if {$empty1 && $empty2} {
	# Case (d), ignore the indices
    } elseif {$empty1} {
	# Case (b), 'addition'.
	incr last2 ; incr len2 -1
	lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]]
    } elseif {$empty2} {
	# Case (c), 'deletion'
	incr last1 ; incr len1 -1
	lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]]
    } else {
	# Case (q), 'change'.
	incr last1 ; incr len1 -1
	incr last2 ; incr len2 -1
	lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]]
    }

    return $result
}

proc ::struct::list::LcsInvertMerge {lcsData len1 len2} {
    return [LcsInvertMerge2 [::lindex $lcsData 0] [::lindex $lcsData 1] $len1 $len2]
}

proc ::struct::list::LcsInvertMerge2 {idx1 idx2 len1 len2} {
    set result {}
    set last1 -1
    set last2 -1

    foreach a $idx1 b $idx2 {
	# Four possible cases.
	# a) last1 ... a and last2 ... b are not empty.
	#    This is a 'change'.
	# b) last1 ... a is empty, last2 ... b is not.
	#    This is an 'addition'.
	# c) last1 ... a is not empty, last2 ... b is empty.
	#    This is a deletion.
	# d) If both ranges are empty we can ignore the
	#    two current indices. For merging we simply
	#    take the information from the input.

	set empty1 [expr {($a - $last1) <= 1}]
	set empty2 [expr {($b - $last2) <= 1}]

	if {$empty1 && $empty2} {
	    # Case (d), add 'unchanged' chunk.
	    foreach {type left right} [lindex $result end] break
	    if {[string equal $type unchanged]} {
		# We extend the 'unchanged' chunk found at the end.
		lset result end [::list unchanged [::list [lindex $left 0] $a] [::list [lindex $right 0] $b]]
	    } else {
		lappend result [::list unchanged [::list $last1 $a] [::list $last2 $b]]
	    }

	} elseif {$empty1} {
	    # Case (b), 'addition'.
	    incr last2 ; incr b -1
	    lappend result [::list added [::list $last1 $a] [::list $last2 $b]]
	    incr b
	} elseif {$empty2} {
	    # Case (c), 'deletion'
	    incr last1 ; incr a -1
	    lappend result [::list deleted [::list $last1 $a] [::list $last2 $b]]
	    incr a
	} else {
	    # Case (q), 'change'.
	    incr last1 ; incr a -1
	    incr last2 ; incr b -1
	    lappend result [::list changed [::list $last1 $a] [::list $last2 $b]]
	    incr a
	    incr b
	}

	set last1 $a
	set last2 $b
    }

    # Handle the last chunk, using the information about the length of
    # the original sequences.

    set empty1 [expr {($len1 - $last1) <= 1}]
    set empty2 [expr {($len2 - $last2) <= 1}]

    if {$empty1 && $empty2} {
	# Case (d), ignore the indices
    } elseif {$empty1} {
	# Case (b), 'addition'.
	incr last2 ; incr len2 -1
	lappend result [::list added [::list $last1 $len1] [::list $last2 $len2]]
    } elseif {$empty2} {
	# Case (c), 'deletion'
	incr last1 ; incr len1 -1
	lappend result [::list deleted [::list $last1 $len1] [::list $last2 $len2]]
    } else {
	# Case (q), 'change'.
	incr last1 ; incr len1 -1
	incr last2 ; incr len2 -1
	lappend result [::list changed [::list $last1 $len1] [::list $last2 $len2]]
    }

    return $result
}

# ::struct::list::Reverse --
#
#	Reverses the contents of the list and returns the reversed
#	list as the result of the command.
#
# Parameters:
#	sequence	List to be reversed.
#
# Results:
#	The sequence in reverse.
#
# Side effects:
#       None.

proc ::struct::list::Reverse {sequence} {
    set l [::llength $sequence]

    # Shortcut for lists where reversing yields the list itself
    if {$l < 2} {return $sequence}

    # Perform true reversal
    set res [::list]
    while {$l} {
	::lappend res [::lindex $sequence [incr l -1]]
    }
    return $res
}


# ::struct::list::Assign --
#
#	Assign list elements to variables.
#
# Parameters:
#	sequence	List to assign
#	args		Names of the variables to assign to.
#
# Results:
#	The unassigned part of the sequence. Can be empty.
#
# Side effects:
#       None.

proc ::struct::list::Assign {sequence args} {
    set l [::llength $sequence]
    set a [::llength $args]

    # Nothing to assign.
    if {$a == 0} {return $sequence}

    # Perform assignments
    set i 0
    foreach v $args {
	upvar 2 $v var
	set      var [::lindex $sequence $i]
	incr i
    }

    # Return remainder, if there is any.
    return [::lrange $sequence $a end]
}


# ::struct::list::Flatten --
#
#	Remove nesting from the input
#
# Parameters:
#	sequence	List to flatten
#
# Results:
#	The input list with one or all levels of nesting removed.
#
# Side effects:
#       None.

proc ::struct::list::Flatten {args} {
    if {[::llength $args] < 1} {
	return -code error \
		"wrong#args: should be \"::struct::list::Assign ?-full? ?--? sequence\""
    }

    set full 0
    while {[string match -* [set opt [::lindex $args 0]]]} {
	switch -glob -- $opt {
	    -full   {set full 1}
	    --      {break}
	    default {return -code error ""}
	}
	set args [::lrange $args 1 end]
    }

    if {[::llength $args] != 1} {
	return -code error \
		"wrong#args: should be \"::struct::list::Assign ?-full? ?--? sequence\""
    }

    set sequence [::lindex $args 0]
    set cont 1
    while {$cont} {
	set cont 0
	set result [::list]
	foreach item $sequence {
	    eval [::list ::lappend result] $item
	}
	if {$full && [string compare $sequence $result]} {set cont 1}
	set sequence $result
    }
    return $result
}


# ::struct::list::Map --
#
#	Apply command to each element of a list and return concatenated results.
#
# Parameters:
#	sequence	List to operate on
#	cmdprefix	Operation to perform on the elements.
#
# Results:
#	List containing the result of applying cmdprefix to the elements of the
#	sequence.
#
# Side effects:
#       None of its own, but the command prefix can perform arbitry actions.

proc ::struct::list::Map {sequence cmdprefix} {
    # Shortcut when nothing is to be done.
    if {[::llength $sequence] == 0} {return $sequence}

    set res [::list]
    foreach item $sequence {
	lappend res [uplevel 2 [linsert $cmdprefix end $item]]
    }
    return $res
}

# ::struct::list::Fold --
#
#	Fold list into one value.
#
# Parameters:
#	sequence	List to operate on
#	cmdprefix	Operation to perform on the elements.
#
# Results:
#	Result of applying cmdprefix to the elements of the
#	sequence.
#
# Side effects:
#       None of its own, but the command prefix can perform arbitry actions.

proc ::struct::list::Fold {sequence initialvalue cmdprefix} {
    # Shortcut when nothing is to be done.
    if {[::llength $sequence] == 0} {return $initialvalue}

    set res $initialvalue
    foreach item $sequence {
	set res [uplevel 2 [linsert $cmdprefix end $res $item]]
    }
    return $res
}

# ::struct::list::Iota --
#
#	Return a list containing the integer numbers 0 ... n-1
#
# Parameters:
#	n	First number not in the generated list.
#
# Results:
#	A list containing integer numbers.
#
# Side effects:
#       None

proc ::struct::list::Iota {n} {
    set retval [::list]
    for {set i 0} {$i < $n} {incr i} {
	::lappend retval $i
    }
    return $retval
}

# ::struct::list::Equal --
#
#	Compares two lists for equality
#	(Same length, Same elements in same order).
#
# Parameters:
#	a	First list to compare.
#	b	Second list to compare.
#
# Results:
#	A boolean. True if the lists are equal.
#
# Side effects:
#       None

proc ::struct::list::Equal {a b} {
    # Author of this command is "Richard Suchenwirth"

    if {[::llength $a] != [::llength $b]} {return 0}
    if {[::lindex $a 0] == $a} {return [string equal $a $b]}
    foreach i $a j $b {if {![Equal $i $j]} {return 0}}
    return 1
}

# ::struct::list::Repeat --
#
#	Create a list repeating the same value over again.
#
# Parameters:
#	value	value to use in the created list.
#	args	Dimension(s) of the (nested) list to create.
#
# Results:
#	A list
#
# Side effects:
#       None

proc ::struct::list::Repeat {value args} {
    if {[::llength $args] == 1} {set args [::lindex $args 0]}
    set buf {}
    foreach number $args {
	incr number 0 ;# force integer (1)
	set buf {}
	for {set i 0} {$i<$number} {incr i} {
	    ::lappend buf $value
	}
	set value $buf
    }
    return $buf
    # (1): See 'Stress testing' (wiki) for why this makes the code safer.
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/list.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] list.tcl]

# 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]
    }
}

# Service procedure to develop the error message for "wrong # args"

proc wrongNumArgs {name arglist count} {
    set ver [info patchlevel]
    # strip "a1", etc. designations
    regsub {(a|b)[1-9]$} $ver {} ver
    if {[package vcompare $ver 8.4] < 0} {
	set arg [lindex $arglist $count]
	set msg "no value given for parameter \"$arg\" to \"$name\""
    } else {
	set msg "wrong # args: should be \"$name $arglist\""
    }
    return $msg
}

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

interp alias {} lcs {} ::struct::list::list longestCommonSubsequence

test list-lcs-1.1 {longestCommonSubsequence, no args} {
    catch { lcs } msg
    set msg
} [wrongNumArgs ::struct::list::LongestCommonSubsequence \
       {sequence1 sequence2 ?maxOccurs?} 0]

test list-lcs-1.2 {longestCommonSubsequence, one arg} {
    catch { lcs x } msg
    set msg
} [wrongNumArgs ::struct::list::LongestCommonSubsequence \
       {sequence1 sequence2 ?maxOccurs?} 1]

test list-lcs-2.1 {longestCommonSubsequence, two empty lists} {
    list [catch { lcs {} {} } msg] $msg
} {0 {{} {}}}

test list-lcs-2.2 {longestCommonSubsequence, insert 1 into an empty list} {
    list [catch { lcs {} {a} } msg] $msg
} {0 {{} {}}}

test list-lcs-2.3 {longestCommonSubsequence, delete 1 from singleton list} {
    list [catch { lcs {a} {} } msg] $msg
} {0 {{} {}}}

test list-lcs-2.4 {longestCommonSubsequence, preserve singleton list} {
    list [catch { lcs {a} {a} } msg] $msg
} {0 {0 0}}

test list-lcs-2.5 {longestCommonSubsequence, 1-element change in singleton list} {
    list [catch { lcs {a} {b} } msg] $msg
} {0 {{} {}}}

test list-lcs-2.6 {longestCommonSubsequence, insert 1 in front of singleton list} {
    list [catch { lcs {a} {b a} } msg] $msg
} {0 {0 1}}

test list-lcs-2.7 {longestCommonSubsequence, insert 1 at end of singleton list} {
    list [catch {lcs {a} {a b}} msg] $msg
} {0 {0 0}}

test list-lcs-2.8 {longestCommonSubsequence, duplicate element} {
    list [catch {lcs {a} {a a}} msg] $msg
} {0 {0 0}}

test list-lcs-2.9 {longestCommonSubsequence, interchange 2} {
    list [catch {lcs {a b} {b a}} msg] $msg
} {0 {1 0}}

test list-lcs-2.10 {longestCommonSubsequence, insert before 2} {
    list [catch {lcs {a b} {b a b}} msg] $msg
} {0 {{0 1} {1 2}}}

test list-lcs-2.11 {longestCommonSubsequence, insert inside 2} {
    list [catch {lcs {a b} {a a b}} msg] $msg
} {0 {{0 1} {0 2}}}

test list-lcs-2.13 {longestCommonSubsequence, insert after 2} {
    list [catch {lcs {a b} {a b a}} msg] $msg
} {0 {{0 1} {0 1}}}

test list-lcs-2.13 {longestCommonSubsequence, delete first of 2} {
    list [catch {lcs {a b} a} msg] $msg
} {0 {0 0}}

test list-lcs-2.14 {longestCommonSubsequence, delete second of 2} {
    list [catch {lcs {a b} b} msg] $msg
} {0 {1 0}}

test list-lcs-2.15 {longestCommonSubsequence, change first of 2} {
    list [catch {lcs {a b} {c b}} msg] $msg
} {0 {1 1}}

test list-lcs-2.16 {longestCommonSubsequence, change first of 2 to dupe} {
    list [catch {lcs {a b} {b b}} msg] $msg
} {0 {1 0}}

test list-lcs-2.17 {longestCommonSubsequence, change second of 2} {
    list [catch {lcs {a b} {a c}} msg] $msg
} {0 {0 0}}

test list-lcs-2.18 {longestCommonSubsequence, change second of 2 to dupe} {
    list [catch {lcs {a b} {a a}} msg] $msg
} {0 {0 0}}

test list-lcs-2.19 {longestCommonSubsequence, mixed changes} {
    list [catch {lcs {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg
} {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}}

test list-lcs-2.20 {longestCommonSubsequence, mixed changes} {
    list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}

test list-lcs-3.1 {longestCommonSubsequence, length limit} {
    list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}

test list-lcs-3.2 {longestCommonSubsequence, length limit} {
    list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg
} {0 {{0 1 3 5 6} {1 2 4 8 9}}}

test list-lcs-3.3 {longestCommonSubsequence, length limit} {
    list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg
} {0 {3 4}}

test list-lcs-3.4 {longestCommonSubsequence, stupid length limit} {
    list [catch {lcs {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg
} {0 {{} {}}}


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

interp alias {} lcs2 {} ::struct::list::list longestCommonSubsequence2

test list-lcs2-1.1 {longestCommonSubsequence2, no args} {
    catch { lcs2 } msg
    set msg
} [wrongNumArgs ::struct::list::LongestCommonSubsequence2 \
       {sequence1 sequence2 ?maxOccurs?} 0]

test list-lcs2-1.2 {longestCommonSubsequence2, one arg} {
    catch { lcs2 x } msg
    set msg
} [wrongNumArgs ::struct::list::LongestCommonSubsequence2 \
       {sequence1 sequence2 ?maxOccurs?} 1]

test list-lcs2-2.1 {longestCommonSubsequence2, two empty lists} {
    list [catch { lcs2 {} {} } msg] $msg
} {0 {{} {}}}

test list-lcs2-2.2 {longestCommonSubsequence2, insert 1 into an empty list} {
    list [catch { lcs2 {} {a} } msg] $msg
} {0 {{} {}}}

test list-lcs2-2.3 {longestCommonSubsequence2, delete 1 from singleton list} {
    list [catch { lcs2 {a} {} } msg] $msg
} {0 {{} {}}}

test list-lcs2-2.4 {longestCommonSubsequence2, preserve singleton list} {
    list [catch { lcs2 {a} {a} } msg] $msg
} {0 {0 0}}

test list-lcs2-2.5 {longestCommonSubsequence2, 1-element change in singleton list} {
    list [catch { lcs2 {a} {b} } msg] $msg
} {0 {{} {}}}

test list-lcs2-2.6 {longestCommonSubsequence2, insert 1 in front of singleton list} {
    list [catch { lcs2 {a} {b a} } msg] $msg
} {0 {0 1}}

test list-lcs2-2.7 {longestCommonSubsequence2, insert 1 at end of singleton list} {
    list [catch {lcs2 {a} {a b}} msg] $msg
} {0 {0 0}}

test list-lcs2-2.8 {longestCommonSubsequence2, duplicate element} {
    list [catch {lcs2 {a} {a a}} msg] $msg
} {0 {0 0}}

test list-lcs2-2.9 {longestCommonSubsequence2, interchange 2} {
    list [catch {lcs2 {a b} {b a}} msg] $msg
} {0 {1 0}}

test list-lcs2-2.10 {longestCommonSubsequence2, insert before 2} {
    list [catch {lcs2 {a b} {b a b}} msg] $msg
} {0 {{0 1} {1 2}}}

test list-lcs2-2.11 {longestCommonSubsequence2, insert inside 2} {
    list [catch {lcs2 {a b} {a a b}} msg] $msg
} {0 {{0 1} {0 2}}}

test list-lcs2-2.13 {longestCommonSubsequence2, insert after 2} {
    list [catch {lcs2 {a b} {a b a}} msg] $msg
} {0 {{0 1} {0 1}}}

test list-lcs2-2.13 {longestCommonSubsequence2, delete first of 2} {
    list [catch {lcs2 {a b} a} msg] $msg
} {0 {0 0}}

test list-lcs2-2.14 {longestCommonSubsequence2, delete second of 2} {
    list [catch {lcs2 {a b} b} msg] $msg
} {0 {1 0}}

test list-lcs2-2.15 {longestCommonSubsequence2, change first of 2} {
    list [catch {lcs2 {a b} {c b}} msg] $msg
} {0 {1 1}}

test list-lcs2-2.16 {longestCommonSubsequence2, change first of 2 to dupe} {
    list [catch {lcs2 {a b} {b b}} msg] $msg
} {0 {1 0}}

test list-lcs2-2.17 {longestCommonSubsequence2, change second of 2} {
    list [catch {lcs2 {a b} {a c}} msg] $msg
} {0 {0 0}}

test list-lcs2-2.18 {longestCommonSubsequence2, change second of 2 to dupe} {
    list [catch {lcs2 {a b} {a a}} msg] $msg
} {0 {0 0}}

test list-lcs2-2.19 {longestCommonSubsequence2, mixed changes} {
    list [catch {lcs2 {a b r a c a d a b r a} {b r i c a b r a c}} msg] $msg
} {0 {{1 2 4 5 8 9 10} {0 1 3 4 5 6 7}}}

test list-lcs2-2.20 {longestCommonSubsequence2, mixed changes} {
    list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a}} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}

test list-lcs2-3.1 {longestCommonSubsequence2, length limit} {
    list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 5} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}

test list-lcs2-3.2 {longestCommonSubsequence2, length limit} {
    list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 4} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}

test list-lcs2-3.3 {longestCommonSubsequence2, length limit} {
    list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 1} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}

test list-lcs2-3.4 {longestCommonSubsequence2, stupid length limit} {
    list [catch {lcs2 {b r i c a b r a c} {a b r a c a d a b r a} 0} msg] $msg
} {0 {{0 1 3 4 5 6 7} {1 2 4 5 8 9 10}}}


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

interp alias {} lcsi  {} ::struct::list::list lcsInvert
interp alias {} lcsim {} ::struct::list::list lcsInvertMerge

test list-lcsInv-4.0 {longestCommonSubsequence, mixed changes} {

    # sequence 1 = a b r a c a d a b r a
    # lcs 1      =   1 2   4 5     8 9 10
    # lcs 2      =   0 1   3 4     5 6 7
    # sequence 2 =   b r i c a     b r a c
    #
    # Inversion  = deleted  {0  0} {-1 0}
    #              changed  {3  3}  {2 2}
    #              deleted  {6  7}  {4 5}
    #              added   {10 11}  {8 8}

    list [catch {lcsi [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg
} {0 {{deleted {0 0} {-1 0}} {changed {3 3} {2 2}} {deleted {6 7} {4 5}} {added {10 11} {8 8}}}}

test list-lcsInv-4.1 {longestCommonSubsequence, mixed changes} {

    # sequence 1 = a b r a c a d a b r a
    # lcs 1      =   1 2   4 5     8 9 10
    # lcs 2      =   0 1   3 4     5 6 7
    # sequence 2 =   b r i c a     b r a c
    #
    # Inversion/Merge  = deleted   {0  0} {-1 0}
    #                    unchanged {1  2}  {0 1}
    #                    changed   {3  3}  {2 2}
    #                    unchanged {4  5}  {3 4}
    #                    deleted   {6  7}  {4 5}
    #                    unchanged {8 10}  {5 7}
    #                    added    {10 11}  {8 8}

    list [catch {lcsim [lcs {a b r a c a d a b r a} {b r i c a b r a c}] 11 9} msg] $msg
} {0 {{deleted {0 0} {-1 0}} {unchanged {1 2} {0 1}} {changed {3 3} {2 2}} {unchanged {4 5} {3 4}} {deleted {6 7} {4 5}} {unchanged {8 10} {5 7}} {added {10 11} {8 8}}}}

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

interp alias {} reverse {} ::struct::list::list reverse

test reverse-1.1 {reverse method} {
    reverse {a b c}
} {c b a}

test reverse-1.2 {reverse method} {
    reverse a
} {a}

test reverse-1.3 {reverse method} {
    reverse {}
} {}

test reverse-2.1 {reverse errors} {
    list [catch {reverse} msg] $msg
} [list 1 [wrongNumArgs ::struct::list::Reverse {sequence} 0]]

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

interp alias {} assign {} ::struct::list::list assign

test assign-4.1 {assign method} {
    catch {unset ::x ::y}
    list [assign {foo bar} x y] $x $y
} {{} foo bar}

test assign-4.2 {assign method} {
    catch {unset x y}
    list [assign {foo bar baz} x y] $x $y
} {baz foo bar}

test assign-4.3 {assign method} {
    catch {unset x y z}
    list [assign {foo bar} x y z] $x $y $z
} {{} foo bar {}}

test assign-4.4 {assign method} {
    assign {foo bar}
} {foo bar}

catch {unset x y z}

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

interp alias {} flatten {} ::struct::list::list flatten

test flatten-1.1 {flatten command} {
    flatten {1 2 3 {4 5} {6 7} {{8 9}} 10}
} {1 2 3 4 5 6 7 {8 9} 10}

test flatten-1.2 {flatten command} {
    flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10}
} {1 2 3 4 5 6 7 8 9 10}

test flatten-2.1 {flatten errors} {
    list [catch {flatten} msg] $msg
} {1 {wrong#args: should be "::struct::list::Assign ?-full? ?--? sequence"}}

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

interp alias {} map {} ::struct::list::list map

proc cc {a} {return $a$a}
proc +  {a} {expr {$a + $a}}
proc *  {a} {expr {$a * $a}}
proc projection {n list} {::lindex $list $n}

test map-4.1 {map command} {
    map {a b c d} cc
} {aa bb cc dd}

test map-4.2 {map command} {
    map {1 2 3 4 5} +
} {2 4 6 8 10}

test map-4.3 {map command} {
    map {1 2 3 4 5} *
} {1 4 9 16 25}

test map-4.4 {map command} {
    map {} *
} {}

test map-4.5 {map command} {
    map {{a b c} {1 2 3} {d f g}} {projection 1}
} {b 2 f}

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

interp alias {} fold {} ::struct::list::list fold

proc cc {a b} {return $a$b}
proc +  {a b} {expr {$a + $b}}
proc *  {a b} {expr {$a * $b}}

test fold-4.1 {fold command} {
    fold {a b c d} {} cc
} {abcd}

test fold-4.2 {fold command} {
    fold {1 2 3 4 5} 0 +
} {15}

test fold-4.3 {fold command} {
    fold {1 2 3 4 5} 1 *
} {120}

test fold-4.4 {fold command} {
    fold {} 1 *
} {1}

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

interp alias {} iota {} ::struct::list::list iota

test iota-4.1 {iota command} {
    iota 0
} {}

test iota-4.2 {iota command} {
    iota 1
} {0}

test iota-4.3 {iota command} {
    iota 11
} {0 1 2 3 4 5 6 7 8 9 10}


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

interp alias {} repeat {} ::struct::list::list repeat

test repeat-4.1 {repeat command} {
    repeat 0
} {}

test repeat-4.2 {repeat command} {
    repeat 0 3
} {0 0 0}

test repeat-4.3 {repeat command} {
    repeat 0 3 4
} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}}

test repeat-4.4 {repeat command} {
    repeat 0 {3 4}
} {{0 0 0} {0 0 0} {0 0 0} {0 0 0}}


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

interp alias {} equal {} ::struct::list::list equal

test equal-4.1 {equal command} {
    equal 0 0
} 1

test equal-4.2 {equal command} {
    equal 0 1
} 0

test equal-4.3 {equal command} {
    equal {0 0 0} {0 0}
} 0

test equal-4.4 {equal command} {
    equal {{0 2 3} 1} {{0 2 3} 1}
} 1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/matrix.man.

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

The [cmd ::struct::matrix] command creates a new matrix object with an
associated global Tcl command whose name is [arg matrixName].  This
command may be used to invoke various operations on the matrix.  It has
the following general form:

[list_begin definitions]
[call [cmd matrixName] [arg option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.

[list_end]

[para]

A matrix is a rectangular collection of cells, i.e. organized in rows
and columns. Each cell contains exactly one value of arbitrary
form. The cells in the matrix are addressed by pairs of integer
numbers, with the first (left) number in the pair specifying the
column and the second (right) number specifying the row the cell is
in. These indices are counted from 0 upward. The special non-numeric
index [const end] refers to the last row or column in the matrix,
depending on the context. Indices of the form

[const end]-[var number] are counted from the end of the row or
column, like they are for standard Tcl lists. Trying to access
non-existing cells causes an error.

[para]

The matrices here are created empty, i.e. they have neither rows nor
columns. The user then has to add rows and columns as needed by his
application. A specialty of this structure is the ability to export an
array-view onto its contents. Such can be used by tkTable, for
example, to link the matrix into the display.

[para]

The following commands are possible for matrix objects:

[list_begin definitions]

[call [arg matrixName] [method {add column}] [opt [arg values]]]

Extends the matrix by one column and then acts like [method setcolumn]
(see below) on this new column if there were [arg values]
supplied. Without [arg values] the new cells will be set to the empty
string. The new column is appended immediately behind the last
existing column.

[call [arg matrixName] [method {add row}] [opt [arg values]]]

Extends the matrix by one row and then acts like [method setrow] (see
below) on this new row if there were [arg values] supplied. Without
[arg values] the new cells will be set to the empty string. The new
row is appended immediately behind the last existing row.

[call [arg matrixName] [method {add columns}] [arg n]]

Extends the matrix by [arg n] columns. The new cells will be set to
the empty string. The new columns are appended immediately behind the
last existing column. A value of [arg n] equal to or smaller than 0 is
not allowed.

[call [arg matrixName] [method {add rows}] [arg n]]

Extends the matrix by [arg n] rows. The new cells will be set to the
empty string. The new rows are appended immediately behind the last
existing row. A value of [arg n] equal to or smaller than 0 is not
allowed.

[call [arg matrixName] [method cells]]

Returns the number of cells currently managed by the matrix. This is
the product of [method rows] and [method columns].

[call [arg matrixName] [method cellsize] [arg {column row}]]

Returns the length of the string representation of the value currently
contained in the addressed cell.

[call [arg matrixName] [method columns]]

Returns the number of columns currently managed by the matrix.

[call [arg matrixName] [method columnwidth] [arg column]]

Returns the length of the longest string representation of all the
values currently contained in the cells of the addressed column if
these are all spanning only one line. For cell values spanning
multiple lines the length of their longest line goes into the
computation.

[call [arg matrixName] [method {delete column}] [arg column]]

Deletes the specified column from the matrix and shifts all columns
with higher indices one index down.

[call [arg matrixName] [method {delete row}] [arg row]]

Deletes the specified row from the matrix and shifts all row with
higher indices one index down.

[call [arg matrixName] [method destroy]]

Destroys the matrix, including its storage space and associated
command.

[call [arg matrixName] [method {format 2string}] [opt [arg report]]]

Formats the matrix using the specified report object and returns the
string containing the result of this operation. The report has to
support the [method printmatrix] method. If no [arg report] is
specified the system will use an internal report definition to format
the matrix.

[call [arg matrixName] [method {format 2chan}] [opt "[opt [arg report]] [arg channel]"]]

Formats the matrix using the specified report object and writes the
string containing the result of this operation into the channel. The
report has to support the [method printmatrix2channel] method.  If no
[arg report] is specified the system will use an internal report
definition to format the matrix. If no [arg channel] is specified the
system will use [const stdout].

[call [arg matrixName] [method {get cell}] [arg {column row}]]

Returns the value currently contained in the cell identified by row
and column index.

[call [arg matrixName] [method {get column}] [arg column]]

Returns a list containing the values from all cells in the column
identified by the index. The contents of the cell in row 0 are stored
as the first element of this list.

[call [arg matrixName] [method {get rect}] [arg {column_tl row_tl column_br row_br}]]

Returns a list of lists of cell values. The values stored in the
result come from the sub-matrix whose top-left and bottom-right cells
are specified by [arg {column_tl, row_tl}] and

[arg {column_br, row_br}] resp. Note that the following equations have
to be true: "[arg column_tl] <= [arg column_br]" and "[arg row_tl] <=
[arg row_br]". The result is organized as follows: The outer list is
the list of rows, its elements are lists representing a single
row. The row with the smallest index is the first element of the outer
list. The elements of the row lists represent the selected cell
values. The cell with the smallest index is the first element in each
row list.

[call [arg matrixName] [method {get row}] [arg row]]

Returns a list containing the values from all cells in the row
identified by the index. The contents of the cell in column 0 are
stored as the first element of this list.

[call [arg matrixName] [method {insert column}] [arg column] [opt [arg values]]]

Extends the matrix by one column and then acts like [method setcolumn]
(see below) on this new column if there were [arg values]
supplied. Without [arg values] the new cells will be set to the empty
string. The new column is inserted just before the column specified by
the given index. This means, if [arg column] is less than or equal to
zero, then the new column is inserted at the beginning of the matrix,
before the first column. If [arg column] has the value [const end],
or if it is greater than or equal to the number of columns in the
matrix, then the new column is appended to the matrix, behind the last
column. The old column at the chosen index and all columns with higher
indices are shifted one index upward.

[call [arg matrixName] [method {insert row}] [arg row] [opt [arg values]]]

Extends the matrix by one row and then acts like [method setrow] (see
below) on this new row if there were [arg values] supplied. Without
[arg values] the new cells will be set to the empty string. The new
row is inserted just before the row specified by the given index. This
means, if [arg row] is less than or equal to zero, then the new row is
inserted at the beginning of the matrix, before the first row. If

[arg row] has the value [const end], or if it is greater than or
equal to the number of rows in the matrix, then the new row is
appended to the matrix, behind the last row. The old row at that index
and all rows with higher indices are shifted one index upward.

[call [arg matrixName] [method link] [opt -transpose] [arg arrayvar]]

Links the matrix to the specified array variable. This means that the
contents of all cells in the matrix is stored in the array too, with
all changes to the matrix propagated there too. The contents of the
cell [arg (column,row)] is stored in the array using the key

[arg column,row]. If the option [option -transpose] is specified the
key [arg row,column] will be used instead. It is possible to link the
matrix to more than one array. Note that the link is bidirectional,
i.e. changes to the array are mirrored in the matrix too.

[call [arg matrixName] [method rowheight] [arg row]]

Returns the height of the specified row in lines. This is the highest
number of lines spanned by a cell over all cells in the row.

[call [arg matrixName] [method rows]]

Returns the number of rows currently managed by the matrix.

[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method all] [arg pattern]]

Searches the whole matrix for cells matching the [arg pattern] and
returns a list with all matches. Each item in the aforementioned list
is a list itself and contains the column and row index of the matching
cell, in this order. The results are ordered by column first and row
second, both times in ascending order. This means that matches to the
left and the top of the matrix come before matches to the right and
down.

[nl]

The type of the pattern (string, glob, regular expression) is
determined by the option after the [method search] keyword. If no
option is given it defaults to [option -exact].

[nl]

If the option [option -nocase] is specified the search will be
case-insensitive.

[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method column] [arg {column pattern}]]

Like [method {search all}], but the search is restricted to the
specified column.

[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method row] [arg {row pattern}]]

Like [method {search all}], but the search is restricted to the
specified row.

[call [arg matrixName] [method search] [opt -nocase] [opt -exact|-glob|-regexp] [method rect] [arg {column_tl row_tl column_br row_br pattern}]]

Like [method {search all}], but the search is restricted to the
specified rectangular area of the matrix.

[call [arg matrixName] [method {set cell}] [arg {column row value}]]

Sets the value in the cell identified by row and column index to the
data in the third argument.

[call [arg matrixName] [method {set column}] [arg {column values}]]

Sets the values in the cells identified by the column index to the
elements of the list provided as the third argument. Each element of
the list is assigned to one cell, with the first element going into
the cell in row 0 and then upward. If there are less values in the
list than there are rows the remaining rows are set to the empty
string. If there are more values in the list than there are rows the
superfluous elements are ignored. The matrix is not extended by this
operation.

[call [arg matrixName] [method {set rect}] [arg {column row values}]]

Takes a list of lists of cell values and writes them into the
submatrix whose top-left cell is specified by the two indices. If the
sublists of the outerlist are not of equal length the shorter sublists
will be filled with empty strings to the length of the longest
sublist. If the submatrix specified by the top-left cell and the
number of rows and columns in the [arg values] extends beyond the
matrix we are modifying the over-extending parts of the values are
ignored, i.e. essentially cut off. This subcommand expects its input
in the format as returned by [method getrect].

[call [arg matrixName] [method {set row}] [arg {row values}]]

Sets the values in the cells identified by the row index to the
elements of the list provided as the third argument. Each element of
the list is assigned to one cell, with the first element going into
the cell in column 0 and then upward. If there are less values in the
list than there are columns the remaining columns are set to the empty
string. If there are more values in the list than there are columns
the superfluous elements are ignored. The matrix is not extended by
this operation.

[call [arg matrixName] [method {swap columns}] [arg {column_a column_b}]]

Swaps the contents of the two specified columns.

[call [arg matrixName] [method {swap rows}] [arg {row_a row_b}]]

Swaps the contents of the two specified rows.

[call [arg matrixName] [method unlink] [arg arrayvar]]

Removes the link between the matrix and the specified arrayvariable,
if there is one.

[list_end]

[section EXAMPLES]
[para]

The examples below assume a 5x5 matrix M with the first row containing
the values 1 to 5, with 1 in the top-left cell. Each other row
contains the contents of the row above it, rotated by one cell to the
right.

[para]
[example {
 % M getrect 0 0 4 4
 {{1 2 3 4 5} {5 1 2 3 4} {4 5 1 2 3} {3 4 5 1 2} {2 3 4 5 1}}
}]

[para]
[example {
 % M setrect 1 1 {{0 0 0} {0 0 0} {0 0 0}}
 % M getrect 0 0 4 4
 {{1 2 3 4 5} {5 0 0 0 4} {4 0 0 0 3} {3 0 0 0 2} {2 3 4 5 1}}
}]

[para]

Assuming that the style definitions in the example section of the
manpage for the package [package report] are loaded into the
interpreter now an example which formats a matrix into a tabular
report. The code filling the matrix with data is not shown.  contains
useful data.

[para]

[example {
    % ::struct::matrix m
    % # ... fill m with data, assume 5 columns
    % ::report::report r 5 style captionedtable 1
    % m format 2string r
    +---+-------------------+-------+-------+--------+
    |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          |15     |47     |31.91   |
    |   |true numeric       |       |       |        |
    +---+-------------------+-------+-------+--------+
    %
    % # alternate way of doing the above
    % r printmatrix m
}]

[keywords matrix]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/matrix.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
'\" 
'\" Copyright (c) 2001 by Andreas Kupries <[email protected]>
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: matrix.n,v 1.10 2002/03/10 02:49:52 andreas_kupries Exp $
'\" 
.so man.macros
.TH matrix n 1.2.1 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::matrix \- Create and manipulate matrix objects
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require struct ?1.2.1?\fR
.sp
\fB::struct::matrix\fR \fImatrixName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::matrix\fR command creates a new matrix object with an
associated global Tcl command whose name is \fImatrixName\fR.  This command
may be used to invoke various operations on the matrix.  It has the
following general form:
.CS
\fImatrixName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  
.PP
A matrix is a rectangular collection of cells, i.e. organized in rows
and columns. Each cell contains exactly one value of arbitrary
form. The cells in the matrix are addressed by pairs of integer
numbers, with the first (left) number in the pair specifying the
column and the second (right) number specifying the row the cell is
in. These indices are counted from 0 upward. The special non-numeric
index \fBend\fR refers to the last row or column in the matrix,
depending on the context. Indices of the form \fBend\fR -\fInumber\fR
are counted from the end of the row or column, like they are for
standard Tcl lists. Trying to access non-existing cells causes an
error.
.PP
The matrices here are created empty, i.e. they have neither rows nor
columns. The user then has to add rows and columns as needed by his
application. A specialty of this structure is the ability to export an
array-view onto its contents. Such can be used by tkTable, for
example, to link the matrix into the display.
.PP
The following commands are possible for matrix objects:
.TP
\fImatrixName\fR \fBadd column\fR \fI?values?\fR
Extends the matrix by one column and then acts like \fBsetcolumn\fR
(see below) on this new column if there were \fIvalues\fR
supplied. Without \fIvalues\fR the new cells will be set to the empty
string. The new column is appended immediately behind the last existing
column.
.TP
\fImatrixName\fR \fBadd row\fR \fI?values?\fR
Extends the matrix by one row and then acts like \fBsetrow\fR (see
below) on this new row if there were \fIvalues\fR supplied. Without
\fIvalues\fR the new cells will be set to the empty string. The new
row is appended immediately behind the last existing row.
.TP
\fImatrixName\fR \fBadd columns\fR \fIn\fR
Extends the matrix by \fIn\fR columns. The new cells will be set to
the empty string. The new columns are appended immediately behind the
last existing column. A value of \fIn\fR equal to or smaller than 0 is
not allowed.
.TP
\fImatrixName\fR \fBadd rows\fR \fIn\fR
Extends the matrix by \fIn\fR rows. The new cells will be set to the
empty string. The new rows are appended immediately behind the last
existing row. A value of \fIn\fR equal to or smaller than 0 is
not allowed.
.TP
\fImatrixName\fR \fBcells\fR
Returns the number of cells currently managed by the matrix. This is
the product of \fBrows\fR and \fBcolumns\fR.
.TP
\fImatrixName\fR \fBcellsize\fR \fIcolumn row\fR
Returns the length of the string representation of the value currently
contained in the addressed cell.
.TP
\fImatrixName\fR \fBcolumns\fR
Returns the number of columns currently managed by the matrix.
.TP
\fImatrixName\fR \fBcolumnwidth\fR \fIcolumn\fR
Returns the length of the longest string representation of all the
values currently contained in the cells of the addressed column if
these are all spanning only one line. For cell values spanning
multiple lines the length of their longest line goes into the
computation.
.TP
\fImatrixName \fBdelete column\fR \fIcolumn\fR
Deletes the specified column from the matrix and shifts all columns
with higher indices one index down.
.TP
\fImatrixName \fBdelete row\fR \fIrow\fR
Deletes the specified row from the matrix and shifts all row with
higher indices one index down.
.TP
\fImatrixName \fBdestroy\fR
Destroys the matrix, including its storage space and associated
command.
.TP
\fImatrixName \fBformat 2string\fR ?\fIreport\fR?
Formats the matrix using the specified report object and returns the
string containing the result of this operation. The report has to
support the \fBprintmatrix\fR method. If no \fIreport\fR is specified
the system will use an internal report definition to format the
matrix.
.TP
\fImatrixName \fBformat 2chan\fR ??\fIreport\fR? \fIchannel\fR?
Formats the matrix using the specified report object and writes the
string containing the result of this operation into the channel. The
report has to support the \fBprintmatrix2channel\fR method.  If no
\fIreport\fR is specified the system will use an internal report
definition to format the matrix. If no \fIchannel\fR is specified the
system will use \fBstdout\fR.
.TP
\fImatrixName\fR \fBget cell\fR \fIcolumn row\fR
Returns the value currently contained in the cell identified by row
and column index.
.TP
\fImatrixName\fR \fBget column\fR \fIcolumn\fR
Returns a list containing the values from all cells in the column
identified by the index. The contents of the cell in row 0 are stored
as the first element of this list.
.TP
\fImatrixName\fR \fBget rect\fR \fIcolumn_tl row_tl column_br row_br\fR
Returns a list of lists of cell values. The values stored in the
result come from the sub-matrix whose top-left and bottom-right cells
are specified by \fIcolumn_tl, row_tl\fR and \fIcolumn_br, row_br\fR
resp. Note that the following equations have to be true: \fIcolumn_tl
<= column_br\fR and \fIrow_tl <= row_br\fR. The result is organized as
follows: The outer list is the list of rows, its elements are lists
representing a single row. The row with the smallest index is the
first element of the outer list. The elements of the row lists
represent the selected cell values. The cell with the smallest index
is the first element in each row list.
.TP
\fImatrixName\fR \fBget row\fR \fIrow\fR
Returns a list containing the values from all cells in the row
identified by the index. The contents of the cell in column 0 are
stored as the first element of this list.
.TP
\fImatrixName\fR \fBinsert column\fR \fIcolumn ?values?\fR
Extends the matrix by one column and then acts like \fBsetcolumn\fR
(see below) on this new column if there were \fIvalues\fR
supplied. Without \fIvalues\fR the new cells will be set to the empty
string. The new column is inserted just before the column specified by
the given index. This means, if \fIcolumn\fR is less than or equal to
zero, then the new column is inserted at the beginning of the matrix,
before the first column. If \fIcolumn\fR has the value \fBend\fR, or
if it is greater than or equal to the number of columns in the matrix,
then the new column is appended to the matrix, behind the last
column. The old column at the chosen index and all columns with higher
indices are shifted one index upward.
.TP
\fImatrixName\fR \fBinsert row\fR \fIrow ?values?\fR
Extends the matrix by one row and then acts like \fBsetrow\fR (see
below) on this new row if there were \fIvalues\fR supplied. Without
\fIvalues\fR the new cells will be set to the empty string. The new
row is inserted just before the row specified by the given index. This
means, if \fIrow\fR is less than or equal to zero, then the new row is
inserted at the beginning of the matrix, before the first row. If
\fIrow\fR has the value \fBend\fR, or if it is greater than or equal
to the number of rows in the matrix, then the new row is appended to
the matrix, behind the last row. The old row at that index and all
rows with higher indices are shifted one index upward.
.TP
\fImatrixName\fR \fBlink\fR \fI?-transpose? arrayvar\fR
Links the matrix to the specified array variable. This means that the
contents of all cells in the matrix is stored in the array too, with
all changes to the matrix propagated there too. The contents of the
cell \fI(column,row)\fR is stored in the array using the key
\fIcolumn,row\fR. If the option \fI-transpose\fR is specified the key
\fIrow,column\fR will be used instead. It is possible to link the
matrix to more than one array. Note that the link is bidirectional,
i.e. changes to the array are mirrored in the matrix too.
.TP
\fImatrixName\fR \fBrowheight\fR \fIrow\fR
Returns the height of the specified row in lines. This is the highest
number of lines spanned by a cell over all cells in the row.
.TP
\fImatrixName\fR \fBrows\fR
Returns the number of rows currently managed by the matrix.
.TP
\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBall\fR \fIpattern\fR
Searches the whole matrix for cells matching the \fIpattern\fR and
returns a list with all matches. Each item in the aforementioned list
is a list itself and contains the column and row index of the matching
cell, in this order. The results are ordered by column first and row
second, both times in ascending order. This means that matches to the
left and the top of the matrix come before matches to the right and
down.
.sp
The type of the pattern (string, glob, regular expression) is
determined by the option after the \fBsearch\fR keyword. If no option
is given it defaults to \fB-exact\fR.
.TP
\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBcolumn\fR \fIcolumn pattern\fR
Like \fBsearch all\fR, but the search is restricted to the specified
column.
.TP
\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBrow\fR    \fIrow pattern\fR
Like \fBsearch all\fR, but the search is restricted to the specified
row.
.TP
\fImatrixName\fR \fBsearch\fR ?-nocase? ?-exact|-glob|-regexp? \fBrect\fR \fIcolumn_tl row_tl column_br row_br pattern\fR
Like \fBsearch all\fR, but the search is restricted to the specified
rectangular area of the matrix.
.TP
\fImatrixName\fR \fBset cell\fR \fIcolumn row value\fR
Sets the value in the cell identified by row and column index to the
data in the third argument.
.TP
\fImatrixName\fR \fBset column\fR \fIcolumn values\fR
Sets the values in the cells identified by the column index to the
elements of the list provided as the third argument. Each element of
the list is assigned to one cell, with the first element going into
the cell in row 0 and then upward. If there are less values in the
list than there are rows the remaining rows are set to the empty
string. If there are more values in the list than there are rows the
superfluous elements are ignored. The matrix is not extended by this
operation.
.TP
\fImatrixName\fR \fBset rect\fR \fIcolumn row values\fR
Takes a list of lists of cell values and writes them into the
submatrix whose top-left cell is specified by the two indices. If the
sublists of the outerlist are not of equal length the shorter sublists
will be filled with empty strings to the length of the longest
sublist. If the submatrix specified by the top-left cell and the
number of rows and columns in the \fIvalues\fR extends beyond the
matrix we are modifying the over-extending parts of the values are
ignored, i.e. essentially cut off. This subcommand expects its input
in the format as returned by \fBgetrect\fR.
.TP
\fImatrixName\fR \fBset row\fR \fIrow values\fR
Sets the values in the cells identified by the row index to the
elements of the list provided as the third argument. Each element of
the list is assigned to one cell, with the first element going into
the cell in column 0 and then upward. If there are less values in the
list than there are columns the remaining columns are set to the empty
string. If there are more values in the list than there are columns
the superfluous elements are ignored. The matrix is not extended by
this operation.
.TP
\fImatrixName\fR \fBswap columns\fR \fIcolumn_a column_b\fR
Swaps the contents of the two specified columns.
.TP
\fImatrixName\fR \fBswap rows\fR \fIrow_a row_b\fR
Swaps the contents of the two specified rows.
.TP
\fImatrixName\fR \fBunlink\fR \fIarrayvar\fR
Removes the link between the matrix and the specified arrayvariable,
if there is one.

.SH EXAMPLES
.PP
The examples below assume a 5x5 matrix M with the first row containing
the values 1 to 5, with 1 in the top-left cell. Each other row
contains the contents of the row above it, rotated by one cell to the
right.
.PP
So
.PP
.CS
M getrect 0 0 4 4
.CE
.PP
returns
.PP
.CS
{{1 2 3 4 5} {5 1 2 3 4} {4 5 1 2 3} {3 4 5 1 2} {2 3 4 5 1}}
.CE
.PP
And
.PP
.CS
M setrect 1 1 {{0 0 0} {0 0 0} {0 0 0}}

M getrect 0 0 4 4
.CE
.PP
returns
.PP
.CS
{{1 2 3 4 5} {5 0 0 0 4} {4 0 0 0 3} {3 0 0 0 2} {2 3 4 5 1}}
.CE
.SH KEYWORDS
matrix
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































Deleted modules/struct/matrix.tcl.

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

package require Tcl 8.2

namespace eval ::struct {}

namespace eval ::struct::matrix {
    # Data storage in the matrix module
    # -------------------------------
    #
    # One namespace per object, containing
    #
    # - Two scalar variables containing the current number of rows and columns.
    # - Four array variables containing the array data, the caches for
    #   rowheights and columnwidths and the information about linked arrays.
    #
    # The variables are
    # - columns #columns in data
    # - rows    #rows in data
    # - data    cell contents
    # - colw    cache of columnwidths
    # - rowh    cache of rowheights
    # - link    information about linked arrays
    # - lock    boolean flag to disable MatTraceIn while in MatTraceOut [#532783]
    # - unset   string used to convey information about 'unset' traces from MatTraceIn to MatTraceOut.

    # counter is used to give a unique name for unnamed matrixs
    variable counter 0

    # commands is the list of subcommands recognized by the matrix
    variable commands
    set      commands(.) [list	\
	    "add"		\
	    "cells"		\
	    "cellsize"		\
	    "columns"		\
	    "columnwidth"	\
	    "delete"		\
	    "destroy"		\
	    "format"		\
	    "get"		\
	    "insert"		\
	    "link"		\
	    "rowheight"		\
	    "rows"		\
	    "search"		\
	    "set"		\
	    "swap"		\
	    "unlink"
	    ]

    # Some subcommands have their own subcommands.
    set commands(add)    [list "column" "columns" "row" "rows"]
    set commands(delete) [list "column" "row"]
    set commands(format) [list "2chan" "2string"]
    set commands(get)    [list "cell" "column" "rect" "row"]
    set commands(insert) [list "column" "row"]
    set commands(set)    [list "cell" "column" "rect" "row"]
    set commands(swap)   [list "columns" "rows"]

    # Only export one command, the one used to instantiate a new matrix
    namespace export matrix
}

# ::struct::matrix::matrix --
#
#	Create a new matrix with a given name; if no name is given, use
#	matrixX, where X is a number.
#
# Arguments:
#	name	Optional name of the matrix; if null or not given, generate one.
#
# Results:
#	name	Name of the matrix created

proc ::struct::matrix::matrix {{name ""}} {
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "matrix${counter}"
    }

    if { [llength [info commands ::$name]] } {
	error "command \"$name\" already exists, unable to create matrix"
    }

    # Set up the namespace
    namespace eval ::struct::matrix::matrix$name {
	variable columns 0
	variable rows    0

	variable data
	variable colw
	variable rowh
	variable link
	variable lock
	variable unset

	array set data  {}
	array set colw  {}
	array set rowh  {}
	array set link  {}
	set       lock  0
	set       unset {}
    }

    # Create the command to manipulate the matrix
    interp alias {} ::$name {} ::struct::matrix::MatrixProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::matrix::MatrixProc --
#
#	Command that processes all matrix object commands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand to invoke.
#	args	Arguments for subcommand.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::MatrixProc {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 ::struct::matrix::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(.) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::_$cmd $name] $args
}

# ::struct::matrix::_add --
#
#	Command that processes all 'add' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'add' to invoke.
#	args	Arguments for subcommand of 'add'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_add {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name add option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__add_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(add) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__add_$cmd $name] $args
}

# ::struct::matrix::_delete --
#
#	Command that processes all 'delete' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'delete' to invoke.
#	args	Arguments for subcommand of 'delete'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_delete {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name delete option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__delete_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(delete) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__delete_$cmd $name] $args
}

# ::struct::matrix::_format --
#
#	Command that processes all 'format' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'format' to invoke.
#	args	Arguments for subcommand of 'format'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_format {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name format option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__format_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(format) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__format_$cmd $name] $args
}

# ::struct::matrix::_get --
#
#	Command that processes all 'get' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'get' to invoke.
#	args	Arguments for subcommand of 'get'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_get {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name get option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__get_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(get) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__get_$cmd $name] $args
}

# ::struct::matrix::_insert --
#
#	Command that processes all 'insert' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'insert' to invoke.
#	args	Arguments for subcommand of 'insert'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_insert {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name insert option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__insert_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(insert) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__insert_$cmd $name] $args
}

# ::struct::matrix::_search --
#
#	Command that processes all 'search' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	args	Arguments for search.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_search {name args} {
    set mode   exact
    set nocase 0

    while {1} {
	switch -glob -- [lindex $args 0] {
	    -exact - -glob - -regexp {
		set mode [string range [lindex $args 0] 1 end]
		set args [lrange $args 1 end]
	    }
	    -nocase {
		set nocase 1
	    }
	    -* {
		return -code error \
			"invalid option \"[lindex $args 0]\":\
			should be -nocase, -exact, -glob, or -regexp"
	    }
	    default {
		break
	    }
	}
    }

    # Possible argument signatures after option processing
    #
    # \ | args
    # --+--------------------------------------------------------
    # 2 | all pattern
    # 3 | row row pattern, column col pattern
    # 6 | rect ctl rtl cbr rbr pattern
    #
    # All range specifications are internally converted into a
    # rectangle.

    switch -exact -- [llength $args] {
	2 - 3 - 6 {}
	default {
	    return -code error \
		"wrong # args: should be\
		\"$name search ?option...? (all|row row|column col|rect c r c r) pattern\""
	}
    }

    set range   [lindex $args 0]
    set pattern [lindex $args end]
    set args    [lrange $args 1 end-1]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows

    switch -exact -- $range {
	all {
	    set ctl 0 ; set cbr $cols ; incr cbr -1
	    set rtl 0 ; set rbr $rows ; incr rbr -1
	}
	column {
	    set ctl [ChkColumnIndex $name [lindex $args 0]]
	    set cbr $ctl
	    set rtl 0       ; set rbr $rows ; incr rbr -1
	}
	row {
	    set rtl [ChkRowIndex $name [lindex $args 0]]
	    set ctl 0    ; set cbr $cols ; incr cbr -1
	    set rbr $rtl
	}
	rect {
	    foreach {ctl rtl cbr rbr} $args break
	    set ctl [ChkColumnIndex $name $ctl]
	    set rtl [ChkRowIndex    $name $rtl]
	    set cbr [ChkColumnIndex $name $cbr]
	    set rbr [ChkRowIndex    $name $rbr]
	    if {($ctl > $cbr) || ($rtl > $rbr)} {
		return -code error "Invalid cell indices, wrong ordering"
	    }
	}
	default {
	    return -code error "invalid range spec \"$range\": should be all, column, row, or rect"
	}
    }

    if {$nocase} {
	set pattern [string tolower $pattern]
    }

    set matches [list]
    for {set r $rtl} {$r <= $rbr} {incr r} {
	for {set c $ctl} {$c <= $cbr} {incr c} {
	    set v  $data($c,$r)
	    if {$nocase} {
		set v [string tolower $v]
	    }
	    switch -exact -- $mode {
		exact  {set matched [string equal $pattern $v]}
		glob   {set matched [string match $pattern $v]}
		regexp {set matched [regexp --    $pattern $v]}
	    }
	    if {$matched} {
		lappend matches [list $c $r]
	    }
	}
    }
    return $matches
}

# ::struct::matrix::_set --
#
#	Command that processes all 'set' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'set' to invoke.
#	args	Arguments for subcommand of 'set'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_set {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name set option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__set_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(set) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__set_$cmd $name] $args
}

# ::struct::matrix::_swap --
#
#	Command that processes all 'swap' subcommands.
#
# Arguments:
#	name	Name of the matrix object to manipulate.
#	cmd	Subcommand of 'swap' to invoke.
#	args	Arguments for subcommand of 'swap'.
#
# Results:
#	Varies based on command to perform

proc ::struct::matrix::_swap {name {cmd ""} args} {
    # Do minimal args checks here
    if { [llength [info level 0]] == 2 } {
	error "wrong # args: should be \"$name swap option ?arg arg ...?\""
    }
    
    # Split the args into command and args components
    if { [llength [info commands ::struct::matrix::__swap_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands(swap) ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::matrix::__swap_$cmd $name] $args
}

# ::struct::matrix::__add_column --
#
#	Extends the matrix by one column and then acts like
#	"setcolumn" (see below) on this new column if there were
#	"values" supplied. Without "values" the new cells will be set
#	to the empty string. The new column is appended immediately
#	behind the last existing column.
#
# Arguments:
#	name	Name of the matrix object.
#	values	Optional values to set into the new row.
#
# Results:
#	None.

proc ::struct::matrix::__add_column {name {values {}}} {
    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::rowh    rh

    if {[set l [llength $values]] < $rows} {
	# Missing values. Fill up with empty strings

	for {} {$l < $rows} {incr l} {
	    lappend values {}
	}
    } elseif {[llength $values] > $rows} {
	# To many values. Remove the superfluous items
	set values [lrange $values 0 [expr {$rows - 1}]]
    }

    # "values" now contains the information to set into the array.
    # Regarding the width and height caches:

    # - The new column is not added to the width cache, the other
    #   columns are not touched, the cache therefore unchanged.
    # - The rows are either removed from the height cache or left
    #   unchanged, depending on the contents set into the cell.

    set r 0
    foreach v $values {
	if {$v != {}} {
	    # Data changed unpredictably, invalidate cache
	    catch {unset rh($r)}
	} ; # {else leave the row unchanged}
	set data($cols,$r) $v
	incr r
    }
    incr cols
    return
}

# ::struct::matrix::__add_row --
#
#	Extends the matrix by one row and then acts like "setrow" (see
#	below) on this new row if there were "values"
#	supplied. Without "values" the new cells will be set to the
#	empty string. The new row is appended immediately behind the
#	last existing row.
#
# Arguments:
#	name	Name of the matrix object.
#	values	Optional values to set into the new row.
#
# Results:
#	None.

proc ::struct::matrix::__add_row {name {values {}}} {
    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::colw    cw

    if {[set l [llength $values]] < $cols} {
	# Missing values. Fill up with empty strings

	for {} {$l < $cols} {incr l} {
	    lappend values {}
	}
    } elseif {[llength $values] > $cols} {
	# To many values. Remove the superfluous items
	set values [lrange $values 0 [expr {$cols - 1}]]
    }

    # "values" now contains the information to set into the array.
    # Regarding the width and height caches:

    # - The new row is not added to the height cache, the other
    #   rows are not touched, the cache therefore unchanged.
    # - The columns are either removed from the width cache or left
    #   unchanged, depending on the contents set into the cell.

    set c 0
    foreach v $values {
	if {$v != {}} {
	    # Data changed unpredictably, invalidate cache
	    catch {unset cw($c)}
	} ; # {else leave the row unchanged}
	set data($c,$rows) $v
	incr c
    }
    incr rows
    return
}

# ::struct::matrix::__add_columns --
#
#	Extends the matrix by "n" columns. The new cells will be set
#	to the empty string. The new columns are appended immediately
#	behind the last existing column. A value of "n" equal to or
#	smaller than 0 is not allowed.
#
# Arguments:
#	name	Name of the matrix object.
#	n	The number of new columns to create.
#
# Results:
#	None.

proc ::struct::matrix::__add_columns {name n} {
    if {$n <= 0} {
	return -code error "A value of n <= 0 is not allowed"
    }

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows

    # The new values set into the cell is always the empty
    # string. These have a length and height of 0, i.e. the don't
    # influence cached widths and heights as they are at least that
    # big. IOW there is no need to touch and change the width and
    # height caches.

    while {$n > 0} {
	for {set r 0} {$r < $rows} {incr r} {
	    set data($cols,$r) ""
	}
	incr cols
	incr n -1
    }

    return
}

# ::struct::matrix::__add_rows --
#
#	Extends the matrix by "n" rows. The new cells will be set to
#	the empty string. The new rows are appended immediately behind
#	the last existing row. A value of "n" equal to or smaller than
#	0 is not allowed.
#
# Arguments:
#	name	Name of the matrix object.
#	n	The number of new rows to create.
#
# Results:
#	None.

proc ::struct::matrix::__add_rows {name n} {
    if {$n <= 0} {
	return -code error "A value of n <= 0 is not allowed"
    }

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows

    # The new values set into the cell is always the empty
    # string. These have a length and height of 0, i.e. the don't
    # influence cached widths and heights as they are at least that
    # big. IOW there is no need to touch and change the width and
    # height caches.

    while {$n > 0} {
	for {set c 0} {$c < $cols} {incr c} {
	    set data($c,$rows) ""
	}
	incr rows
	incr n -1
    }
    return
}

# ::struct::matrix::_cells --
#
#	Returns the number of cells currently managed by the
#	matrix. This is the product of "rows" and "columns".
#
# Arguments:
#	name	Name of the matrix object.
#
# Results:
#	The number of cells in the matrix.

proc ::struct::matrix::_cells {name} {
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::columns columns
    return [expr {$rows * $columns}]
}

# ::struct::matrix::_cellsize --
#
#	Returns the length of the string representation of the value
#	currently contained in the addressed cell.
#
# Arguments:
#	name	Name of the matrix object.
#	column	Column index of the cell to query
#	row	Row index of the cell to query
#
# Results:
#	The number of cells in the matrix.

proc ::struct::matrix::_cellsize {name column row} {
    set column [ChkColumnIndex $name $column]
    set row    [ChkRowIndex    $name $row]

    upvar ::struct::matrix::matrix${name}::data data
    return [string length $data($column,$row)]
}

# ::struct::matrix::_columns --
#
#	Returns the number of columns currently managed by the
#	matrix.
#
# Arguments:
#	name	Name of the matrix object.
#
# Results:
#	The number of columns in the matrix.

proc ::struct::matrix::_columns {name} {
    upvar ::struct::matrix::matrix${name}::columns columns
    return $columns
}

# ::struct::matrix::_columnwidth --
#
#	Returns the length of the longest string representation of all
#	the values currently contained in the cells of the addressed
#	column if these are all spanning only one line. For cell
#	values spanning multiple lines the length of their longest
#	line goes into the computation.
#
# Arguments:
#	name	Name of the matrix object.
#	column	The index of the column whose width is asked for.
#
# Results:
#	See description.

proc ::struct::matrix::_columnwidth {name column} {
    set column [ChkColumnIndex $name $column]

    upvar ::struct::matrix::matrix${name}::colw cw

    if {![info exists cw($column)]} {
	upvar ::struct::matrix::matrix${name}::rows rows
	upvar ::struct::matrix::matrix${name}::data data

	set width 0
	for {set r 0} {$r < $rows} {incr r} {
	    foreach line [split $data($column,$r) \n] {
		set len [string length $line]
		if {$len > $width} {
		    set width $len
		}
	    }
	}

	set cw($column) $width
    }

    return $cw($column)
}

# ::struct::matrix::__delete_column --
#
#	Deletes the specified column from the matrix and shifts all
#	columns with higher indices one index down.
#
# Arguments:
#	name	Name of the matrix.
#	column	The index of the column to delete.
#
# Results:
#	None.

proc ::struct::matrix::__delete_column {name column} {
    set column [ChkColumnIndex $name $column]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::colw    cw
    upvar ::struct::matrix::matrix${name}::rowh    rh

    # Move all data from the higher columns down and then delete the
    # superfluous data in the old last column. Move the data in the
    # width cache too, take partial fill into account there too.
    # Invalidate the height cache for all rows.

    for {set r 0} {$r < $rows} {incr r} {
	for {set c $column; set cn [expr {$c + 1}]} {$cn < $cols} {incr c ; incr cn} {
	    set data($c,$r) $data($cn,$r)
	    if {[info exists cw($cn)]} {
		set cw($c) $cw($cn)
		unset cw($cn)
	    }
	}
	unset data($c,$r)
	catch {unset rh($r)}
    }
    incr cols -1
    return
}

# ::struct::matrix::__delete_row --
#
#	Deletes the specified row from the matrix and shifts all
#	row with higher indices one index down.
#
# Arguments:
#	name	Name of the matrix.
#	row	The index of the row to delete.
#
# Results:
#	None.

proc ::struct::matrix::__delete_row {name row} {
    set row [ChkRowIndex $name $row]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::colw    cw
    upvar ::struct::matrix::matrix${name}::rowh    rh

    # Move all data from the higher rows down and then delete the
    # superfluous data in the old last row. Move the data in the
    # height cache too, take partial fill into account there too.
    # Invalidate the width cache for all columns.

    for {set c 0} {$c < $cols} {incr c} {
	for {set r $row; set rn [expr {$r + 1}]} {$rn < $rows} {incr r ; incr rn} {
	    set data($c,$r) $data($c,$rn)
	    if {[info exists rh($rn)]} {
		set rh($r) $rh($rn)
		unset rh($rn)
	    }
	}
	unset data($c,$r)
	catch {unset cw($c)}
    }
    incr rows -1
    return
}

# ::struct::matrix::_destroy --
#
#	Destroy a matrix, including its associated command and data storage.
#
# Arguments:
#	name	Name of the matrix to destroy.
#
# Results:
#	None.

proc ::struct::matrix::_destroy {name} {
    upvar ::struct::matrix::matrix${name}::link link

    # Unlink all existing arrays before destroying the object so that
    # we don't leave dangling references / traces.

    foreach avar [array names link] {
	_unlink $name $avar
    }

    namespace delete ::struct::matrix::matrix$name
    interp alias {} ::$name {}
}

# ::struct::matrix::__format_2string --
#
#	Formats the matrix using the specified report object and
#	returns the string containing the result of this
#	operation. The report has to support the "printmatrix" method.
#
# Arguments:
#	name	Name of the matrix.
#	report	Name of the report object specifying the formatting.
#
# Results:
#	A string containing the formatting result.

proc ::struct::matrix::__format_2string {name {report {}}} {
    if {$report == {}} {
	# Use an internal hardwired simple report to format the matrix.
	# 1. Go through all columns and compute the column widths.
	# 2. Then iterate through all rows and dump then into a
	#    string, formatted to the number of characters per columns

	array set cw {}
	set cols [_columns $name]
	for {set c 0} {$c < $cols} {incr c} {
	    set cw($c) [_columnwidth $name $c]
	}

	set result [list]
	set n [_rows $name]
	for {set r 0} {$r < $n} {incr r} {
	    set rh [_rowheight $name $r]
	    if {$rh < 2} {
		# Simple row.
		set line [list]
		for {set c 0} {$c < $cols} {incr c} {
		    set val [__get_cell $name $c $r]
		    lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]"
		}
		lappend result [join $line " "]
	    } else {
		# Complex row, multiple passes
		for {set h 0} {$h < $rh} {incr h} {
		    set line [list]
		    for {set c 0} {$c < $cols} {incr c} {
			set val [lindex [split [__get_cell $name $c $r] \n] $h]
			lappend line "$val[string repeat " " [expr {$cw($c)-[string length $val]}]]"
		    }
		    lappend result [join $line " "]
		}
	    }
	}
	return [join $result \n]
    } else {
	return [$report printmatrix $name]
    }
}

# ::struct::matrix::__format_2chan --
#
#	Formats the matrix using the specified report object and
#	writes the string containing the result of this operation into
#	the channel. The report has to support the
#	"printmatrix2channel" method.
#
# Arguments:
#	name	Name of the matrix.
#	report	Name of the report object specifying the formatting.
#	chan	Handle of the channel to write to.
#
# Results:
#	None.

proc ::struct::matrix::__format_2chan {name {report {}} {chan stdout}} {
    if {$report == {}} {
	# Use an internal hardwired simple report to format the matrix.
	# We delegate this to the string formatter and print its result.
	puts -nonewline [__format_2string $name]
    } else {
	$report printmatrix2channel $name $chan
    }
    return
}

# ::struct::matrix::__get_dell --
#
#	Returns the value currently contained in the cell identified
#	by row and column index.
#
# Arguments:
#	name	Name of the matrix.
#	column	Column index of the addressed cell.
#	row	Row index of the addressed cell.
#
# Results:
#	value	Value currently stored in the addressed cell.

proc ::struct::matrix::__get_cell {name column row} {
    set column [ChkColumnIndex $name $column]
    set row    [ChkRowIndex    $name $row]

    upvar ::struct::matrix::matrix${name}::data data
    return $data($column,$row)
}

# ::struct::matrix::__get_column --
#
#	Returns a list containing the values from all cells in the
#	column identified by the index. The contents of the cell in
#	row 0 are stored as the first element of this list.
#
# Arguments:
#	name	Name of the matrix.
#	column	Column index of the addressed cell.
#
# Results:
#	List of values stored in the addressed row.

proc ::struct::matrix::__get_column {name column} {
    set column [ChkColumnIndex $name $column]

    upvar ::struct::matrix::matrix${name}::data data
    upvar ::struct::matrix::matrix${name}::rows rows

    set result [list]
    for {set r 0} {$r < $rows} {incr r} {
	lappend result $data($column,$r)
    }
    return $result
}

# ::struct::matrix::__get_rect --
#
#	Returns a list of lists of cell values. The values stored in
#	the result come from the submatrix whose top-left and
#	bottom-right cells are specified by "column_tl", "row_tl" and
#	"column_br", "row_br" resp. Note that the following equations
#	have to be true: column_tl <= column_br and row_tl <= row_br.
#	The result is organized as follows: The outer list is the list
#	of rows, its elements are lists representing a single row. The
#	row with the smallest index is the first element of the outer
#	list. The elements of the row lists represent the selected
#	cell values. The cell with the smallest index is the first
#	element in each row list.
#
# Arguments:
#	name		Name of the matrix.
#	column_tl	Column index of the top-left cell of the area.
#	row_tl		Row index of the top-left cell of the the area
#	column_br	Column index of the bottom-right cell of the area.
#	row_br		Row index of the bottom-right cell of the the area
#
# Results:
#	List of a list of values stored in the addressed area.

proc ::struct::matrix::__get_rect {name column_tl row_tl column_br row_br} {
    set column_tl [ChkColumnIndex $name $column_tl]
    set row_tl    [ChkRowIndex    $name $row_tl]
    set column_br [ChkColumnIndex $name $column_br]
    set row_br    [ChkRowIndex    $name $row_br]

    if {
	($column_tl > $column_br) ||
	($row_tl    > $row_br)
    } {
	return -code error "Invalid cell indices, wrong ordering"
    }

    upvar ::struct::matrix::matrix${name}::data data
    set result [list]

    for {set r $row_tl} {$r <= $row_br} {incr r} {
	set row [list]
	for {set c $column_tl} {$c <= $column_br} {incr c} {
	    lappend row $data($c,$r)
	}
	lappend result $row
    }

    return $result
}

# ::struct::matrix::__get_row --
#
#	Returns a list containing the values from all cells in the
#	row identified by the index. The contents of the cell in
#	column 0 are stored as the first element of this list.
#
# Arguments:
#	name	Name of the matrix.
#	row	Row index of the addressed cell.
#
# Results:
#	List of values stored in the addressed row.

proc ::struct::matrix::__get_row {name row} {
    set row [ChkRowIndex $name $row]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols

    set result [list]
    for {set c 0} {$c < $cols} {incr c} {
	lappend result $data($c,$row)
    }
    return $result
}

# ::struct::matrix::__insert_column --
#
#	Extends the matrix by one column and then acts like
#	"setcolumn" (see below) on this new column if there were
#	"values" supplied. Without "values" the new cells will be set
#	to the empty string. The new column is inserted just before
#	the column specified by the given index. This means, if
#	"column" is less than or equal to zero, then the new column is
#	inserted at the beginning of the matrix, before the first
#	column. If "column" has the value "Bend", or if it is greater
#	than or equal to the number of columns in the matrix, then the
#	new column is appended to the matrix, behind the last
#	column. The old column at the chosen index and all columns
#	with higher indices are shifted one index upward.
#
# Arguments:
#	name	Name of the matrix.
#	column	Index of the column where to insert.
#	values	Optional values to set the cells to.
#
# Results:
#	None.

proc ::struct::matrix::__insert_column {name column {values {}}} {
    # Allow both negative and too big indices.
    set column [ChkColumnIndexAll $name $column]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::rowh    rh

    if {$column > $cols} {
	# Same as 'addcolumn'
	__add_column $name $values
	return
    }

    set firstcol $column
    if {$firstcol < 0} {
	set firstcol 0
    }

    if {[set l [llength $values]] < $rows} {
	# Missing values. Fill up with empty strings

	for {} {$l < $rows} {incr l} {
	    lappend values {}
	}
    } elseif {[llength $values] > $rows} {
	# To many values. Remove the superfluous items
	set values [lrange $values 0 [expr {$rows - 1}]]
    }

    # "values" now contains the information to set into the array.
    # Regarding the width and height caches:
    # Invalidate all rows, move all columns

    # Move all data from the higher columns one up and then insert the
    # new data into the freed space. Move the data in the
    # width cache too, take partial fill into account there too.
    # Invalidate the height cache for all rows.

    for {set r 0} {$r < $rows} {incr r} {
	for {set cn $cols ; set c [expr {$cn - 1}]} {$c >= $firstcol} {incr c -1 ; incr cn -1} {
	    set data($cn,$r) $data($c,$r)
	    if {[info exists cw($c)]} {
		set cw($cn) $cw($c)
		unset cw($c)
	    }
	}
	set data($firstcol,$r) [lindex $values $r]
	catch {unset rh($r)}
    }
    incr cols
    return
}

# ::struct::matrix::__insert_row --
#
#	Extends the matrix by one row and then acts like "setrow" (see
#	below) on this new row if there were "values"
#	supplied. Without "values" the new cells will be set to the
#	empty string. The new row is inserted just before the row
#	specified by the given index. This means, if "row" is less
#	than or equal to zero, then the new row is inserted at the
#	beginning of the matrix, before the first row. If "row" has
#	the value "end", or if it is greater than or equal to the
#	number of rows in the matrix, then the new row is appended to
#	the matrix, behind the last row. The old row at that index and
#	all rows with higher indices are shifted one index upward.
#
# Arguments:
#	name	Name of the matrix.
#	row	Index of the row where to insert.
#	values	Optional values to set the cells to.
#
# Results:
#	None.

proc ::struct::matrix::__insert_row {name row {values {}}} {
    # Allow both negative and too big indices.
    set row [ChkRowIndexAll $name $row]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::rowh    rh

    if {$row > $rows} {
	# Same as 'addrow'
	__add_row $name $values
	return
    }

    set firstrow $row
    if {$firstrow < 0} {
	set firstrow 0
    }

    if {[set l [llength $values]] < $cols} {
	# Missing values. Fill up with empty strings

	for {} {$l < $cols} {incr l} {
	    lappend values {}
	}
    } elseif {[llength $values] > $cols} {
	# To many values. Remove the superfluous items
	set values [lrange $values 0 [expr {$cols - 1}]]
    }

    # "values" now contains the information to set into the array.
    # Regarding the width and height caches:
    # Invalidate all columns, move all rows

    # Move all data from the higher rows one up and then insert the
    # new data into the freed space. Move the data in the
    # height cache too, take partial fill into account there too.
    # Invalidate the width cache for all columns.

    for {set c 0} {$c < $cols} {incr c} {
	for {set rn $rows ; set r [expr {$rn - 1}]} {$r >= $firstrow} {incr r -1 ; incr rn -1} {
	    set data($c,$rn) $data($c,$r)
	    if {[info exists rh($r)]} {
		set rh($rn) $rh($r)
		unset rh($r)
	    }
	}
	set data($c,$firstrow) [lindex $values $c]
	catch {unset cw($c)}
    }
    incr rows
    return
}

# ::struct::matrix::_link --
#
#	Links the matrix to the specified array variable. This means
#	that the contents of all cells in the matrix is stored in the
#	array too, with all changes to the matrix propagated there
#	too. The contents of the cell "(column,row)" is stored in the
#	array using the key "column,row". If the option "-transpose"
#	is specified the key "row,column" will be used instead. It is
#	possible to link the matrix to more than one array. Note that
#	the link is bidirectional, i.e. changes to the array are
#	mirrored in the matrix too.
#
# Arguments:
#	name	Name of the matrix object.
#	option	Either empty of '-transpose'.
#	avar	Name of the variable to link to
#
# Results:
#	None

proc ::struct::matrix::_link {name args} {
    switch -exact -- [llength $args] {
	0 {
	    return -code error "$name: wrong # args: link ?-transpose? arrayvariable"
	}
	1 {
	    set transpose 0
	    set variable  [lindex $args 0]
	}
	2 {
	    foreach {t variable} $args break
	    if {[string compare $t -transpose]} {
		return -code error "$name: illegal syntax: link ?-transpose? arrayvariable"
	    }
	    set transpose 1
	}
	default {
	    return -code error "$name: wrong # args: link ?-transpose? arrayvariable"
	}
    }

    upvar ::struct::matrix::matrix${name}::link link

    if {[info exists link($variable)]} {
	return -code error "$name link: Variable \"$variable\" already linked to matrix"
    }

    # Ok, a new variable we are linked to. Record this information,
    # dump our current contents into the array, at last generate the
    # traces actually performing the link.

    set link($variable) $transpose

    upvar #0 $variable array
    upvar ::struct::matrix::matrix${name}::data data

    foreach key [array names data] {
	foreach {c r} [split $key ,] break
	if {$transpose} {
	    set array($r,$c) $data($key)
	} else {
	    set array($c,$r) $data($key)
	}
    }

    trace variable array wu [list ::struct::matrix::MatTraceIn  $variable $name]
    trace variable data  w  [list ::struct::matrix::MatTraceOut $variable $name]
    return
}

# ::struct::matrix::_links --
#
#	Retrieves the names of all array variable the matrix is
#	officialy linked to.
#
# Arguments:
#	name	Name of the matrix object.
#
# Results:
#	List of variables the matrix is linked to.

proc ::struct::matrix::_links {name} {
    upvar ::struct::matrix::matrix${name}::link link
    return [array names link]
}

# ::struct::matrix::_rowheight --
#
#	Returns the height of the specified row in lines. This is the
#	highest number of lines spanned by a cell over all cells in
#	the row.
#
# Arguments:
#	name	Name of the matrix
#	row	Index of the row queried for its height
#
# Results:
#	The height of the specified row in lines.

proc ::struct::matrix::_rowheight {name row} {
    set row [ChkRowIndex $name $row]

    upvar ::struct::matrix::matrix${name}::rowh rh

    if {![info exists rh($row)]} {
	upvar ::struct::matrix::matrix${name}::columns cols
	upvar ::struct::matrix::matrix${name}::data data

	set height 1
	for {set c 0} {$c < $cols} {incr c} {
	    set cheight [llength [split $data($c,$row) \n]]
	    if {$cheight > $height} {
		set height $cheight
	    }
	}

	set rh($row) $height
    }
    return $rh($row)
}

# ::struct::matrix::_rows --
#
#	Returns the number of rows currently managed by the matrix.
#
# Arguments:
#	name	Name of the matrix object.
#
# Results:
#	The number of rows in the matrix.

proc ::struct::matrix::_rows {name} {
    upvar ::struct::matrix::matrix${name}::rows rows
    return $rows
}

# ::struct::matrix::__set_cell --
#
#	Sets the value in the cell identified by row and column index
#	to the data in the third argument.
#
# Arguments:
#	name	Name of the matrix object.
#	column	Column index of the cell to set.
#	row	Row index of the cell to set.
#	value	THe new value of the cell.
#
# Results:
#	None.
 
proc ::struct::matrix::__set_cell {name column row value} {
    set column [ChkColumnIndex $name $column]
    set row    [ChkRowIndex    $name $row]

    upvar ::struct::matrix::matrix${name}::data data

    if {![string compare $value $data($column,$row)]} {
	# No change, ignore call!
	return
    }

    set data($column,$row) $value

    if {$value != {}} {
	upvar ::struct::matrix::matrix${name}::colw colw
	upvar ::struct::matrix::matrix${name}::rowh rowh
	catch {unset colw($column)}
	catch {unset rowh($row)}
    }
    return
}

# ::struct::matrix::__set_column --
#
#	Sets the values in the cells identified by the column index to
#	the elements of the list provided as the third argument. Each
#	element of the list is assigned to one cell, with the first
#	element going into the cell in row 0 and then upward. If there
#	are less values in the list than there are rows the remaining
#	rows are set to the empty string. If there are more values in
#	the list than there are rows the superfluous elements are
#	ignored. The matrix is not extended by this operation.
#
# Arguments:
#	name	Name of the matrix.
#	column	Index of the column to set.
#	values	Values to set into the column.
#
# Results:
#	None.

proc ::struct::matrix::__set_column {name column values} {
    set column [ChkColumnIndex $name $column]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::rowh    rh
    upvar ::struct::matrix::matrix${name}::colw    cw

    if {[set l [llength $values]] < $rows} {
	# Missing values. Fill up with empty strings

	for {} {$l < $rows} {incr l} {
	    lappend values {}
	}
    } elseif {[llength $values] > $rows} {
	# To many values. Remove the superfluous items
	set values [lrange $values 0 [expr {$rows - 1}]]
    }

    # "values" now contains the information to set into the array.
    # Regarding the width and height caches:

    # - Invalidate the column in the width cache.
    # - The rows are either removed from the height cache or left
    #   unchanged, depending on the contents set into the cell.

    set r 0
    foreach v $values {
	if {$v != {}} {
	    # Data changed unpredictably, invalidate cache
	    catch {unset rh($r)}
	} ; # {else leave the row unchanged}
	set data($column,$r) $v
	incr r
    }
    catch {unset cw($column)}
    return
}

# ::struct::matrix::__set_rect --
#
#	Takes a list of lists of cell values and writes them into the
#	submatrix whose top-left cell is specified by the two
#	indices. If the sublists of the outerlist are not of equal
#	length the shorter sublists will be filled with empty strings
#	to the length of the longest sublist. If the submatrix
#	specified by the top-left cell and the number of rows and
#	columns in the "values" extends beyond the matrix we are
#	modifying the over-extending parts of the values are ignored,
#	i.e. essentially cut off. This subcommand expects its input in
#	the format as returned by "getrect".
#
# Arguments:
#	name	Name of the matrix object.
#	column	Column index of the topleft cell to set.
#	row	Row index of the topleft cell to set.
#	values	Values to set.
#
# Results:
#	None.

proc ::struct::matrix::__set_rect {name column row values} {
    # Allow negative indices!
    set column [ChkColumnIndexNeg $name $column]
    set row    [ChkRowIndexNeg    $name $row]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::colw    colw
    upvar ::struct::matrix::matrix${name}::rowh    rowh

    if {$row < 0} {
	# Remove rows from the head of values to restrict it to the
	# overlapping area.

	set values [lrange $values [expr {0 - $row}] end]
	set row 0
    }

    # Restrict it at the end too.
    if {($row + [llength $values]) > $rows} {
	set values [lrange $values 0 [expr {$rows - $row - 1}]]
    }

    # Same for columns, but store it in some vars as this is required
    # in a loop.
    set firstcol 0
    if {$column < 0} {
	set firstcol [expr {0 - $column}]
	set column 0
    }

    # Now pan through values and area and copy the external data into
    # the matrix.

    set r $row
    foreach line $values {
	set line [lrange $line $firstcol end]

	set l [expr {$column + [llength $line]}]
	if {$l > $cols} {
	    set line [lrange $line 0 [expr {$cols - $column - 1}]]
	} elseif {$l < [expr {$cols - $firstcol}]} {
	    # We have to take the offset into the line into account
	    # or we add fillers we don't need, overwriting part of the
	    # data array we shouldn't.

	    for {} {$l < [expr {$cols - $firstcol}]} {incr l} {
		lappend line {}
	    }
	}

	set c $column
	foreach cell $line {
	    if {$cell != {}} {
		catch {unset rh($r)}
		catch {unset cw($c)}
	    }
	    set data($c,$r) $cell
	    incr c
	}
	incr r
    }
    return
}

# ::struct::matrix::__set_row --
#
#	Sets the values in the cells identified by the row index to
#	the elements of the list provided as the third argument. Each
#	element of the list is assigned to one cell, with the first
#	element going into the cell in column 0 and then upward. If
#	there are less values in the list than there are columns the
#	remaining columns are set to the empty string. If there are
#	more values in the list than there are columns the superfluous
#	elements are ignored. The matrix is not extended by this
#	operation.
#
# Arguments:
#	name	Name of the matrix.
#	row	Index of the row to set.
#	values	Values to set into the row.
#
# Results:
#	None.

proc ::struct::matrix::__set_row {name row values} {
    set row [ChkRowIndex $name $row]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rows    rows
    upvar ::struct::matrix::matrix${name}::colw    cw
    upvar ::struct::matrix::matrix${name}::rowh    rh

    if {[set l [llength $values]] < $cols} {
	# Missing values. Fill up with empty strings

	for {} {$l < $cols} {incr l} {
	    lappend values {}
	}
    } elseif {[llength $values] > $cols} {
	# To many values. Remove the superfluous items
	set values [lrange $values 0 [expr {$cols - 1}]]
    }

    # "values" now contains the information to set into the array.
    # Regarding the width and height caches:

    # - Invalidate the row in the height cache.
    # - The columns are either removed from the width cache or left
    #   unchanged, depending on the contents set into the cell.

    set c 0
    foreach v $values {
	if {$v != {}} {
	    # Data changed unpredictably, invalidate cache
	    catch {unset cw($c)}
	} ; # {else leave the row unchanged}
	set data($c,$row) $v
	incr c
    }
    catch {unset rh($row)}
    return
}

# ::struct::matrix::__swap_columns --
#
#	Swaps the contents of the two specified columns.
#
# Arguments:
#	name		Name of the matrix.
#	column_a	Index of the first column to swap
#	column_b	Index of the second column to swap
#
# Results:
#	None.

proc ::struct::matrix::__swap_columns {name column_a column_b} {
    set column_a [ChkColumnIndex $name $column_a]
    set column_b [ChkColumnIndex $name $column_b]

    upvar ::struct::matrix::matrix${name}::data data
    upvar ::struct::matrix::matrix${name}::rows rows
    upvar ::struct::matrix::matrix${name}::colw colw

    # Note: This operation does not influence the height cache for all
    # rows and the width cache only insofar as its contents has to be
    # swapped too for the two columns we are touching. Note that the
    # cache might be partially filled or not at all, so we don't have
    # to "swap" in some situations.

    for {set r 0} {$r < $rows} {incr r} {
	set tmp                $data($column_a,$r)
	set data($column_a,$r) $data($column_b,$r)
	set data($column_b,$r) $tmp
    }

    set cwa [info exists colw($column_a)]
    set cwb [info exists colw($column_b)]

    if {$cwa && $cwb} {
	set tmp             $colw($column_a)
	set colw($column_a) $colw($column_b)
	set colw($column_b) $tmp
    } elseif {$cwa} {
	# Move contents, don't swap.
	set   colw($column_b) $colw($column_a)
	unset colw($column_a)
    } elseif {$cwb} {
	# Move contents, don't swap.
	set   colw($column_a) $colw($column_b)
	unset colw($column_b)
    } ; # else {nothing to do at all}
    return
}

# ::struct::matrix::__swap_rows --
#
#	Swaps the contents of the two specified rows.
#
# Arguments:
#	name	Name of the matrix.
#	row_a	Index of the first row to swap
#	row_b	Index of the second row to swap
#
# Results:
#	None.

proc ::struct::matrix::__swap_rows {name row_a row_b} {
    set row_a [ChkRowIndex $name $row_a]
    set row_b [ChkRowIndex $name $row_b]

    upvar ::struct::matrix::matrix${name}::data    data
    upvar ::struct::matrix::matrix${name}::columns cols
    upvar ::struct::matrix::matrix${name}::rowh    rowh

    # Note: This operation does not influence the width cache for all
    # columns and the height cache only insofar as its contents has to be
    # swapped too for the two rows we are touching. Note that the
    # cache might be partially filled or not at all, so we don't have
    # to "swap" in some situations.

    for {set c 0} {$c < $cols} {incr c} {
	set tmp             $data($c,$row_a)
	set data($c,$row_a) $data($c,$row_b)
	set data($c,$row_b) $tmp
    }

    set rha [info exists rowh($row_a)]
    set rhb [info exists rowh($row_b)]

    if {$rha && $rhb} {
	set tmp          $rowh($row_a)
	set rowh($row_a) $rowh($row_b)
	set rowh($row_b) $tmp
    } elseif {$rha} {
	# Move contents, don't swap.
	set   rowh($row_b) $rowh($row_a)
	unset rowh($row_a)
    } elseif {$rhb} {
	# Move contents, don't swap.
	set   rowh($row_a) $rowh($row_b)
	unset rowh($row_b)
    } ; # else {nothing to do at all}
    return
}

# ::struct::matrix::_unlink --
#
#	Removes the link between the matrix and the specified
#	arrayvariable, if there is one.
#
# Arguments:
#	name	Name of the matrix.
#	avar	Name of the linked array.
#
# Results:
#	None.

proc ::struct::matrix::_unlink {name avar} {

    upvar ::struct::matrix::matrix${name}::link link

    if {![info exists link($avar)]} {
	# Ignore unlinking of unkown variables.
	return
    }

    # Delete the traces first, then remove the link management
    # information from the object.

    upvar #0 $avar array
    upvar ::struct::matrix::matrix${name}::data data

    trace vdelete array wu [list ::struct::matrix::MatTraceIn  $avar $name]
    trace vdelete date  w  [list ::struct::matrix::MatTraceOut $avar $name]

    unset link($avar)
    return
}

# ::struct::matrix::ChkColumnIndex --
#
#	Helper to check and transform column indices. Returns the
#	absolute index number belonging to the specified
#	index. Rejects indices out of the valid range of columns.
#
# Arguments:
#	matrix	Matrix to look at
#	column	The incoming index to check and transform
#
# Results:
#	The absolute index to the column

proc ::struct::matrix::ChkColumnIndex {name column} {
    upvar ::struct::matrix::matrix${name}::columns c

    switch -regex -- $column {
	{end-[0-9]+} {
	    set column [string map {end- ""} $column]
	    set cc [expr {$c - 1 - $column}]
	    if {($cc < 0) || ($cc >= $c)} {
		return -code error "bad column index end-$column, column does not exist"
	    }
	    return $cc
	}
	end {
	    if {$c <= 0} {
		return -code error "bad column index $column, column does not exist"
	    }
	    return [expr {$c - 1}]
	}
	{[0-9]+} {
	    if {($column < 0) || ($column >= $c)} {
		return -code error "bad column index $column, column does not exist"
	    }
	    return $column
	}
	default {
	    return -code error "bad column index \"$column\", syntax error"
	}
    }
    # Will not come to this place
}

# ::struct::matrix::ChkRowIndex --
#
#	Helper to check and transform row indices. Returns the
#	absolute index number belonging to the specified
#	index. Rejects indices out of the valid range of rows.
#
# Arguments:
#	matrix	Matrix to look at
#	row	The incoming index to check and transform
#
# Results:
#	The absolute index to the row

proc ::struct::matrix::ChkRowIndex {name row} {
    upvar ::struct::matrix::matrix${name}::rows r

    switch -regex -- $row {
	{end-[0-9]+} {
	    set row [string map {end- ""} $row]
	    set rr [expr {$r - 1 - $row}]
	    if {($rr < 0) || ($rr >= $r)} {
		return -code error "bad row index end-$row, row does not exist"
	    }
	    return $rr
	}
	end {
	    if {$r <= 0} {
		return -code error "bad row index $row, row does not exist"
	    }
	    return [expr {$r - 1}]
	}
	{[0-9]+} {
	    if {($row < 0) || ($row >= $r)} {
		return -code error "bad row index $row, row does not exist"
	    }
	    return $row
	}
	default {
	    return -code error "bad row index \"$row\", syntax error"
	}
    }
    # Will not come to this place
}

# ::struct::matrix::ChkColumnIndexNeg --
#
#	Helper to check and transform column indices. Returns the
#	absolute index number belonging to the specified
#	index. Rejects indices out of the valid range of columns
#	(Accepts negative indices).
#
# Arguments:
#	matrix	Matrix to look at
#	column	The incoming index to check and transform
#
# Results:
#	The absolute index to the column

proc ::struct::matrix::ChkColumnIndexNeg {name column} {
    upvar ::struct::matrix::matrix${name}::columns c

    switch -regex -- $column {
	{end-[0-9]+} {
	    set column [string map {end- ""} $column]
	    set cc [expr {$c - 1 - $column}]
	    if {$cc >= $c} {
		return -code error "bad column index end-$column, column does not exist"
	    }
	    return $cc
	}
	end {
	    return [expr {$c - 1}]
	}
	{[0-9]+} {
	    if {$column >= $c} {
		return -code error "bad column index $column, column does not exist"
	    }
	    return $column
	}
	default {
	    return -code error "bad column index \"$column\", syntax error"
	}
    }
    # Will not come to this place
}

# ::struct::matrix::ChkRowIndexNeg --
#
#	Helper to check and transform row indices. Returns the
#	absolute index number belonging to the specified
#	index. Rejects indices out of the valid range of rows
#	(Accepts negative indices).
#
# Arguments:
#	matrix	Matrix to look at
#	row	The incoming index to check and transform
#
# Results:
#	The absolute index to the row

proc ::struct::matrix::ChkRowIndexNeg {name row} {
    upvar ::struct::matrix::matrix${name}::rows r

    switch -regex -- $row {
	{end-[0-9]+} {
	    set row [string map {end- ""} $row]
	    set rr [expr {$r - 1 - $row}]
	    if {$rr >= $r} {
		return -code error "bad row index end-$row, row does not exist"
	    }
	    return $rr
	}
	end {
	    return [expr {$r - 1}]
	}
	{[0-9]+} {
	    if {$row >= $r} {
		return -code error "bad row index $row, row does not exist"
	    }
	    return $row
	}
	default {
	    return -code error "bad row index \"$row\", syntax error"
	}
    }
    # Will not come to this place
}

# ::struct::matrix::ChkColumnIndexAll --
#
#	Helper to transform column indices. Returns the
#	absolute index number belonging to the specified
#	index.
#
# Arguments:
#	matrix	Matrix to look at
#	column	The incoming index to check and transform
#
# Results:
#	The absolute index to the column

proc ::struct::matrix::ChkColumnIndexAll {name column} {
    upvar ::struct::matrix::matrix${name}::columns c

    switch -regex -- $column {
	{end-[0-9]+} {
	    set column [string map {end- ""} $column]
	    set cc [expr {$c - 1 - $column}]
	    return $cc
	}
	end {
	    return $c
	}
	{[0-9]+} {
	    return $column
	}
	default {
	    return -code error "bad column index \"$column\", syntax error"
	}
    }
    # Will not come to this place
}

# ::struct::matrix::ChkRowIndexAll --
#
#	Helper to transform row indices. Returns the
#	absolute index number belonging to the specified
#	index.
#
# Arguments:
#	matrix	Matrix to look at
#	row	The incoming index to check and transform
#
# Results:
#	The absolute index to the row

proc ::struct::matrix::ChkRowIndexAll {name row} {
    upvar ::struct::matrix::matrix${name}::rows r

    switch -regex -- $row {
	{end-[0-9]+} {
	    set row [string map {end- ""} $row]
	    set rr [expr {$r - 1 - $row}]
	    return $rr
	}
	end {
	    return $r
	}
	{[0-9]+} {
	    return $row
	}
	default {
	    return -code error "bad row index \"$row\", syntax error"
	}
    }
    # Will not come to this place
}

# ::struct::matrix::MatTraceIn --
#
#	Helper propagating changes made to an array
#	into the matrix the array is linked to.
#
# Arguments:
#	avar		Name of the array which was changed.
#	name		Matrix to write the changes to.
#	var,idx,op	Standard trace arguments
#
# Results:
#	None.

proc ::struct::matrix::MatTraceIn {avar name var idx op} {
    # Propagate changes in the linked array back into the matrix.

    upvar ::struct::matrix::matrix${name}::lock lock
    if {$lock} {return}

    # We have to cover two possibilities when encountering an "unset" operation ...
    # 1. The external array was destroyed: perform automatic unlink.
    # 2. An individual element was unset:  Set the corresponding cell to the empty string.
    #    See SF Tcllib Bug #532791.

    if {(![string compare $op u]) && ($idx == {})} {
	# Possibility 1: Array was destroyed
	$name unlink $avar
	return
    }

    upvar #0 $avar                              array
    upvar ::struct::matrix::matrix${name}::data data
    upvar ::struct::matrix::matrix${name}::link link

    set transpose $link($avar)
    if {$transpose} {
	foreach {r c} [split $idx ,] break
    } else {
	foreach {c r} [split $idx ,] break
    }

    # Use standard method to propagate the change.
    # => Get automatically index checks, cache updates, ...

    if {![string compare $op u]} {
	# Unset possibility 2: Element was unset.
	# Note: Setting the cell to the empty string will
	# invoke MatTraceOut for this array and thus try
	# to recreate the destroyed element of the array.
	# We don't want this. But we do want to propagate
	# the change to other arrays, as "unset". To do
	# all of this we use another state variable to
	# signal this situation.

	upvar ::struct::matrix::matrix${name}::unset unset
	set unset $avar

	$name set cell $c $r ""

	set unset {}
	return
    }

    $name set cell $c $r $array($idx)
    return
}

# ::struct::matrix::MatTraceOut --
#
#	Helper propagating changes made to the matrix into the linked arrays.
#
# Arguments:
#	avar		Name of the array to write the changes to.
#	name		Matrix which was changed.
#	var,idx,op	Standard trace arguments
#
# Results:
#	None.

proc ::struct::matrix::MatTraceOut {avar name var idx op} {
    # Propagate changes in the matrix data array into the linked array.

    upvar ::struct::matrix::matrix${name}::unset unset

    if {![string compare $avar $unset]} {
	# Do not change the variable currently unsetting
	# one of its elements.
	return
    }

    upvar ::struct::matrix::matrix${name}::lock lock
    set lock 1 ; # Disable MatTraceIn [#532783]

    upvar #0 $avar                              array
    upvar ::struct::matrix::matrix${name}::data data
    upvar ::struct::matrix::matrix${name}::link link

    set transpose $link($avar)

    if {$transpose} {
	foreach {r c} [split $idx ,] break
    } else {
	foreach {c r} [split $idx ,] break
    }

    if {$unset != {}} {
	# We are currently propagating the unset of an
	# element in a different linked array to this
	# array. We make sure that this is an unset too.

	unset array($c,$r)
    } else {
	set array($c,$r) $data($idx)
    }
    set lock 0
    return
}



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/matrix.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] matrix.tcl]
namespace import struct::matrix::matrix

# Simple "report object" to test the format methods.

proc tclformat {cmd matrix {chan stdout}} {
    switch -exact -- $cmd {
	printmatrix {
	    set r [$matrix rows]
	    set c [$matrix rows]
	    set     out [list "# $matrix $c x $r"]
	    lappend out "matrix $matrix"
	    lappend out "$matrix add rows    $r"
	    lappend out "$matrix add columns $c"
	    lappend out "$matrix set rect 0 0 [list [$matrix get rect 0 0 end end]]"
	    return [join $out \n]
	}
	printmatrix2channel {
	    set r [$matrix rows]
	    set c [$matrix rows]
	    puts $chan "# $matrix $c x $r"
	    puts $chan "matrix $matrix"
	    puts $chan "$matrix add rows    $r"
	    puts $chan "$matrix add columns $c"
	    puts $chan "$matrix set rect 0 0 [list [$matrix get rect 0 0 end end]]"
	    return ""
	}
	default {
	    return -code error "Unknown method $cmd"
	}
    }
}

# Retrieve the contents of an array as a list, with sorted keys, to
# test the linking between matrices and array variables.

proc aget {avar} {
    upvar 1 $avar a
    set out [list]
    foreach key [lsort [array names a]] {
	lappend out $key $a($key)
    }
    return $out
}



test matrix-0.1 {matrix errors} {
    matrix mymatrix
    catch {matrix mymatrix} msg
    mymatrix destroy
    set msg
} "command \"mymatrix\" already exists, unable to create matrix"

test matrix-0.2 {matrix errors} {
    matrix mymatrix
    catch {mymatrix} msg
    mymatrix destroy
    set msg
} "wrong # args: should be \"mymatrix option ?arg arg ...?\""

test matrix-0.3 {matrix errors} {
    matrix mymatrix
    catch {mymatrix foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be add, cells, cellsize, columns, columnwidth, delete, destroy, format, get, insert, link, rowheight, rows, search, set, swap, or unlink"

test matrix-0.4 {matrix errors} {
    matrix mymatrix
    catch {mymatrix add foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be column, columns, row, or rows"

test matrix-0.5 {matrix errors} {
    matrix mymatrix
    catch {mymatrix delete foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be column, or row"

test matrix-0.6 {matrix errors} {
    matrix mymatrix
    catch {mymatrix get foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be cell, column, rect, or row"

test matrix-0.7 {matrix errors} {
    matrix mymatrix
    catch {mymatrix set foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be cell, column, rect, or row"

test matrix-0.8 {matrix errors} {
    matrix mymatrix
    catch {mymatrix format foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be 2chan, or 2string"

test matrix-0.9 {matrix errors} {
    matrix mymatrix
    catch {mymatrix swap foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be columns, or rows"

test matrix-0.10 {matrix errors} {
    catch {matrix set} msg
    set msg
} "command \"set\" already exists, unable to create matrix"

test matrix-0.11 {matrix errors} {
    matrix mymatrix
    catch {mymatrix set cell 0 0 foo} msg
    mymatrix destroy
    set msg
} {bad column index 0, column does not exist}

test matrix-0.12 {matrix errors} {
    matrix mymatrix
    mymatrix add column
    catch {mymatrix set cell 0 0 foo} msg
    mymatrix destroy
    set msg
} {bad row index 0, row does not exist}

test matrix-0.13 {matrix errors} {
    matrix mymatrix
    catch {mymatrix insert foo} msg
    mymatrix destroy
    set msg
} "bad option \"foo\": must be column, or row"

test matrix-1.0 {create} {
    set name [matrix]
    set result [list $name [string equal [info commands ::$name] "::$name"]]
    $name destroy
    set result
} [list matrix1 1]


test matrix-1.1 {columns, rows & cells} {
    matrix mymatrix
    set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]]
    mymatrix destroy
    set result
} {0 0 0}

test matrix-1.2 {columns, rows & cells} {
    matrix mymatrix
    mymatrix add column
    set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]]
    mymatrix destroy
    set result
} {0 1 0}

test matrix-1.3 {columns, rows & cells} {
    matrix mymatrix
    mymatrix add row
    set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]]
    mymatrix destroy
    set result
} {1 0 0}

test matrix-1.4 {columns, rows & cells} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row
    set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]]
    mymatrix destroy
    set result
} {1 1 1}

test matrix-1.5 {columns, rows & cells} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row
    mymatrix add column
    mymatrix add row
    set result [list [mymatrix rows] [mymatrix columns] [mymatrix cells]]
    mymatrix destroy
    set result
} {2 2 4}

test matrix-2.0 {add error} {
    matrix mymatrix
    catch {mymatrix add} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix add option ?arg arg ...?"}

test matrix-2.1 {add column, add row} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2} {3 4}}

test matrix-2.2 {add column, add row} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row
    mymatrix add column
    mymatrix add row
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{{} {}} {{} {}}}

test matrix-2.3 {add columns, add rows} {
    matrix mymatrix
    mymatrix add columns 4
    mymatrix add rows    4
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}}

test matrix-2.4 {add columns, add rows} {
    matrix mymatrix
    mymatrix add rows    4
    mymatrix add columns 4
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{{} {} {} {}} {{} {} {} {}} {{} {} {} {}} {{} {} {} {}}}

test matrix-2.5 {add columns, add rows} {
    matrix mymatrix
    catch {mymatrix add columns 0} result
    mymatrix destroy
    set result
} {A value of n <= 0 is not allowed}

test matrix-2.6 {add columns, add rows} {
    matrix mymatrix
    catch {mymatrix add rows 0} result
    mymatrix destroy
    set result
} {A value of n <= 0 is not allowed}

test matrix-2.7 {add column, add row, cut off} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2 5 6 7}
    mymatrix add row {3 4 8 9 10}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2} {3 4}}



test matrix-3.1 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    set result [list [mymatrix cellsize 0 0] [mymatrix columnwidth 1] [mymatrix rowheight 1]]
    mymatrix destroy
    set result
} {1 2 2}

test matrix-3.2 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix cellsize -1 -1} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-3.3 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix cellsize 5 -1} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-3.4 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix cellsize 0 -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-3.5 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix cellsize 0 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-3.6 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix rowheight -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-3.7 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix rowheight 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-3.8 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix columnwidth -1} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-3.9 {sizes, widths, heights} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {23}
    mymatrix add row [list "4\n5" 6]
    catch {mymatrix columnwidth 5} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-4.0 {delete error} {
    matrix mymatrix
    catch {mymatrix delete} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix delete option ?arg arg ...?"}

test matrix-4.1 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2a}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row [list 7 8 "9\na"]

    set     resa [list [mymatrix columnwidth 0]]
    lappend resa [mymatrix columnwidth 1]
    lappend resa [mymatrix columnwidth 2]

    set result [list [mymatrix get rect 0 0 end end]]
    mymatrix delete column 1
    lappend result [mymatrix get rect 0 0 end end]
    mymatrix delete row 1
    lappend result [mymatrix get rect 0 0 end end]

    lappend resa [mymatrix columnwidth 0]
    lappend resa [mymatrix columnwidth 1]

    mymatrix destroy
    lappend result $resa
    set result
} {{{1 2a 5} {3 4 6} {7 8 {9
a}}} {{1 5} {3 6} {7 {9
a}}} {{1 5} {7 {9
a}}} {1 2 1 1 1}}

test matrix-4.1a {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2a}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row [list 7 8 "9\na"]

    set     resb [list [mymatrix rowheight 0]]
    lappend resb [mymatrix rowheight 1]
    lappend resb [mymatrix rowheight 2]

    set result [list [mymatrix get rect 0 0 end end]]
    mymatrix delete row 1
    mymatrix delete column 1
    lappend result [mymatrix get rect 0 0 end end]

    lappend resb [mymatrix rowheight 0]
    lappend resb [mymatrix rowheight 1]

    mymatrix destroy
    lappend result $resb
    set result
} {{{1 2a 5} {3 4 6} {7 8 {9
a}}} {{1 5} {7 {9
a}}} {1 1 2 1 2}}

test matrix-4.2 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [list [mymatrix get rect 0 0 end end]]
    mymatrix delete column 0
    lappend result [mymatrix get rect 0 0 end end]
    mymatrix delete row 0
    lappend result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{{1 2 5} {3 4 6} {7 8 9}} {{2 5} {4 6} {8 9}} {{4 6} {8 9}}}

test matrix-4.3 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [list [mymatrix get rect 0 0 end end]]
    mymatrix delete column end
    lappend result [mymatrix get rect 0 0 end end]
    mymatrix delete row end
    lappend result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{{1 2 5} {3 4 6} {7 8 9}} {{1 2} {3 4} {7 8}} {{1 2} {3 4}}}

test matrix-4.4 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix delete column -1} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-4.5 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix delete column 5} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-4.6 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix delete row -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-4.7 {deletion of rows and columns} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix delete row 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-5.0 {format error} {
    matrix mymatrix
    catch {mymatrix format} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix format option ?arg arg ...?"}

test matrix-5.1 {formatting} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [mymatrix format 2string tclformat]
    mymatrix destroy
    set result
} "# mymatrix 3 x 3
matrix mymatrix
mymatrix add rows    3
mymatrix add columns 3
mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}"

test matrix-5.2 {internal format} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [mymatrix format 2string]
    mymatrix destroy
    set result
} "1 2 5\n3 4 6\n7 8 9"

test matrix-5.3 {internal format} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3a 4}
    mymatrix add column {5 6}
    mymatrix add row [list 7 8 "9\nb"]
    set result [mymatrix format 2string]
    mymatrix destroy
    set result
} "1  2 5\n3a 4 6\n7  8 9\n     b"

if {![catch {package require memchan}]} {
    # We have memory channels and can therefore test
    # 'format2channel-via' too.

    test matrix-5.4 {formatting} {
	matrix mymatrix
	mymatrix add column
	mymatrix add row {1}
	mymatrix add column {2}
	mymatrix add row {3 4}
	mymatrix add column {5 6}
	mymatrix add row {7 8 9}

	set chan [memchan]
	mymatrix format 2chan tclformat $chan
	mymatrix destroy

	seek $chan 0
	set result [read $chan]
	close $chan
	set result
    } "# mymatrix 3 x 3
matrix mymatrix
mymatrix add rows    3
mymatrix add columns 3
mymatrix set rect 0 0 {{1 2 5} {3 4 6} {7 8 9}}"
}

test matrix-6.0 {set/get error} {
    matrix mymatrix
    catch {mymatrix set} msga
    catch {mymatrix get} msgb
    mymatrix destroy
    list $msga $msgb
} {{wrong # args: should be "mymatrix set option ?arg arg ...?"} {wrong # args: should be "mymatrix get option ?arg arg ...?"}}

test matrix-6.1 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [mymatrix get cell 0 2]
    mymatrix destroy
    set result
} 7

test matrix-6.2 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [mymatrix get column 1]
    mymatrix destroy
    set result
} {2 4 8}

test matrix-6.3 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [mymatrix get row 2]
    mymatrix destroy
    set result
} {7 8 9}

test matrix-6.4 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    set result [mymatrix get rect 1 1 end end]
    mymatrix destroy
    set result
} {{4 6} {8 9}}

test matrix-6.5 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set cell 0 2 foo
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 4 6} {foo 8 9}}

test matrix-6.6 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set column 1 {a b c}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 a 5} {3 b 6} {7 c 9}}

test matrix-6.7 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set row 2 {bar buz nex}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 4 6} {bar buz nex}}

test matrix-6.8 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set rect 1 1 {{c d} {e f}}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 c d} {7 e f}}

test matrix-6.9 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set column 1 {a b}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 a 5} {3 b 6} {7 {} 9}}

test matrix-6.10 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set column 1 {a b c d e f}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 a 5} {3 b 6} {7 c 9}}

test matrix-6.11 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set row 2 {bar buz}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 4 6} {bar buz {}}}

test matrix-6.12 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set row 2 {bar buz nex floz}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 4 6} {bar buz nex}}

test matrix-6.13 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set rect 1 1 {{c d e} {f g h} {i j k}}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 c d} {7 f g}}

test matrix-6.14 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix set rect -1 -1 {{c d e} {f g h} {i j k}}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{g h 5} {j k 6} {7 8 9}}

test matrix-6.15 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get cell -1 2} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-6.16 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get cell 5 2} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-6.17 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get cell 0 -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-6.18 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get cell 0 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-6.19 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get column -1} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-6.20 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get column 5} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-6.21 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get row -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-6.22 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get row 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-6.23 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect -1 1 end end} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-6.24 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 5 1 end end} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-6.25 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 1 1 -1 end} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-6.26 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 1 1 5 end} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-6.27 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 1 -1 end end} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-6.28 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 1 5 end end} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-6.29 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 1 1 end -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-6.30 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect 1 1 end 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-6.31 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix set column -1 {a b c}} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-6.32 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix set column 5 {a b c}} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-6.33 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix set row -1 {a b c}} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-6.34 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix set row 5 {a b c}} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-6.35 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix set rect 5 1 {{a b} {c d}}} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-6.36 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix set rect 1 5 {{a b} {c d}}} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}


test matrix-6.43 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix get rect end end 1 1} result
    mymatrix destroy
    set result
} {Invalid cell indices, wrong ordering}

test matrix-6.44 {set and get in all forms} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix set cell 0 0 foo
    set result [list [mymatrix get rect 0 0 end end]]
    mymatrix set cell 0 0 foo
    lappend result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {foo foo}




test matrix-7.0 {swap error} {
    matrix mymatrix
    catch {mymatrix swap} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix swap option ?arg arg ...?"}

test matrix-7.1 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix swap columns 1 end
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 5 2} {3 6 4} {7 9 8}}

test matrix-7.2 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix swap rows 1 end
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {7 8 9} {3 4 6}}

test matrix-7.3 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap columns -1 end} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-7.4 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap columns 5 end} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-7.5 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap columns 1 -1} result
    mymatrix destroy
    set result
} {bad column index -1, column does not exist}

test matrix-7.6 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap columns 1 5} result
    mymatrix destroy
    set result
} {bad column index 5, column does not exist}

test matrix-7.7 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap rows -1 end} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-7.8 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap rows 5 end} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-7.9 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap rows 1 -1} result
    mymatrix destroy
    set result
} {bad row index -1, row does not exist}

test matrix-7.10 {swapping} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    catch {mymatrix swap rows 1 5} result
    mymatrix destroy
    set result
} {bad row index 5, row does not exist}

test matrix-8.0 {insert error} {
    matrix mymatrix
    catch {mymatrix insert} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix insert option ?arg arg ...?"}

test matrix-8.1 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert column 0 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{a 1 2 5} {b 3 4 6} {c 7 8 9}}

test matrix-8.2 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert column 1 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 a 2 5} {3 b 4 6} {7 c 8 9}}

test matrix-8.3 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert column end {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5 a} {3 4 6 b} {7 8 9 c}}

test matrix-8.4 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert column 3 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5 a} {3 4 6 b} {7 8 9 c}}

test matrix-8.5 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert column -1 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{a 1 2 5} {b 3 4 6} {c 7 8 9}}


test matrix-8.6 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert row 0 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{a b c} {1 2 5} {3 4 6} {7 8 9}}

test matrix-8.7 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert row 1 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {a b c} {3 4 6} {7 8 9}}

test matrix-8.8 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert row end {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 4 6} {7 8 9} {a b c}}

test matrix-8.9 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert row 3 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {3 4 6} {7 8 9} {a b c}}

test matrix-8.10 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}

    mymatrix insert row -1 {a b c}

    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{a b c} {1 2 5} {3 4 6} {7 8 9}}

test matrix-8.11 {insertion} {
    matrix mymatrix
    mymatrix add column
    mymatrix insert row 1 {1}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {1}

test matrix-8.12 {insertion} {
    matrix mymatrix
    mymatrix add row
    mymatrix insert column 1 {1}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {1}

test matrix-9.0 {link errors} {
    matrix mymatrix
    catch {mymatrix link} msg
    mymatrix destroy
    set msg
} {mymatrix: wrong # args: link ?-transpose? arrayvariable}

test matrix-9.1 {link errors} {
    matrix mymatrix
    catch {mymatrix link 1 2 3} msg
    mymatrix destroy
    set msg
} {mymatrix: wrong # args: link ?-transpose? arrayvariable}

test matrix-9.2 {link errors} {
    matrix mymatrix
    catch {mymatrix link foo 2} msg
    mymatrix destroy
    set msg
} {mymatrix: illegal syntax: link ?-transpose? arrayvariable}

test matrix-9.3 {link errors} {
    matrix mymatrix
    mymatrix link foo
    catch {mymatrix link foo} msg
    mymatrix destroy
    set msg
} {mymatrix link: Variable "foo" already linked to matrix}

test matrix-9.4 {linking, initial transfer} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link a
    set result [aget a]
    mymatrix destroy
    set result
} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9}

test matrix-9.5 {linking, initial transfer} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link -transpose a
    set result [aget a]
    mymatrix destroy
    set result
} {0,0 1 0,1 2 0,2 5 1,0 3 1,1 4 1,2 6 2,0 7 2,1 8 2,2 9}


test matrix-9.6 {linking, trace array -> matrix} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link a
    set a(1,0) foo
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 foo 5} {3 4 6} {7 8 9}}

test matrix-9.7 {linking, trace array -> matrix} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link -transpose a
    set a(1,0) foo
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 5} {foo 4 6} {7 8 9}}

test matrix-9.8 {linking, trace and unlink} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link a
    set a(1,0) foo
    set result [list [mymatrix get rect 0 0 end end]]
    mymatrix unlink a
    set a(1,0) 2
    lappend result [aget a]
    mymatrix destroy
    set result
} {{{1 foo 5} {3 4 6} {7 8 9}} {0,0 1 0,1 3 0,2 7 1,0 2 1,1 4 1,2 8 2,0 5 2,1 6 2,2 9}}

test matrix-9.9 {linking} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link a
    catch {set a(1,5) foo} result
    mymatrix destroy
    set result
} {can't set "a(1,5)": bad row index 5, row does not exist}

test matrix-9.10 {unlink unknown} {
    matrix mymatrix
    set result [list [mymatrix links]]
    mymatrix unlink foo
    lappend result [mymatrix links]
    mymatrix destroy
    set result
} {{} {}}

test matrix-9.11 {auto unlink} {
    matrix mymatrix
    mymatrix add column
    mymatrix add row {1}
    mymatrix add column {2}
    mymatrix add row {3 4}
    mymatrix add column {5 6}
    mymatrix add row {7 8 9}
    mymatrix link a
    set result [list [mymatrix links]]
    unset a
    lappend result [mymatrix links]
    mymatrix destroy
    set result
} {a {}}

test matrix-9.12 {unset in linked array} {
    matrix mymatrix
    mymatrix add columns 3
    mymatrix add row {1 2 3}
    mymatrix add row {a b c}

    catch {unset a}
    mymatrix link a

    set     result [list]
    lappend result [aget a]
    unset a(0,0)
    lappend result [mymatrix get rect 0 0 end end]

    mymatrix destroy
    set result
} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {{{} 2 3} {a b c}}}

test matrix-9.12a {unset in linked array} {
    matrix mymatrix
    mymatrix add columns 3
    mymatrix add row {1 2 3}
    mymatrix add row {a b c}

    catch {unset a}
    mymatrix link a
    catch {unset b}
    mymatrix link b

    set     result [list]
    lappend result [aget a]
    unset a(0,0)
    lappend result [aget b]

    mymatrix destroy
    set result
} {{0,0 1 0,1 a 1,0 2 1,1 b 2,0 3 2,1 c} {0,1 a 1,0 2 1,1 b 2,0 3 2,1 c}}

test matrix-9.13 {operation on linked matrix} {
    catch {unset a}
    matrix mymatrix
    mymatrix add columns 4
    mymatrix add row {1 2 3}
    mymatrix link a
    mymatrix add row {a b c d}
    set result [mymatrix get rect 0 0 end end]
    mymatrix destroy
    set result
} {{1 2 3 {}} {a b c d}}

test 10.1 {search errors} {
    matrix mymatrix
    catch {mymatrix search} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"}

test 10.2 {search errors} {
    matrix mymatrix
    catch {mymatrix search 1} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"}

test 10.3 {search errors} {
    matrix mymatrix
    catch {mymatrix search 1 2 3 4 5} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"}

test 10.4 {search errors} {
    matrix mymatrix
    catch {mymatrix search 1 2 3 4 5 6 7 8} msg
    mymatrix destroy
    set msg
} {wrong # args: should be "mymatrix search ?option...? (all|row row|column col|rect c r c r) pattern"}

test 10.5 {search errors} {
    matrix mymatrix
    catch {mymatrix search -foo 2 3 4} msg
    mymatrix destroy
    set msg
} {invalid option "-foo": should be -nocase, -exact, -glob, or -regexp}

test 10.6 {search errors} {
    matrix mymatrix
    catch {mymatrix search -exact foo 3 4} msg
    mymatrix destroy
    set msg
} {invalid range spec "foo": should be all, column, row, or rect}

test 10.7 {search errors} {
    matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {1  2  3 4 5}
    mymatrix add row {6  7  8 9 0}
    mymatrix add row {a  b  c d e}
    mymatrix add row {ab ba f g h}
    mymatrix add row {cd 4d x y z}
    catch {mymatrix search -exact rect 4 0 2 1 foo} msg
    mymatrix destroy
    set msg
} {Invalid cell indices, wrong ordering}

test 10.8 {search errors} {
    matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {1  2  3 4 5}
    mymatrix add row {6  7  8 9 0}
    mymatrix add row {a  b  c d e}
    mymatrix add row {ab ba f g h}
    mymatrix add row {cd 4d x y z}
    catch {mymatrix search -exact rect 2 1 4 0 foo} msg
    mymatrix destroy
    set msg
} {Invalid cell indices, wrong ordering}


test matrix-10.9 "searching, default" {
    matrix mymatrix
    mymatrix add columns 5
    mymatrix add row {1  2  3 4 5}
    mymatrix add row {6  7  8 9 0}
    mymatrix add row {a  b  c d e}
    mymatrix add row {ab ba f g h}
    mymatrix add row {cd 4d x y z}
    set result [mymatrix search row 2 b]
    mymatrix destroy
    set result
} {{1 2}}

foreach {n mode range pattern result} {
    10 -exact  {all}          {ab}  {{0 3}}
    11 -glob   {all}          {a*}  {{0 2} {0 3}}
    12 -regexp {all}          {b.}  {{1 3}}
    13 -exact  {row    2}     {b}   {{1 2}}
    14 -glob   {row    3}     {b*}  {{1 3}}
    15 -regexp {row    4}     {d}   {{0 4} {1 4}}
    16 -exact  {column 2}     {c}   {{2 2}}
    17 -glob   {column 0}     {a*}  {{0 2} {0 3}}
    18 -regexp {column 1}     {b.*} {{1 2} {1 3}}
    19 -exact  {rect 1 1 3 3} {c}   {{2 2}}
    20 -glob   {rect 1 1 3 3} {b*}  {{1 2} {1 3}}
    21 -regexp {rect 1 1 3 3} {b.*} {{1 2} {1 3}}
} {
    test matrix-10.$n "searching ($mode $range $pattern)" {
	matrix mymatrix
	mymatrix add columns 5
	mymatrix add row {1  2  3 4 5}
	mymatrix add row {6  7  8 9 0}
	mymatrix add row {a  b  c d e}
	mymatrix add row {ab ba f g h}
	mymatrix add row {cd 4d x y z}
	set result [eval mymatrix search $mode $range $pattern]
	mymatrix destroy
	set result
    } $result ; # {}
}


# Future tests: query rowheight, column width before and after delete
# row/column to ascertain that the cached values are correctly
# shifted.

# Test 'format 2chan', have to redirect a channel for this.

# Future: Tests involving cached information (row heights, col widths)
# should use special commands to peek at the cache only, without
# recalculation.

# Document 'links' method.

::tcltest::cleanupTests

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
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 struct 1.3 [list source [file join $dir struct.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted modules/struct/pool.html.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html xmlns:o="urn:schemas-microsoft-com:office:office"
xmlns:w="urn:schemas-microsoft-com:office:word"
xmlns="http://www.w3.org/TR/REC-html40">

<head>
<meta http-equiv=Content-Type content="text/html; charset=windows-1252">
<meta name=ProgId content=Word.Document>
<meta name=Generator content="Microsoft Word 9">
<meta name=Originator content="Microsoft Word 9">
<link rel=File-List href="./pool_bestanden/filelist.xml">
<!--[if gte mso 9]><xml>
 <o:DocumentProperties>
  <o:LastAuthor>Erik</o:LastAuthor>
  <o:Revision>97</o:Revision>
  <o:TotalTime>516</o:TotalTime>
  <o:LastPrinted>2002-05-15T11:24:00Z</o:LastPrinted>
  <o:Created>2002-04-16T19:32:00Z</o:Created>
  <o:LastSaved>2002-05-15T11:27:00Z</o:LastSaved>
  <o:Pages>6</o:Pages>
  <o:Words>1767</o:Words>
  <o:Characters>10077</o:Characters>
  <o:Company>None</o:Company>
  <o:Lines>83</o:Lines>
  <o:Paragraphs>20</o:Paragraphs>
  <o:CharactersWithSpaces>12375</o:CharactersWithSpaces>
  <o:Version>9.2812</o:Version>
 </o:DocumentProperties>
</xml><![endif]--><!--[if gte mso 9]><xml>
 <w:WordDocument>
  <w:View>Normal</w:View>
  <w:HyphenationZone>21</w:HyphenationZone>
 </w:WordDocument>
</xml><![endif]-->
<style>
<!--
 /* Font Definitions */
@font-face
	{font-family:Tahoma;
	panose-1:2 11 6 4 3 5 4 4 2 4;
	mso-font-charset:0;
	mso-generic-font-family:swiss;
	mso-font-pitch:variable;
	mso-font-signature:553679495 -2147483648 8 0 66047 0;}
 /* Style Definitions */
p.MsoNormal, li.MsoNormal, div.MsoNormal
	{mso-style-parent:"";
	margin:0in;
	margin-bottom:.0001pt;
	mso-pagination:widow-orphan;
	font-size:12.0pt;
	font-family:"Times New Roman";
	mso-fareast-font-family:"Times New Roman";}
p.MsoDocumentMap, li.MsoDocumentMap, div.MsoDocumentMap
	{margin:0in;
	margin-bottom:.0001pt;
	mso-pagination:widow-orphan;
	background:navy;
	font-size:12.0pt;
	font-family:Tahoma;
	mso-fareast-font-family:"Times New Roman";}
p.MsoPlainText, li.MsoPlainText, div.MsoPlainText
	{margin:0in;
	margin-bottom:.0001pt;
	mso-pagination:widow-orphan;
	font-size:10.0pt;
	font-family:"Courier New";
	mso-fareast-font-family:"Times New Roman";}
@page Section1
	{size:8.5in 11.0in;
	margin:.8in .8in .7in .7in;
	mso-header-margin:.2in;
	mso-footer-margin:.2in;
	mso-paper-source:0;}
div.Section1
	{page:Section1;}
 /* List Definitions */
@list l0
	{mso-list-id:491943773;
	mso-list-type:hybrid;
	mso-list-template-ids:389161538 700215070 68354051 68354053 68354049 68354051 68354053 68354049 68354051 68354053;}
@list l0:level1
	{mso-level-start-at:2;
	mso-level-number-format:bullet;
	mso-level-text:-;
	mso-level-tab-stop:53.4pt;
	mso-level-number-position:left;
	margin-left:53.4pt;
	text-indent:-.25in;
	font-family:"Times New Roman";
	mso-fareast-font-family:"Times New Roman";}
@list l1
	{mso-list-id:2044330862;
	mso-list-type:hybrid;
	mso-list-template-ids:1794557052 1241923622 68354073 68354075 68354063 68354073 68354075 68354063 68354073 68354075;}
@list l1:level1
	{mso-level-tab-stop:106.15pt;
	mso-level-number-position:left;
	margin-left:106.15pt;
	text-indent:-35.35pt;}
ol
	{margin-bottom:0in;}
ul
	{margin-bottom:0in;}
-->
</style>
<meta name=CVS content="$Id: pool.html,v 1.1 2002/05/28 06:29:31 andreas_kupries Exp $">
<meta name=CVS content="$Id: pool.html,v 1.1 2002/05/28 06:29:31 andreas_kupries Exp $">
<meta name=CVS content="\$Id: pool.html,v 1.1 2002/05/28 06:29:31 andreas_kupries Exp $">
</head>

<body lang=NL style='tab-interval:35.4pt'>

<div class=Section1>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText align=center style='text-align:center;mso-outline-level:
1'><b><span style='font-size:16.0pt;font-family:"Times New Roman"'>POOL 0.1<o:p></o:p></span></b></p>

<p class=MsoPlainText align=center style='text-align:center'><span
style='font-size:11.0pt;font-family:"Times New Roman"'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText align=center style='text-align:center;mso-outline-level:
1'><span style='font-size:11.0pt;font-family:"Times New Roman"'>Author: Erik
Leunissen<o:p></o:p></span></p>

<p class=MsoPlainText><span style='font-size:11.0pt;font-family:"Times New Roman"'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span style='font-size:11.0pt;font-family:"Times New Roman"'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>NAME<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>pool
� Managing a pool of discrete items.<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>SYNOPSIS<o:p></o:p></span></b></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><span style='mso-tab-count:1'>������������� </span><b>pool
</b><i>?poolName? ?maxsize?</i><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>DESCRIPTION</span></b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:11.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
<i>pool</i> command creates a new instance of a pool data structure. The command
takes the name of the new pool as its first argument. If no name is supplied,
then the new pool will be named pool&lt;X&gt;, where X is a positive integer.
The optional second argument <i>maxsize</i> is a positive integer indicating
the maximum size of the pool; this is the maximum number of items the pool may
hold.</span><span lang=EN-GB style='mso-ansi-language:EN-GB'><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>POOLS AND ALLOCATION<o:p></o:p></span></b></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size:
11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
purpose of the <i>pool</i> command and the pool object command that it
generates, is to manage pools of discrete items.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Examples
of a pool of discrete items are:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list:
l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'>the seats in a cinema, theatre,
train etc.. for which visitors/travellers can<span style="mso-spacerun: yes">�
</span>make a reservation;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list:
l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'>the dynamic IP-addresses that an ISP
can dole out<span style="mso-spacerun: yes">� </span>to subscribers;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list:
l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'>a car rental's collection of cars,
which can be rented by customers;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list:
l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'>the class rooms in a school
building, which need to be scheduled;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list:
l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'>the database connections available
to client-threads in a web-server application;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in;mso-list:
l0 level1 lfo2;tab-stops:list 53.4pt'><![if !supportLists]><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;
</span></span><![endif]><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'>the books in a library that
customers can borrow;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:53.4pt;text-indent:-.25in'><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>etc ...<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
common denominator in the examples is that there is a more or less fixed number
of items (seats, IP-addresses, cars, ...) that are supposed to be allocated on
a more or less regular basis. An item can be allocated only once at a time. An
item that is allocated, must be released before it can be re-allocated. While
several items in a pool are being allocated and released continuously, the
total number of items in the pool remains constant.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Keeping
track of which items are allocated, and by whom, is the purpose of the <i>pool</i>
command and its subordinates.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Pool parlance<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If
we say that an item is allocated, it means that the item is <i>busy</i>, <i>owned</i>
or <i>occupied</i>; it is not available anymore. If an item is free, it is
available. <i>Deallocating</i> an item is equivalent to <i>setting free</i> or <i>releasing</i>
an item. The person or entity to which the item has been allotted is said to <i>own</i>
the item.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><b><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size:
11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>ITEMS<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Discrete items<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
<i>pool</i> command is designed for <b>discrete items only</b>. Note that there
are pools where allocation occurs on a non-discrete basis, for example computer
memory. There are also pools from which the shares that are doled out are not
expected to be returned, for example a charity fund or a pan of soup from which
you may receive a portion. Finally, there are even pools from which nothing is
ever allocated or returned, like a swimming pool or a cesspool.<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Unique item names<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>A pool cannot manage duplicate item names. Therefore, items in a pool
must have unique names.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><b><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span
style="mso-spacerun: yes">�</span><o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Item equivalence<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>From
the point of view of the manager of a pool, items are equivalent. The manager
of a pool is indifferent about which entity/person occupies a given item.
However, clients may have preferences for a particular item, based on some item
property they know.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Preferences<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>A
future owner may have a preference for a particular item. Preference based
allocation is supported (see the <b>�prefer</b> option to the <i>request</i>
subcommand). A preference for a particular item is most likely to result from
variability among features associated with the items. Note that the pool
commands themselves are not designed to manage such item properties. If item
properties play a role in an application, they should be<span
style="mso-spacerun: yes">� </span>managed separately. <o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>POOL OBJECT COMMAND<o:p></o:p></span></b></p>

<p class=MsoPlainText><b><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size:
14.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
<i>pool</i> command creates a new Tcl command whose name is <i>poolName</i> .
This pool object command is used to manipulate or query the pool object. The
general syntax of a pool object command is:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span
style='mso-tab-count:1'>������������� </span><i>poolName</i> <b>subcommand</b> <i>?arg
arg �?</i><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
following subcommands and corresponding arguments are available:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>add</b> <i>itemName1 ?itemName2 itemName3 ...?</i><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This
command adds the items on the command line to the pool. If duplicate item names
occur on the command line, an error is raised. If one or more of the items
already exist in the pool, this also is considered an error.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span
style='mso-tab-count:1'>������������� </span><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>clear</b> <i>?-force?</i><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Removes
all items from the pool. If there are any allocated items at the time when the
command is invoked, an error is raised. This behaviour may be modified through
the <i>-force</i> argument. If it is supplied on the command line, the pool
will be cleared regardless the allocation state of its items.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>destroy</b> <i>?-force?<o:p></o:p></i></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Destroys
the pool data structure, all associated variables and the associated pool
object command. By default, the command checks whether any items are still
allocated and raises an error if such is the case. This behaviour may be
modified through the argument -<i>force</i>. If it is supplied on the command
line, the pool data structure will be destroyed regardless allocation state of
its items. <o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<span lang=EN-GB style='font-size:10.0pt;font-family:"Courier New";mso-fareast-font-family:
"Times New Roman";mso-ansi-language:EN-GB;mso-fareast-language:NL;mso-bidi-language:
AR-SA'><br clear=all style='page-break-before:always'>
</span>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>info</b> <i>type ?arg?<o:p></o:p></i></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:.5in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Returns
various information about the pool for further programmatic use. The type
argument indicates the type of information requested. Only the <i>allocID</i>
type uses an additional argument.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:.5in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>allocID </span></b><i><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>itemName<o:p></o:p></span></i></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>returns the allocID of the item whose name is <i>itemName.</i>
Free items have an allocation ID -1.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>allitems<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><span style='mso-tab-count:1'>������������ </span></span></b><span
lang=EN-GB style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>returns a list of all items in the pool.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>allocstate<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>Returns a list of key-value pairs, where the keys are
the items and the values &nbsp;are the corresponding&nbsp;allocation ID's. Free
items have an allocation ID -1.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>cursize<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>returns &nbsp;the current pool size, i.e. the
&nbsp;number of items in the pool.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>freeitems</span></b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.5in;margin-bottom:
0in;margin-left:107.4pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>returns
a list of items that currently are not allocated.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:71.4pt;margin-bottom:.0001pt'><b><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>maxsize<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>returns &nbsp;the maximum size of the pool.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:1.0in;margin-bottom:
0in;margin-left:105.6pt;margin-bottom:.0001pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>maxsize</b> <i>?maxsize?<o:p></o:p></i></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>Sets or queries the maximum size of the pool,
depending on whether the <i>maxsize</i> argument is supplied. If the optional
argument <i>maxsize</i> is supplied, the maximum size of the pool will<span
style="mso-spacerun: yes">� </span>be set to that value. If no argument <i>maxsize</i>
is supplied, the current maximum size of the pool is returned. In this variant,
the command is an alias for: </span><span lang=EN-GB style='font-size:10.5pt;
mso-bidi-font-size:10.0pt;mso-ansi-language:EN-GB'>poolName info maxsize</span><span
lang=EN-GB style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>The <i>maxsize</i> argument needs to be a positive
integer.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><span style="mso-spacerun: yes">�</span><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>release</b> <i>itemName<o:p></o:p></i></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>Releases the item whose name is <i>itemName</i> that
was allocated previously. An error is raised if the item was not allocated at
the time when the command was issued.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;mso-bidi-font-size:10.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'><span style="mso-spacerun: yes">�</span><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>remove</b> <i>itemName ?-force?</i><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Removes
the item whose name is <i>itemName</i><span style="mso-spacerun: yes">�
</span>from the pool. If the item was allocated at the time when the command
was invoked, an error is raised. This behaviour may be modified through the
optional argument <i>-force</i>. If it is supplied on the command line, the
item will be removed regardless its allocation state.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<span lang=EN-GB style='font-size:10.0pt;font-family:"Courier New";mso-fareast-font-family:
"Times New Roman";mso-ansi-language:EN-GB;mso-fareast-language:NL;mso-bidi-language:
AR-SA'><br clear=all style='page-break-before:always'>
</span>

<p class=MsoPlainText style='margin-left:35.4pt'><i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>poolName</span></i><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <b>request</b> <i>itemVar ?options?</i><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Handles
a request for an item, taking into account a possible preference for a
particular item.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>There
are two possible outcomes depending on the availability of items:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:1.25in;text-indent:-19.2pt;mso-list:
l1 level1 lfo4'><![if !supportLists]><span lang=EN-GB style='font-size:11.0pt;
font-family:"Times New Roman";mso-ansi-language:EN-GB'>1.<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; </span></span><![endif]><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>The request is honoured, an item is allocated and the variable whose
name is passed with the argument <i>itemVar</i> will be set to the name of the
item that was allocated. The command returns 1.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:1.25in;text-indent:-19.2pt;mso-list:
l1 level1 lfo4'><![if !supportLists]><span lang=EN-GB style='font-size:11.0pt;
font-family:"Times New Roman";mso-ansi-language:EN-GB'>2.<span
style='font:7.0pt "Times New Roman"'>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; </span></span><![endif]><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>The request is denied. No item is allocated. The variable whose name is <i>itemVar</i>
is not set. Attempts to read <i>itemVar</i><span style="mso-spacerun: yes">�
</span>may raise an error if the variable was not defined before issuing the
request. The command returns 0.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
return values from this command are meant to be inspected. The examples below
show how to do this. Failure to check the return value may result in erroneous
behaviour.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If
no preference for a particular item is supplied through the option <b>�prefer</b>
(see below), then all requests are honoured as long as items are available.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>The
following options are supported:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><b><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-allocID</span></b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'> <i>allocID</i><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If
the request is honoured, an item will be allocated to the entity identified by <i>allocID</i>.
If the allocation state of an item is queried, it is this allocation ID that
will be returned. If the option <b>�allocID</b> is not supplied, the item will
be allocated to<span style="mso-spacerun: yes">� </span><i>dummyID</i>.
Allocation ID�s may be anything except the value -1, which is reserved for free
items.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:70.8pt'><b><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>-prefer
</span></b><i><span lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>preferredItem</span></i><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This
option modifies the allocation strategy as follows:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>If
the item whose name is <i>preferredItem</i> is not allocated at the time when
the command is invoked, the request is honoured (return value is 1). If the item
was allocated at the time when the command was invoked, the request is denied
(return value is 0).<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:106.2pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><b><span lang=EN-GB
style='font-size:12.0pt;mso-bidi-font-size:14.0pt;font-family:"Times New Roman";
mso-ansi-language:EN-GB'>EXAMPLES<o:p></o:p></span></b></p>

<p class=MsoPlainText><b><span lang=EN-GB style='font-size:12.0pt;mso-bidi-font-size:
14.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Two
examples are provided. The first one mimics a step by step interactive tclsh session,
where each step is explained. The second example shows the usage in a server
application that talks to a back-end application.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Example 1<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This
example presents an interactive tclsh session which considers the case of a Car
rental's collection of cars. Ten steps explain its usage in chronological
order, from the creation of the pool, via the most important stages in the
usage of a pool, to the final destruction.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:63.0pt;margin-bottom:
0in;margin-left:81.0pt;margin-bottom:.0001pt'><span lang=EN-GB
style='mso-bidi-font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Note aside:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-top:0in;margin-right:63.0pt;margin-bottom:
0in;margin-left:81.0pt;margin-bottom:.0001pt'><span lang=EN-GB
style='mso-bidi-font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>In this example, brand names are used to label the various items.
However, a brand name could be regarded as a property of an item. Because the <i>pool</i>
command is not designed to manage properties of items, they need to be managed
separately. In the latter case the items should be labelled with more neutral
names such as: car1, car2, car3 , etc ... and a separate database or array
should hold the brand names associated with the car labels.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>1.
Load the package into an interpreter<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
package require pool<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:blue;mso-ansi-language:
EN-GB'>0.1<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>2.
Create a pool object called `CarPool' with a maximum size of 55 items (cars):<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
pool CarPool 55<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:blue;mso-ansi-language:
EN-GB'>CarPool<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>4.
Add items to the pool:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
CarPool add Toyota Trabant Chrysler1 Chrysler2 Volkswagen<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><span
style='mso-tab-count:1'>������������� </span><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>5.
Somebody crashed the Toyota? Remove it from the pool as follows:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
CarPool remove Toyota<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>6.
Acquired a new car for the pool? Add it as follows:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
CarPool add Nissan<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>7.
Check whether the pool was adjusted correctly:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'>% CarPool info allitems<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:blue;mso-ansi-language:
EN-GB'>Trabant Chrysler1 Chrysler2 Volkswagen Nissan<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Suspend
interactive session temporarily, and show the programmatic use of the <b>request</b>
subcommand:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>#
Mrs. Swift needs a car. She doesn't have a preference for a<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>#
particular car. We'll issue a request on her behalf as follows:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>if {
[CarPool request car -allocID &quot;Mrs. Swift&quot;] }<span
style="mso-spacerun: yes">� </span>{<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt;mso-outline-level:
1'><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;
mso-ansi-language:EN-GB'># request was honoured, process the variable `car�<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'>puts &quot;$car has been allocated to [CarPool info allocID $car].&quot;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'>} else {<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'># request was denied<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style='mso-tab-count:1'>���� </span>puts &quot;No car available.&quot;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>(note how the <b>if</b> command uses the value returned by the request
subcommand.)<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>#
Suppose mr. Wiggly has a preference for the Trabant:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>if {
[CarPool request car -allocID &quot;Mr. Wiggly&quot; �prefer Trabant] }<span
style="mso-spacerun: yes">� </span>{<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt;mso-outline-level:
1'><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;
mso-ansi-language:EN-GB'># request was honoured, process the variable `car�<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'>puts &quot;$car has been allocated to [CarPool info allocID $car].&quot;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'>} else {<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;text-indent:35.4pt'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'># request was denied<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style='mso-tab-count:1'>���� </span>puts &quot;The Trabant was not
available.&quot;<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Resume
interactive session:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>8.
When the car is returned then you can render it available by:<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
CarPool release Trabant<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>9.
When done, you delete the pool.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'>% CarPool destroy<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;color:#FF6600;mso-ansi-language:
EN-GB'>Couldn't destroy `CarPool' because some items are still allocated.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>Oops,
� forgot that Mrs. Swift still occupies a car.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>10.
We force the destruction of the pool as follows: <o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>%
CarPool destroy -force<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><b><span
lang=EN-GB style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:
EN-GB'>Example 2<o:p></o:p></span></b></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>This
example describes the case from which the author�s need for pool management
originated. It is an example of a server application that receives requests
from client applications. The client requests are dispatched onto a back-end
application before being returned to the client application. In many cases
there are a few equivalent instances of back-end applications to which a client
request may be passed along. The file descriptors that identify the channels to
these back-end instances make up a pool of connections. A particular connection
may be allocated to just one client request at a time.<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># Create
the pool of connections (pipes)<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>set
maxpipes 10<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>pool
Pipes $maxpipes<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>for
{set i 0} {$i &lt; $maxpipes} {incr i} {<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:
11.0pt;mso-ansi-language:EN-GB'><span style='mso-tab-count:1'>���� </span><span
style="mso-spacerun: yes">��� </span>set fd {open �|backendApplication� w+}<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:
11.0pt;mso-ansi-language:EN-GB'><span style='mso-tab-count:1'>���� </span><span
style="mso-spacerun: yes">��� </span>Pipes add $fd<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:
11.0pt;mso-ansi-language:EN-GB'><span style='mso-tab-count:1'>���� </span>}<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'># A
client request comes in. The request is identified as `clientX�.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'># Dispatch it onto an instance of a back-end application<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>if {
[Pipes request fd �allocID clientX] } {<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'><span style="mso-spacerun: yes">��� </span># a connection was allocated<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style="mso-spacerun: yes">��� </span># communicate to the back-end application
via the variable `fd�<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style="mso-spacerun: yes">��� </span>puts $fd �someInstruction�<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style="mso-spacerun: yes">��� </span># ...... etc.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}
else {<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt;mso-outline-level:1'><span
lang=EN-GB style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:
EN-GB'><span style="mso-spacerun: yes">��� </span># all connections are
currently occupied<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style="mso-spacerun: yes">��� </span># store the client request in a queue for
later processing,<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'><span
style="mso-spacerun: yes">��� </span># or return a �Server busy� message to the
client.<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:10.5pt;mso-bidi-font-size:11.0pt;mso-ansi-language:EN-GB'>}<o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='margin-left:35.4pt'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

<p class=MsoPlainText style='mso-outline-level:1'><span lang=EN-GB
style='font-size:11.0pt;font-family:"Times New Roman";mso-ansi-language:EN-GB'>#
</span><span lang=EN-GB style='font-family:"Times New Roman";mso-ansi-language:
EN-GB'>CVS: $Id: pool.html,v 1.1 2002/05/28 06:29:31 andreas_kupries Exp $<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'># EOF pool.html<o:p></o:p></span></p>

<p class=MsoPlainText><span lang=EN-GB style='font-size:11.0pt;font-family:
"Times New Roman";mso-ansi-language:EN-GB'><![if !supportEmptyParas]>&nbsp;<![endif]><o:p></o:p></span></p>

</div>

</body>

</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/pool.man.

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

This package provides pool objects which can be used to manage
finite collections of discrete items.

[list_begin definitions]

[call [cmd ::struct::pool] [opt [arg poolName]] [opt [arg maxsize]]]

Creates a new pool object. If no [arg poolName] is supplied, then the
new pool will be named pool[var X], where X is a positive integer.
The optional second argument [arg maxsize] has to be a positive
integer indicating the maximum size of the pool; this is the maximum
number of items the pool may hold. The default for this value is
[const 10].
     
[nl]

The pool object has an associated global Tcl command whose name is
[arg poolName]. This command may be used to invoke various
configuration operations on the report. It has the following general
form:

[list_begin definitions]
[call [cmd poolName] [arg option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command. See section [sectref {POOL OBJECT COMMAND}] for a detailed
list of options and their behaviour.

[list_end]
[list_end]

[para]
      
[section {POOLS AND ALLOCATION}]
 
The purpose of the pool command and the pool object command that it
generates, is to manage pools of discrete items.
      
Examples of a pool of discrete items are:

[list_begin bullet]

[bullet]
the seats in a cinema, theatre, train etc.. for which visitors/travelers can  make a reservation;
[bullet]
the dynamic IP-addresses that an ISP can dole out  to subscribers;
[bullet]
a car rental's collection of cars, which can be rented by customers;
[bullet]
the class rooms in a school building, which need to be scheduled;
[bullet]
the database connections available to client-threads in a web-server application;
[bullet]
the books in a library that customers can borrow;
[bullet]
etc ...

[list_end]
[para]

The common denominator in the examples is that there is a more or less
fixed number of items (seats, IP-addresses, cars, ...) that are
supposed to be allocated on a more or less regular basis. An item can
be allocated only once at a time. An item that is allocated, must be
released before it can be re-allocated.  While several items in a pool
are being allocated and released continuously, the total number of
items in the pool remains constant.

[para]
      
Keeping track of which items are allocated, and by whom, is the
purpose of the pool command and its subordinates.

[para]      

[emph {Pool parlance}]: If we say that an item is

[term allocated], it means that the item is [term busy],

[term owned] or [term occupied]; it is not available anymore. If
an item is [term free], it is [term available]. Deallocating an
item is equivalent to setting free or releasing an item. The person or
entity to which the item has been allotted is said to own the item.
      
      
[section ITEMS]
      
[emph {Discrete items}]
[para]

The [cmd pool] command is designed for

[emph {discrete items only}]. Note that there are pools where
allocation occurs on a non-discrete basis, for example computer
memory. There are also pools from which the shares that are doled out
are not expected to be returned, for example a charity fund or a pan
of soup from which you may receive a portion. Finally, there are even
pools from which nothing is ever allocated or returned, like a
swimming pool or a cesspool.

[para]
[emph {Unique item names}]
[para]

A pool cannot manage duplicate item names. Therefore, items in a pool
must have unique names.

[para]
[emph {Item equivalence}]
[para]

From the point of view of the manager of a pool, items are
equivalent. The manager of a pool is indifferent about which
entity/person occupies a given item. However, clients may have
preferences for a particular item, based on some item property they
know.

[para] 
[emph Preferences]
[para]

A future owner may have a preference for a particular item. Preference
based allocation is supported (see the [option -prefer] option to the
request subcommand). A preference for a particular item is most likely
to result from variability among features associated with the
items. Note that the pool commands themselves are not designed to
manage such item properties. If item properties play a role in an
application, they should be managed separately.
 
 
[section {POOL OBJECT COMMAND}]
 
The following subcommands and corresponding arguments are available to
any pool object command.

[list_begin definitions]
 
[call [arg poolName] [method add] [arg itemName1] [opt [arg {itemName2 itemName3 ...}]]]

This command adds the items on the command line to the pool. If
duplicate item names occur on the command line, an error is raised. If
one or more of the items already exist in the pool, this also is
considered an error.

              
[call [arg poolName] [method clear] [opt [option -force]]]

Removes all items from the pool. If there are any allocated items at
the time when the command is invoked, an error is raised. This
behaviour may be modified through the [option -force] argument. If it
is supplied on the command line, the pool will be cleared regardless
the allocation state of its items.
     
[call [arg poolName] [method destroy] [opt [option -force]]]

Destroys the pool data structure, all associated variables and the
associated pool object command. By default, the command checks whether
any items are still allocated and raises an error if such is the
case. This behaviour may be modified through the argument

[option -force]. If it is supplied on the command line, the pool data
structure will be destroyed regardless allocation state of its items.
 

[call [arg poolName] [method info] [arg type] [opt [arg arg]]]

Returns various information about the pool for further programmatic
use. The [arg type] argument indicates the type of information
requested. Only the type [const allocID] uses an additional argument.

[list_begin definitions]
     
[lst_item "[const allocID] [arg itemName]"]

returns the allocID of the item whose name is [arg itemName]. Free
items have an allocation id of [const -1].

[lst_item [const allitems]]

returns a list of all items in the pool.
 
[lst_item [const allocstate]]

Returns a list of key-value pairs, where the keys are the items and
the values are the corresponding allocation id's. Free items have an
allocation id of [const -1].
      
[lst_item [const cursize]]

returns the current pool size, i.e. the number of items in the pool.
      
[lst_item [const freeitems]]

returns a list of items that currently are not allocated.
      
[lst_item [const maxsize]]

returns the maximum size of the pool.

[list_end]
[nl]          

[call [arg poolName] [method maxsize] [opt [arg maxsize]]]

Sets or queries the maximum size of the pool, depending on whether the
[arg maxsize] argument is supplied or not. If [arg maxsize] is
supplied, the maximum size of the pool will be set to that value. If
no argument is supplied, the current maximum size of the pool is
returned. In this variant, the command is an alias for:

[nl]
[cmd {poolName info maxsize}].
[nl]

The [arg maxsize] argument has to be a positive integer.
     
     
[call [arg poolName] [method release] [arg itemName]]

Releases the item whose name is [arg itemName] that was allocated
previously. An error is raised if the item was not allocated at the
time when the command was issued.

     
[call [arg poolName] [method remove] [arg itemName] [opt [option -force]]]

Removes the item whose name is [arg itemName] from the pool. If the
item was allocated at the time when the command was invoked, an error
is raised. This behaviour may be modified through the optional
argument [option -force]. If it is supplied on the command line, the
item will be removed regardless its allocation state.
     

[call [arg poolName] [method request] itemVar [opt options]]

Handles a request for an item, taking into account a possible
preference for a particular item. There are two possible outcomes
depending on the availability of items:

[list_begin enum]

[enum]

The request is honoured, an item is allocated and the variable whose
name is passed with the argument [arg itemVar] will be set to the name
of the item that was allocated. The command returns 1.

[enum]

The request is denied. No item is allocated. The variable whose name
is itemVar is not set.  Attempts to read [arg itemVar] may raise an
error if the variable was not defined before issuing the request. The
command returns 0.

[list_end]
[nl]

The return values from this command are meant to be inspected. The
examples below show how to do this. Failure to check the return value
may result in erroneous behaviour. If no preference for a particular
item is supplied through the option [option -prefer] (see below), then
all requests are honoured as long as items are available.

[nl]
The following options are supported:

[list_begin definitions]
 
[lst_item "[option -allocID] [arg allocID]"]

If the request is honoured, an item will be allocated to the entity
identified by allocID. If the allocation state of an item is queried,
it is this allocation ID that will be returned. If the option

[option -allocID] is not supplied, the item will be given to and owned
by [const dummyID]. Allocation id's may be anything except the value
-1, which is reserved for free items.

     
[lst_item "[option -prefer] [arg preferredItem]"]

This option modifies the allocation strategy as follows: If the item
whose name is [arg preferredItem] is not allocated at the time when
the command is invoked, the request is honoured (return value is
1). If the item was allocated at the time when the command was
invoked, the request is denied (return value is 0).

[list_end]               
[list_end]               
 
[section EXAMPLES]
 
Two examples are provided. The first one mimics a step by step
interactive tclsh session, where each step is explained. The second
example shows the usage in a server application that talks to a
back-end application.

[para]      
[emph {Example 1}]
[para]

This example presents an interactive tclsh session which considers the
case of a Car rental's collection of cars. Ten steps explain its usage
in chronological order, from the creation of the pool, via the most
important stages in the usage of a pool, to the final destruction.

[para]
[emph {Note aside:}]
[para]

In this example, brand names are used to label the various
items. However, a brand name could be regarded as a property of an
item. Because the pool command is not designed to manage properties of
items, they need to be managed separately. In the latter case the
items should be labeled with more neutral names such as: car1, car2,
car3 , etc ... and a separate database or array should hold the brand
names associated with the car labels.

[para]      
[example {      
     1. Load the package into an interpreter
     % package require pool
     0.1
      
     2. Create a pool object called `CarPool' with a maximum size of 55 items (cars):
     % pool CarPool 55
     CarPool
      
     4. Add items to the pool:
     % CarPool add Toyota Trabant Chrysler1 Chrysler2 Volkswagen
                   
     5. Somebody crashed the Toyota. Remove it from the pool as follows:
     % CarPool remove Toyota
      
     6. Acquired a new car for the pool. Add it as follows:
     % CarPool add Nissan
      
     7. Check whether the pool was adjusted correctly:
     % CarPool info allitems
     Trabant Chrysler1 Chrysler2 Volkswagen Nissan
}]

[para]

Suspend the interactive session temporarily, and show the programmatic
use of the request subcommand:

[para]      
[example {     
     # Mrs. Swift needs a car. She doesn't have a preference for a
     # particular car. We'll issue a request on her behalf as follows:
     if { [CarPool request car -allocID "Mrs. Swift"] }  {
         # request was honoured, process the variable `car'
         puts "$car has been allocated to [CarPool info allocID $car]."
     } else {
         # request was denied
          puts "No car available."
     }
}]
[para]

Note how the [cmd if] command uses the value returned by the
[method request] subcommand.

[para]
[example {      
     # Suppose Mr. Wiggly has a preference for the Trabant:
     if { [CarPool request car -allocID "Mr. Wiggly" -prefer Trabant] }  {
         # request was honoured, process the variable `car'
         puts "$car has been allocated to [CarPool info allocID $car]."
     } else {
         # request was denied
          puts "The Trabant was not available."
     }
}]
[para]

Resume the interactive session:

[para]
[example {
     8. When the car is returned then you can render it available by:
     % CarPool release Trabant
      
     9. When done, you delete the pool.
     % CarPool destroy
     Couldn't destroy `CarPool' because some items are still allocated.
      
     Oops, forgot that Mrs. Swift still occupies a car.
      
     10. We force the destruction of the pool as follows: 
     % CarPool destroy -force
}]

[para]
[emph {Example 2}]
[para]

This example describes the case from which the author's need for pool
management originated. It is an example of a server application that
receives requests from client applications. The client requests are
dispatched onto a back-end application before being returned to the
client application. In many cases there are a few equivalent instances
of back-end applications to which a client request may be passed
along. The file descriptors that identify the channels to these
back-end instances make up a pool of connections. A particular
connection may be allocated to just one client request at a time.

[para]
[example { 
     # Create the pool of connections (pipes)
     set maxpipes 10
     pool Pipes $maxpipes
     for {set i 0} {$i < $maxpipes} {incr i} {
         set fd {open "|backendApplication" w+}
         Pipes add $fd
     }
      
     # A client request comes in. The request is identified as `clientX'.
     # Dispatch it onto an instance of a back-end application
     if { [Pipes request fd -allocID clientX] } {
         # a connection was allocated
         # communicate to the back-end application via the variable `fd'
         puts $fd "someInstruction"
         # ...... etc.
     } else {
         # all connections are currently occupied
         # store the client request in a queue for later processing,
         # or return a 'Server busy' message to the client.
     }
}]

[keywords struct pool finite {discrete items}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/pool.tcl.

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

package require cmdline

namespace eval ::struct {}
namespace eval ::struct::pool {

    # a list of all current pool names
    variable pools {}

    # counter is used to give a unique name to a pool if
    # no name was supplied, e.g. pool1, pool2 etc.
    variable counter 0

    # `commands' is the list of subcommands recognized by a pool-object command
    variable commands {add clear destroy info maxsize release remove request}

    # All errors with corresponding (unformatted) messages.
    # The format strings will be replaced by the appropriate
    # values when an error occurs.
    variable  Errors
    array set Errors {
	BAD_SUBCMD {bad subcommand "%s": must be %s}
	DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.}
	DUPLICATE_POOLNAME {The pool `%s' already exists.}
	EXCEED_MAXSIZE "This command would increase the total number of items\
		\nbeyond the maximum size of the pool. No items registered."
	FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID."
	INVALID_POOLSIZE {The pool currently holds %s items.\
		Can't set maxsize to a value less than that.}
	ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.}
	ITEM_NOT_IN_POOL {`%s' is not a member of %s.}
	ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.}
	ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.}
	NONINT_REQSIZE {The second argument must be a positive integer value}
	SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.}
	UNKNOWN_ARG {Unknown argument `%s'}
	UNKNOWN_POOL {Nothing known about `%s'.}
	VARNAME_EXISTS "A variable `::struct::pool::%s' already exists."
	WRONG_INFO_TYPE "Expected second argument to be one of:\
		\n     allitems, allocstate, cursize, freeitems, maxsize,\
		\nbut received: `%s'."
	WRONG_NARGS {Wrong nr. of arguments.}
    }
    
    namespace export pool
}


# A small helper routine to check list membership
proc ::struct::pool::lmember {list element} {
    if { [lsearch -exact $list $element] >= 0 } {
        return 1
    } else  {
        return 0
    }
}


# General note
# ============
#
# All procedures below use the following method to reference
# a particular pool-object:
#
#    variable $poolname
#    upvar #0 ::struct::pool::$poolname pool
#    upvar #0 ::struct::pool::Allocstate_$poolname state
#
# Therefore, the names `pool' and `state' refer to a particular
# instance of a pool.
#
# In the comments to the code below, the words `pool' and `state'
# also refer to a particular pool.
#

# ::struct::pool::create
#
#    Creates a new instance of a pool (a pool-object).
#    ::struct::pool::pool (see right below) is an alias to this procedure.
#
#
# Arguments:
#    poolname: name of the pool-object
#    maxsize:  the maximum number of elements that the pool is allowed
#              consist of.
#
#
# Results:
#    the name of the newly created pool
#
#
# Side effects:
#    - Registers the pool-name in the variable `pools'.
#
#    - Creates the pool array which holds general state about the pool.
#      The following elements are initialized:
#          pool(freeitems): a list of non-allocated items
#          pool(cursize):   the current number of elements in the pool
#          pool(maxsize):   the maximum allowable number of pool elements
#      Additional state may be hung off this array as long as the three
#      elements above are not corrupted.
#
#    - Creates a separate array `state' that will hold allocation state
#      of the pool elements.
#
#    - Creates an object-procedure that has the same name as the pool.
#
proc ::struct::pool::create { {poolname ""} {maxsize 10} } {
    variable pools
    variable counter
    variable Errors
    
    # check maxsize argument
    if { ![string equal $maxsize 10] } {
        if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } {
            return -code error $Errors(NONINT_REQSIZE)
        }
    }
    
    # create a name if no name was supplied
    if { [string length $poolname]==0 } {
        incr counter
        set poolname pool$counter
        set incrcnt 1
    }
    
    # check whether there exists a pool named $poolname
    if { [lmember $pools $poolname] } {
        if { [::info exists incrcnt] } {
            incr counter -1
        }
        return -code error [format $Errors(DUPLICATE_POOLNAME) $poolname]
    }
    
    # check whether the namespace variable exists
    if { [::info exists ::struct::pool::$poolname] } {
        if { [::info exists incrcnt] } {
            incr counter -1
        }
        return -code error [format $Errors(VARNAME_EXISTS) $poolname]
    }
    
    variable $poolname
    
    # register
    lappend pools $poolname
    
    # create and initialize the new pool data structure
    upvar #0 ::struct::pool::$poolname pool
    set pool(freeitems) {}
    set pool(maxsize) $maxsize
    set pool(cursize) 0
    
    # the array that holds allocation state
    upvar #0 ::struct::pool::Allocstate_$poolname state
    array set state {}
    
    # create a pool-object command and map it to the pool commands
    interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname
    return $poolname
}

#
# This alias provides compatibility with the implementation of the
# other data structures (stack, queue etc...) in the tcllib::struct package.
#
proc ::struct::pool::pool { {poolname ""} {maxsize 10} } {
    ::struct::pool::create $poolname $maxsize
}


# ::struct::pool::poolCmd
#
#    This proc constitutes a level of indirection between the pool-object
#    subcommand and the pool commands (below); it's sole function is to pass
#    the command along to one of the pool commands, and receive any results.
#
# Arguments:
#    poolname:    name of the pool-object
#    subcmd:      the subcommand, which identifies the pool-command to
#                 which calls will be passed.
#    args:        any arguments. They will be inspected by the pool-command
#                 to which this call will be passed along.
#
# Results:
#    Whatever result the pool command returns, is once more returned.
#
# Side effects:
#    Dispatches the call onto a specific pool command and receives any results.
#
proc ::struct::pool::poolCmd {poolname subcmd args} {
    variable Errors
    
    # check the subcmd argument
    if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } {
        set optlist [join $::struct::pool::commands ", "]
        set optlist [linsert $optlist "end-1" "or"]
        return -code error [format $Errors(BAD_SUBCMD) $subcmd $optlist]
    }
    
    # pass the call to the pool command indicated by the subcmd argument,
    # and return the result from that command.
    return [eval ::struct::pool::$subcmd $poolname $args]
}


# ::struct::pool::destroy
#
#    Destroys a pool-object, its associated variables and "object-command"
#
# Arguments:
#    poolname:    name of the pool-object
#    forceArg:    if set to `-force', the pool-object will be destroyed
#                 regardless the allocation state of its objects.
#
# Results:
#    none
#
# Side effects:
#    - unregisters the pool name in the variable `pools'.
#    - unsets `pool' and `state' (poolname specific variables)
#    - destroys the "object-procedure" that was associated with the pool.
#
proc ::struct::pool::destroy {poolname {forceArg ""}} {
    variable pools
    variable Errors
    
    # check forceArg argument
    if { [string length $forceArg] } {
        if { [string equal $forceArg -force] } {
            set force 1
        } else {
            return -code error [format $Errors(UNKNOWN_ARG) $forceArg]
        }
    } else {
        set force 0
    }
    
    set index [lsearch -exact $pools $poolname]
    if {$index == -1 } {
        return -code error [format $Errors(UNKNOWN_POOL) $poolname]
    }
    
    if { !$force } {
        # check for any lingering allocated items
        variable $poolname
        upvar #0 ::struct::pool::$poolname pool
        upvar #0 ::struct::pool::Allocstate_$poolname state
        if { [llength $pool(freeitems)] != $pool(cursize) } {
            return -code error [format $Errors(SOME_ITEMS_NOT_FREE) destroy $poolname]
        }
    }
    
    rename ::$poolname {}
    unset ::struct::pool::$poolname
    catch {unset ::struct::pool::Allocstate_$poolname}
    set pools [lreplace $pools $index $index]
    
    return
}


# ::struct::pool::add
#
#    Add items to the pool
#
# Arguments:
#    poolname:    name of the pool-object
#    args:        the items to add
#
# Results:
#    none
#
# Side effects:
#    sets the initial allocation state of the added items to -1 (free)
#
proc ::struct::pool::add {poolname args} {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    # argument check
    if { [llength $args] == 0 } {
        return -code error $Errors(WRONG_NARGS)
    }
    
    # will this operation exceed the size limit of the pool?
    if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } {
        return -code error $Errors(EXCEED_MAXSIZE)
    }
    
    
    # check for duplicate items on the command line
    set N [llength $args]
    if { $N > 1} {
        for {set i 0} {$i<=$N} {incr i} {
            foreach item [lrange $args [expr {$i+1}] end] {
                if { [string equal [lindex $args $i] $item]} {
                    return -code error [format $Errors(DUPLICATE_ITEM_IN_ARGS) $item]
                }
            }
        }
    }
    
    # check whether the items exist yet in the pool
    foreach item $args {
        if { [lmember [array names state] $item] } {
            return -code error [format $Errors(ITEM_ALREADY_IN_POOL) $item]
        }
    }
    
    # add items to the pool, and initialize their allocation state
    foreach item $args {
        lappend pool(freeitems) $item
        set state($item) -1
        incr pool(cursize)
    }
    return
}



# ::struct::pool::clear
#
#    Removes all items from the pool and clears corresponding
#    allocation state.
#
#
# Arguments:
#    poolname: name of the pool-object
#    forceArg: if set to `-force', all items are removed
#              regardless their allocation state.
#
# Results:
#    none
#
# Side effects:
#    see description above
#
proc ::struct::pool::clear {poolname {forceArg ""} } {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    # check forceArg argument
    if { [string length $forceArg] } {
        if { [string equal $forceArg -force] } {
            set force 1
        } else {
            return -code error [format $Errors(UNKNOWN_ARG) $forceArg]
        }
    } else {
        set force 0
    }
    
    # check whether some items are still allocated
    if { !$force } {
        if { [llength $pool(freeitems)] != $pool(cursize) } {
            return -code error [format $Errors(SOME_ITEMS_NOT_FREE) clear $poolname]
        }
    }
    
    # clear the pool, clean up state and adjust the pool size
    set pool(freeitems) {}
    array unset state
    array set state {}
    set pool(cursize) 0
    return
}



# ::struct::pool::info
#
#    Returns information about the pool in data structures that allow
#    further programmatic use.
#
# Arguments:
#    poolname: name of the pool-object
#    type:     the type of info requested
#
#
# Results:
#    The info requested
#
#
# Side effects:
#    none
#
proc ::struct::pool::info {poolname type args} {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    # check the number of arguments
    if { [string equal $type allocID] } {
        if { [llength $args]!=1 } {
            return -code error $Errors(WRONG_NARGS)
        }
    } elseif { [llength $args] > 0 } {
        return -code error $Errors(WRONG_NARGS)
    }
    
    switch $type {
        allitems {
            return [array names state]
        }
        allocstate {
            return [array get state]
        }
        allocID {
            set item [lindex $args 0]
            if {![lmember [array names state] $item]} {
                return -code error [format $Errors(ITEM_NOT_IN_POOL) $item $poolname]
            }
            return $state($item)
        }
        cursize {
            return $pool(cursize)
        }
        freeitems {
            return $pool(freeitems)
        }
        maxsize {
            return $pool(maxsize)
        }
        default {
            return -code error [format $Errors(WRONG_INFO_TYPE) $type]
        }
    }
}


# ::struct::pool::maxsize
#
#    Returns the current or sets a new maximum size of the pool.
#    As far as querying only is concerned, this is an alias for
#    `::struct::pool::info maxsize'.
#
#
# Arguments:
#    poolname: name of the pool-object
#    reqsize:  if supplied, it is the requested size of the pool, i.e.
#              the maximum number of elements in the pool.
#
#
# Results:
#    The current/new maximum size of the pool.
#
#
# Side effects:
#    Sets pool(maxsize) if a new size is supplied.
#
proc ::struct::pool::maxsize {poolname {reqsize ""} } {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    if { [string length $reqsize] } {
        if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } {
            if { $pool(cursize) <= $reqsize } {
                set pool(maxsize) $reqsize
            } else  {
                return -code error [format $Errors(INVALID_POOLSIZE) $pool(cursize)]
            }
        } else  {
            return -code error $Errors(NONINT_REQSIZE)
        }
    }
    return $pool(maxsize)
}


# ::struct::pool::release
#
#    Deallocates an item
#
#
# Arguments:
#    poolname: name of the pool-object
#    item:     name of the item to be released
#
#
# Results:
#    none
#
# Side effects:
#    - sets the item's allocation state to free (-1)
#    - appends item to the list of free items
#
proc ::struct::pool::release {poolname item} {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    # Is item in the pool?
    if {![lmember [array names state] $item]} {
        return -code error [format $Errors(ITEM_NOT_IN_POOL) $item $poolname]
    }
    
    # check whether item was allocated
    if { $state($item) == -1 } {
        return -code error [format $Errors(ITEM_NOT_ALLOCATED) $item]
    } else  {
        
        # set item free and return it to the pool of free items
        set state($item) -1
        lappend pool(freeitems) $item
        
    }
    return
}

# ::struct::pool::remove
#
#    Removes an item from the pool
#
#
# Arguments:
#    poolname: name of the pool-object
#    item:     the item to be removed
#    forceArg: if set to `-force', the item is removed
#              regardless its allocation state.
#
# Results:
#    none
#
# Side effects:
#    - cleans up allocation state related to the item
#
proc ::struct::pool::remove {poolname item {forceArg ""} } {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    # check forceArg argument
    if { [string length $forceArg] } {
        if { [string equal $forceArg -force] } {
            set force 1
        } else {
            return -code error [format $Errors(UNKNOWN_ARG) $forceArg]
        }
    } else {
        set force 0
    }
    
    # Is item in the pool?
    if {![lmember [array names state] $item]} {
        return -code error [format $Errors(ITEM_NOT_IN_POOL) $item $poolname]
    }
    
    set index [lsearch $pool(freeitems) $item]
    if { $index >= 0} {
        
        # actual removal
        set pool(freeitems) [lreplace $pool(freeitems) $index $index]
        
    } elseif { !$force }  {
        return -code error [format $Errors(ITEM_STILL_ALLOCATED) $item]
    }
    
    # clean up state and adjust the pool size
    unset state($item)
    incr pool(cursize) -1
    return
}



# ::struct::pool::request
#
#     Handles requests for an item, taking into account a preference
#     for a particular item if supplied.
#
#
# Arguments:
#    poolname:    name of the pool-object
#
#    itemvar:     variable to which the item-name will be assigned
#                 if the request is honored.
#
#    args:        an optional sequence of key-value pairs, indicating the
#                 following options:
#                 -prefer:  the preferred item to allocate.
#                 -allocID: An ID for the entity to which the item will be
#                           allocated. This facilitates reverse lookups.
#
# Results:
#
#    1 if the request was honored; an item is allocated
#    0 if the request couldn't be honored; no item is allocated
#
#    The user is strongly advised to check the return values
#    when calling this procedure.
#
#
# Side effects:
#
#   if the request is honored:
#    - sets allocation state to $allocID (or dummyID if it was not supplied)
#      if allocation was succesful. Allocation state is maintained in the
#      namespace variable state (see: `General note' above)
#    - sets the variable passed via `itemvar' to the allocated item.
#
#   if the request is denied, no side effects occur.
#
proc ::struct::pool::request {poolname itemvar args} {
    variable Errors
    variable $poolname
    upvar #0 ::struct::pool::$poolname pool
    upvar #0 ::struct::pool::Allocstate_$poolname state
    
    # check args
    set nargs [llength $args]
    if { ! ($nargs==0 || $nargs==2 || $nargs==4) } {
        if { ![string equal $args -?] && ![string equal $args -help]} {
            return -code error $Errors(WRONG_NARGS)
        }
    } elseif { $nargs } {
        foreach {name value} $args {
            if { ![string match -* $name] } {
                return -code error [format $Errors(UNKNOWN_ARG) $name]
            }
        }
    }
    
    set allocated 0
    
    # are there any items available?
    if { [llength $pool(freeitems)] > 0} {
        
        # process command options
        set options [cmdline::getoptions args { \
            {prefer.arg {} {The preference for a particular item}} \
            {allocID.arg {} {An ID for the entity to which the item will be allocated} } \
                } \
                "usage: $poolname request itemvar ?options?:"]
        foreach {key value} $options {
            set $key $value
        }
        
        if { $allocID == -1 } {
            return -code error $Errors(FORBIDDEN_ALLOCID)
        }
        
        # let `item' point to a variable two levels up the call stack
        upvar 2 $itemvar item
        
        # check whether a preference was supplied
        if { [string length $prefer] } {
            if {![lmember [array names state] $prefer]} {
                return -code error [format $Errors(ITEM_NOT_IN_POOL) $prefer $poolname]
            }
            if { $state($prefer) == -1 } {
                set index [lsearch $pool(freeitems) $prefer]
                set item $prefer
            }
        } else  {
            set index 0
            set item [lindex $pool(freeitems) 0]
        }
        
        # do the actual allocation
        set pool(freeitems) [lreplace $pool(freeitems) $index $index]
        if { [string length $allocID] } {
            set state($item) $allocID
        } else  {
            set state($item) dummyID
        }
        set allocated 1
    }
    return $allocated
}


# EOF pool.tcl
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/pooltest.tcl.

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

source [file join [file dirname [info script]] pool.tcl]
namespace import pool::*
pool CarPool

CarPool add Toyota Volkswagen Chrysler Trabant

CarPool request item -prefer Trabant -allocID me


proc poolinfo {} {
    puts "Current pool size: [CarPool info cursize]"
    puts "Maximum pool size: [CarPool info maxsize]"
    puts "Free items: [CarPool info freeitems]"
    if { [CarPool info cursize] > 0 } {
        set sep_line [string repeat - 40]
        puts "Allocation info:\
                \nnr.    item   allocID (-1 = free)"
        puts $sep_line
        set i 0
        foreach {item state} [CarPool info allocstate] {
            puts "[incr i]     $item        $state"
        }
        puts $sep_line
    }
    return
}
poolinfo
set failedtests {}

# Exercise all error cases

proc MatchErrMsg {errid errmsg} {
    global failedtests
    
    set pattern [format $::pool::Errors($errid) * *]
    if { ![string match $pattern $errmsg] } {
        puts "$errid: failed \
                \nPattern: $pattern \
                \nError message: $errmsg"
        lappend failedtests $errid
    } else  {
        puts "$errid: passed"
    }
}

proc VARNAME_EXISTS {} {
    set ::pool::existvar 1
    catch {pool::create existvar} errmsg
    MatchErrMsg [info level 0] $errmsg
    unset ::pool::existvar
}

proc DUPLICATE_POOLNAME {} {
    catch {pool::create CarPool} errmsg
    MatchErrMsg [info level 0] $errmsg
}

proc NONINT_REQSIZE {} {
    catch {pool::create CarPool noninteger} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool maxsize noninteger} errmsg
    MatchErrMsg [info level 0] $errmsg
}

proc UNKNOWN_POOL {} {
    catch {pool::destroy NonExistentPool} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc BAD_SUBCMD {} {
    catch {CarPool badsubcommand whateverargs} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc SOME_ITEMS_NOT_FREE {} {
    catch {CarPool clear} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool destroy} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc DUPLICATE_ITEM_IN_ARGS {} {
    catch {CarPool add Toyota duplicatecar someothercar somestrangecar duplicatecar} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc FORBIDDEN_ALLOCID {} {
    catch {CarPool request car -allocID -1} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc ITEM_ALREADY_IN_POOL {} {
    catch {CarPool add Toyota} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc ITEM_STILL_ALLOCATED {} {
    catch {CarPool remove Trabant} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc ITEM_NOT_ALLOCATED {} {
    catch {CarPool release Toyota} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc ITEM_NOT_IN_POOL {} {
    catch {CarPool info allocID Buggy} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool request item -prefer Buggy} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool release Buggy} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool remove Buggy} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc EXCEED_MAXSIZE {} {
    catch {CarPool add  1 2 3 4 5 6 7} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc INVALID_POOLSIZE {} {
    catch {CarPool maxsize [expr {[CarPool info cursize] - 1}] } errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc WRONG_INFO_TYPE {} {
    catch {CarPool info wronginfotype} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc UNKNOWN_ARG {} {
    catch {CarPool clear unknownarg} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool request item Toyota unknownarg} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool destroy unknownarg} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool remove Toyota unknownarg} errmsg
    MatchErrMsg [info level 0] $errmsg
}


proc WRONG_NARGS {} {
    catch {CarPool add} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool info cursize oneargtoomany} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool info allocID} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool info allocID Trabant oneargtoomany} errmsg
    MatchErrMsg [info level 0] $errmsg
    
    catch {CarPool request item Toyota -prefer me} errmsg
    MatchErrMsg [info level 0] $errmsg
}


puts "TESTING ERROR CASES:\n"

foreach errid [array names pool::Errors] {
    if { [llength [::info procs $errid]] } {
        eval $errid
    }
}

puts {}
if { [llength $failedtests] } {
    puts "The following tests failed:"
    foreach errid $failedtests {
        puts $errid
    }
} else  {
    puts "All tests passed."
}

# EOF pooltest.tcl
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































Deleted modules/struct/prioqueue.tcl.

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

package require Tcl 8.2

namespace eval ::struct {}

namespace eval ::struct::prioqueue {
    # The queues array holds all of the queues you've made
    variable queues

    # counter is used to give a unique name for unnamed queues
    variable counter 0

    # commands is the list of subcommands recognized by the queue
    variable commands [list \
	    "clear" \
	    "destroy"   \
	    "get"   \
	    "peek"  \
	    "put"   \
	    "size"  \
	    "peekpriority" \
	    ]

    variable sortopt [list \
	    "-integer" \
	    "-real" \
	    "-ascii" \
	    "-dictionary" \
	    ]

    # this is a simple design decision, that integer and real
    # are sorted decreasing, and -ascii and -dictionary are sorted -increasing
    # could be changed to something configurable.
    variable sortdir [list \
	    "-decreasing" \
	    "-decreasing" \
	    "-increasing" \
	    "-increasing" \
	    ]



    # Only export one command, the one used to instantiate a new queue
    namespace export prioqueue

    proc K {x y} {set x} ;# DKF's K combinator
}

# ::struct::prioqueue::prioqueue --
#
#   Create a new prioqueue with a given name; if no name is given, use
#   prioqueueX, where X is a number.
#
# Arguments:
#   sorting sorting option for lsort to use, no -command option
#           defaults to integer
#   name    name of the queue; if null, generate one.
#           names may not begin with -
#
#
# Results:
#   name    name of the queue created

proc ::struct::prioqueue::prioqueue {args} {
    variable queues
    variable counter
    variable queues_sorting
    variable sortopt

    # check args
    if {[llength $args] > 2} {
        error "wrong # args: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\""
    }
    if {[llength $args] == 0} {
        # defaulting to integer priorities
        set sorting -integer
    } else {
        if {[llength $args] == 1} {
            if {[string match "-*" [lindex $args 0]]==1} {
                set sorting [lindex $args 0]
            } else {
                set sorting -integer
                set name [lindex $args 0]
            }
        } else {
            if {[llength $args] == 2} {
                foreach {sorting name} $args {break}
            }
        }
    }
    # check option (like lsort sorting options without -command)
    if {[lsearch $sortopt $sorting] == -1} {
        # if sortoption is unknown, but name is a sortoption we give a better error message
        if {[info exists name] && [lsearch $sortopt $name]!=-1} {
            error "wrong argument position: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\""
        }
        error "unknown sort option \"$sorting\""
    }
    # create name if not given
    if {![info exists name]} {
        incr counter
        set name "prioqueue${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create prioqueue"
    }

    # Initialize the queue as empty
    set queues($name) [list ]
    switch -exact -- $sorting {
	-integer { set queues_sorting($name) 0}
	-real    { set queues_sorting($name) 1}
	-ascii   { set queues_sorting($name) 2}
	-dictionary { set queues_sorting($name) 3}
    }

    # Create the command to manipulate the queue
    interp alias {} ::$name {} ::struct::prioqueue::QueueProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::prioqueue::QueueProc --
#
#   Command that processes all queue object commands.
#
# Arguments:
#   name    name of the queue object to manipulate.
#   args    command name and args for the command
#
# Results:
#   Varies based on command to perform

proc ::struct::prioqueue::QueueProc {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 { [string equal [info commands ::struct::prioqueue::_$cmd] ""] } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    return [eval [list ::struct::prioqueue::_$cmd $name] $args]
}

# ::struct::prioqueue::_clear --
#
#   Clear a queue.
#
# Arguments:
#   name    name of the queue object.
#
# Results:
#   None.

proc ::struct::prioqueue::_clear {name} {
    variable queues
    set queues($name) [list]
    return
}

# ::struct::prioqueue::_destroy --
#
#   Destroy a queue object by removing it's storage space and
#   eliminating it's proc.
#
# Arguments:
#   name    name of the queue object.
#
# Results:
#   None.

proc ::struct::prioqueue::_destroy {name} {
    variable queues
    variable queues_sorting
    unset queues($name)
    unset queues_sorting($name)
    interp alias {} ::$name {}
    return
}

# ::struct::prioqueue::_get --
#
#   Get an item from a queue.
#
# Arguments:
#   name    name of the queue object.
#   count   number of items to get; defaults to 1
#
# Results:
#   item    first count items from the queue; if there are not enough
#           items in the queue, throws an error.
#

proc ::struct::prioqueue::_get {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in prioqueue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item gets aren't listified
	set item [lindex [lindex $queues($name) 0] 1]
	set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 0]
	return $item
    }

    # Otherwise, return a list of items
    incr count -1
    set items [lrange $queues($name) 0 $count]
    foreach item $items {
        lappend result [lindex $item 1]
    }
    set items ""

    set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 $count]
    return $result
}

# ::struct::prioqueue::_peek --
#
#   Retrive the value of an item on the queue without removing it.
#
# Arguments:
#   name    name of the queue object.
#   count   number of items to peek; defaults to 1
#
# Results:
#   items   top count items from the queue; if there are not enough items
#       to fufill the request, throws an error.

proc ::struct::prioqueue::_peek {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in prioqueue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	return [lindex [lindex $queues($name) 0] 1]
    }

    # Otherwise, return a list of items
    set index [expr {$count - 1}]
    foreach item [lrange $queues($name) 0 $index] {
        lappend result [lindex $item 1]
    }
    return $result
}

# ::struct::prioqueue::_peekpriority --
#
#   Retrive the priority of an item on the queue without removing it.
#
# Arguments:
#   name    name of the queue object.
#   count   number of items to peek; defaults to 1
#
# Results:
#   items   top count items from the queue; if there are not enough items
#       to fufill the request, throws an error.

proc ::struct::prioqueue::_peekpriority {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in prioqueue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	return [lindex [lindex $queues($name) 0] 0]
    }

    # Otherwise, return a list of items
    set index [expr {$count - 1}]
    foreach item [lrange $queues($name) 0 $index] {
        lappend result [lindex $item 0]
    }
    return $result
}


# ::struct::prioqueue::_put --
#
#   Put an item into a queue.
#
# Arguments:
#   name    name of the queue object
#   args    list of the form "item1 prio1 item2 prio2 item3 prio3"
#
# Results:
#   None.

proc ::struct::prioqueue::_put {name args} {
    variable queues
    variable queues_sorting
    variable sortopt
    variable sortdir

    if { [llength $args] == 0 || [llength $args] % 2} {
	error "wrong # args: should be \"$name put item prio ?item prio ...?\""
    }

    # check for prio type before adding
    switch -exact -- $queues_sorting($name) {
        0    {
	    foreach {item prio} $args {
		if {![string is integer -strict $prio]} {
		    error "priority \"$prio\" is not an integer type value"
		}
	    }
	}
        1    {
	    foreach {item prio} $args {
		if {![string is double -strict $prio]} {
		    error "priority \"$prio\" is not a real type value"
		}
	    }
	}
        default {
	    #no restrictions for -ascii and -dictionary
	}
    }

    # sort by priorities
    set opt [lindex $sortopt $queues_sorting($name)]
    set dir [lindex $sortdir $queues_sorting($name)]

    # add only if check has passed
    foreach {item prio} $args {
        set new [list $prio $item]
        set queues($name) [__linsertsorted [K $queues($name) [set queues($name) ""]] $new $opt $dir]
    }
    return
}

# ::struct::prioqueue::_size --
#
#   Return the number of objects on a queue.
#
# Arguments:
#   name    name of the queue object.
#
# Results:
#   count   number of items on the queue.

proc ::struct::prioqueue::_size {name} {
    variable queues
    return [llength $queues($name)]
}

# ::struct::prioqueue::__linsertsorted
#
# Helper proc for inserting into a sorted list.
#
#

proc ::struct::prioqueue::__linsertsorted {list newElement sortopt sortdir} {
    set pos 0
    set newPrio [lindex $newElement 0]
    foreach element $list {
        set prio [lindex $element 0]
        if {[__elementcompare $prio $newPrio $sortopt $sortdir]} break
        incr pos
    }
    linsert $list $pos $newElement
}

# ::struct::prioqueue::__elementcompare
#
# Compare helper with the sort options.
#
#

proc ::struct::prioqueue::__elementcompare {prio newPrio sortopt sortdir} {
    if {[string equal $sortopt "-integer"] || [string equal $sortopt "-real"]} {
        set result [expr {$prio < $newPrio}]
    } elseif {[string equal $sortopt "-ascii"]} {
        set result [expr {[string compare $prio $newPrio] < 0}]
    } elseif {[string equal $sortopt "-dictionary"]} {
        # need to use lsort to access -dictionary sorting
        set result [string equal $prio [lindex \
		[lsort -increasing -dictionary [list $prio $newPrio]] 0]]
    }

    return [expr {[string equal $sortdir "-decreasing"] ? $result : !$result}]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/prioqueue.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] prioqueue.tcl]
namespace import -force struct::prioqueue::prioqueue

test prioqueue-0.1 {prioqueue errors} {
    prioqueue -integer myprioqueue
    catch {prioqueue myprioqueue} msg
    myprioqueue destroy
    set msg
} "command \"myprioqueue\" already exists, unable to create prioqueue"
test prioqueue-0.2 {prioqueue errors} {
    prioqueue myprioqueue
    catch {myprioqueue} msg
    myprioqueue destroy
    set msg
} "wrong # args: should be \"myprioqueue option ?arg arg ...?\""
test prioqueue-0.3 {prioqueue errors} {
    prioqueue myprioqueue
    catch {myprioqueue foo} msg
    myprioqueue destroy
    set msg
} "bad option \"foo\": must be clear, destroy, get, peek, put, size, or peekpriority"
test prioqueue-0.4 {prioqueue errors} {
    catch {prioqueue set} msg
    set msg
} "command \"set\" already exists, unable to create prioqueue"

test prioqueue-0.5 {prioqueue errors} {
    catch {prioqueue -foo myprioqueue} msg
    set msg
} "unknown sort option \"-foo\""

test prioqueue-0.6 {prioqueue errors} {
    catch {prioqueue -foo} msg
    set msg
} "unknown sort option \"-foo\""

test prioqueue-0.7 {prioqueue errors} {
    catch {prioqueue -integer myprioqueue foo} msg
    set msg
} "wrong # args: should be \"prioqueue ?-ascii|-dictionary|-integer|-real? ?name?\""

test prioqueue-0.8 {prioqueue errors} {
    catch {prioqueue myprioqueue -integer} msg
    set msg
} "wrong argument position: should be \"prioqueue ?-ascii|-dictionary|-integer|-real? ?name?\""

test prioqueue-1.1 {prioqueue creation} {
    set foo [prioqueue myprioqueue]
    set cmd [info commands ::myprioqueue]
    set size [myprioqueue size]
    myprioqueue destroy
    list $foo $cmd $size
} {myprioqueue ::myprioqueue 0}

test prioqueue-1.2 {prioqueue creation} {
    set foo [prioqueue]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {prioqueue1 ::prioqueue1 0}

test prioqueue-1.3 {prioqueue creation} {
    set foo [prioqueue -ascii]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {prioqueue2 ::prioqueue2 0}

test prioqueue-1.5 {prioqueue creation} {
    set foo [prioqueue -dictionary]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {prioqueue3 ::prioqueue3 0}

test prioqueue-1.6 {prioqueue creation} {
    set foo [prioqueue -integer]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {prioqueue4 ::prioqueue4 0}

test prioqueue-1.7 {prioqueue creation} {
    set foo [prioqueue -real]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {prioqueue5 ::prioqueue5 0}


test prioqueue-2.1 {prioqueue destroy} {
    prioqueue myprioqueue
    myprioqueue destroy
    info commands ::myprioqueue
} {}

test prioqueue-3.2 {size operation} {
    prioqueue myprioqueue
    myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1
    set size [myprioqueue size]
    myprioqueue destroy
    set size
} 7
test prioqueue-3.3 {size operation} {
    prioqueue myprioqueue
    myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1
    myprioqueue get 3
    set size [myprioqueue size]
    myprioqueue destroy
    set size
} 4
test prioqueue-3.4 {size operation} {
    prioqueue myprioqueue
    myprioqueue put a 1 b 1 c 1 d 1 e 1 f 1 g 1 
    myprioqueue get 3
    myprioqueue peek 3
    set size [myprioqueue size]
    myprioqueue destroy
    set size
} 4
    
test prioqueue-4.1 {put operation} {
    prioqueue myprioqueue
    catch {myprioqueue put} msg
    myprioqueue destroy
    set msg
} "wrong # args: should be \"myprioqueue put item prio ?item prio ...?\""

test prioqueue-4.1a {put operation} {
    prioqueue myprioqueue
    catch {myprioqueue put a} msg
    myprioqueue destroy
    set msg
} "wrong # args: should be \"myprioqueue put item prio ?item prio ...?\""

test prioqueue-4.2 {put operation, singleton items} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 1
    myprioqueue put c 1
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "a b c"

test prioqueue-4.3 {put operation, singleton items} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 2
    myprioqueue put c 3
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "c b a"

test prioqueue-4.4 {put operation, singleton items} {
    prioqueue myprioqueue
    myprioqueue put a 3
    myprioqueue put b 2
    myprioqueue put c 1
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "a b c"

test prioqueue-4.5 {put operation, singleton items} {
    prioqueue myprioqueue
    myprioqueue put a 3
    myprioqueue put b 1
    myprioqueue put c 2
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "a c b"

test prioqueue-4.6 {put operation, singleton items} {
    prioqueue -ascii myprioqueue 
    myprioqueue put a a
    myprioqueue put b b
    myprioqueue put c c
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "a b c"

test prioqueue-4.7 {put operation, singleton items} {
    prioqueue -dictionary myprioqueue
    myprioqueue put a a
    myprioqueue put b b
    myprioqueue put c c
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "a b c"

test prioqueue-4.8 {put operation, singleton items} {
    prioqueue -real myprioqueue
    myprioqueue put a 1.0
    myprioqueue put b 2.0
    myprioqueue put c 3.0
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "c b a"

test prioqueue-4.9 {put operation, multiple items} {
    prioqueue myprioqueue
    myprioqueue put a 1 b 1 c 1
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} "a b c"

test prioqueue-4.10 {put operation, spaces in items} {
    prioqueue myprioqueue
    myprioqueue put a 1 b 1 "foo bar" 1
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} [list a b "foo bar"]

test prioqueue-4.11 {put operation, bad chars in items} {
    prioqueue myprioqueue
    myprioqueue put a 1 b 1 \{ 1
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} [list a b \{]

test prioqueue-4.12 {put operation, bad priorities} {
    prioqueue myprioqueue
    catch {myprioqueue put a a} msg
    myprioqueue destroy
    set msg
} {priority "a" is not an integer type value}

test prioqueue-4.13 {put operation, bad priorities} {
    prioqueue myprioqueue
    catch {myprioqueue put a 1.01} msg
    myprioqueue destroy
    set msg
} {priority "1.01" is not an integer type value}

test prioqueue-4.14 {put operation, bad priorities} {
    prioqueue -real myprioqueue 
    catch {myprioqueue put a 1a} msg
    myprioqueue destroy
    set msg
} {priority "1a" is not a real type value}

test prioqueue-4.15 {put operation, bad priorities} {
    prioqueue -real myprioqueue 
    catch {myprioqueue put a a} msg
    myprioqueue destroy
    set msg
} {priority "a" is not a real type value}

test prioqueue-4.16 {put operation, checking priorities} {
    prioqueue -ascii myprioqueue 
    catch {myprioqueue put a 1.0} msg
    myprioqueue destroy
    set msg
} {}

test prioqueue-4.17 {put operation, checking priorities} {
    prioqueue -dictionary myprioqueue 
    catch {myprioqueue put a "1.0 +1"} msg
    myprioqueue destroy
    set msg
} {}


test prioqueue-5.1 {get operation} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 1
    myprioqueue put c 1
    set result [list [myprioqueue get] [myprioqueue get] [myprioqueue get]]
    myprioqueue destroy
    set result
} [list a b c]

test prioqueue-5.2 {get operation, multiple items} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 1
    myprioqueue put c 1
    set result [myprioqueue get 3]
    myprioqueue destroy
    set result
} [list a b c]

test prioqueue-6.1 {peek operation} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 1
    myprioqueue put c 1
    set result [list [myprioqueue peek] [myprioqueue peek] [myprioqueue peek]]
    myprioqueue destroy
    set result
} [list a a a]

test prioqueue-6.2 {peek operation} {
    prioqueue myprioqueue
    catch {myprioqueue peek 0} msg
    myprioqueue destroy
    set msg
} {invalid item count 0}

test prioqueue-6.3 {peek operation} {
    prioqueue myprioqueue
    catch {myprioqueue peek -1} msg
    myprioqueue destroy
    set msg
} {invalid item count -1}

test prioqueue-6.4 {peek operation} {
    prioqueue myprioqueue
    catch {myprioqueue peek} msg
    myprioqueue destroy
    set msg
} {insufficient items in prioqueue to fill request}

test prioqueue-6.5 {peek operation} {
    prioqueue myprioqueue
    myprioqueue put a 1
    catch {myprioqueue peek 2} msg
    myprioqueue destroy
    set msg
} {insufficient items in prioqueue to fill request}

test prioqueue-6.6 {get operation, multiple items} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 1
    myprioqueue put c 1
    set result [list [myprioqueue peek 3] [myprioqueue get 3]]
    myprioqueue destroy
    set result
} [list [list a b c] [list a b c]]

test prioqueue-6.7 {get operation} {
    prioqueue myprioqueue
    catch {myprioqueue get 0} msg
    myprioqueue destroy
    set msg
} {invalid item count 0}

test prioqueue-6.8 {get operation} {
    prioqueue myprioqueue
    catch {myprioqueue get -1} msg
    myprioqueue destroy
    set msg
} {invalid item count -1}

test prioqueue-6.9 {get operation} {
    prioqueue myprioqueue
    catch {myprioqueue get} msg
    myprioqueue destroy
    set msg
} {insufficient items in prioqueue to fill request}

test prioqueue-6.10 {get operation} {
    prioqueue myprioqueue
    myprioqueue put a 1
    catch {myprioqueue get 2} msg
    myprioqueue destroy
    set msg
} {insufficient items in prioqueue to fill request}

test prioqueue-7.1 {clear operation} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 1
    myprioqueue put c 1
    set result [list [myprioqueue peek 3]]
    myprioqueue clear
    lappend result [myprioqueue size]
    myprioqueue destroy
    set result
} [list [list a b c] 0]

test prioqueue-8.1 {peekpriority operation} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 2
    myprioqueue put c 3
    set result [list [myprioqueue peekpriority] [myprioqueue peekpriority] [myprioqueue peekpriority]]
    myprioqueue destroy
    set result
} [list 3 3 3]

test prioqueue-8.2 {peekpriority operation, multiple items} {
    prioqueue myprioqueue
    myprioqueue put a 1
    myprioqueue put b 2
    myprioqueue put c 3
    set result [myprioqueue peekpriority 3]
    myprioqueue destroy
    set result
} [list 3 2 1]

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/queue.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
[manpage_begin queue n 1.2.1]
[moddesc   {Tcl Data Structures}]
[titledesc {Create and manipulate queue objects}]
[require Tcl 8.2]
[require struct [opt 1.3]]
[description]

The [cmd ::struct::queue] command creates a new queue object with an
associated global Tcl command whose name is [emph queueName].  This
command may be used to invoke various operations on the queue.  It has
the following general form:

[list_begin definitions]

[call [arg queueName] [cmd option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.  The following commands are possible for queue objects:


[call [arg queueName] [cmd clear]]

Remove all items from the queue.


[call [arg queueName] [cmd destroy]]

Destroy the queue, including its storage space and associated command.


[call [arg queueName] [cmd get] [opt "[arg count]"]]

Return the front [arg count] items of the queue and remove them from
the queue.  If [arg count] is not specified, it defaults to 1.  If
[arg count] is 1, the result is a simple string; otherwise, it is a
list.  If specified, [arg count] must be greater than or equal to 1.
If there are no items in the queue, this command will return

[arg count] empty strings.


[call [arg queueName] [cmd peek] [opt "[arg count]"]]

Return the front [arg count] items of the queue, without removing them
from the queue.  If [arg count] is not specified, it defaults to 1.
If [arg count] is 1, the result is a simple string; otherwise, it is a
list.  If specified, [arg count] must be greater than or equal to 1.
If there are no items in the queue, this command will return

[arg count] empty strings.


[call [arg queueName] [cmd put] [arg item] [opt "[arg "item ..."]"]]

Put the [arg item] or items specified into the queue.  If more than
one [arg item] is given, they will be added in the order they are
listed.


[call [arg queueName] [cmd size]]

Return the number of items in the queue.


[list_end]

[keywords stack matrix tree graph]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































Deleted modules/struct/queue.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: queue.n,v 1.6 2002/02/01 22:59:08 andreas_kupries Exp $
'\" 
.so man.macros
.TH queue n 1.2.1 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::queue \- Create and manipulate queue objects
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require struct ?1.2.1?\fR
.sp
\fB::struct::queue\fR \fIqueueName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::queue\fR command creates a new queue object with an
associated global Tcl command whose name is \fIqueueName\fR.  This command
may be used to invoke various operations on the queue.  It has the
following general form:
.CS
\fIqueueName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  The following
commands are possible for queue objects:
.TP
\fIqueueName \fBclear\fR
Remove all items from the queue.
.TP
\fIqueueName \fBdestroy\fR
Destroy the queue, including its storage space and associated command.
.TP
\fIqueueName \fBget\fR ?\fIcount\fR?
Return the front \fIcount\fR items of the queue and remove them
from the queue.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items in the queue, this command will return \fIcount\fR
empty strings.
.TP
\fIqueueName \fBpeek\fR ?\fIcount\fR?
Return the front \fIcount\fR items of the queue, without removing them
from the queue.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items in the queue, this command will return \fIcount\fR
empty strings.
.TP
\fIqueueName \fBput\fR \fIitem\fR ?\fIitem ...\fR?
Put the item or items specified into the queue.  If more than one
item is given, they will be added in the order they are listed.
.TP
\fIqueueName \fBsize\fR
Return the number of items in the queue.

.SH KEYWORDS
stack, queue
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































Deleted modules/struct/queue.tcl.

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

namespace eval ::struct {}

namespace eval ::struct::queue {
    # The queues array holds all of the queues you've made
    variable queues
    
    # counter is used to give a unique name for unnamed queues
    variable counter 0

    # commands is the list of subcommands recognized by the queue
    variable commands [list \
	    "clear"	\
	    "destroy"	\
	    "get"	\
	    "peek"	\
	    "put"	\
	    "size"	\
	    ]

    # Only export one command, the one used to instantiate a new queue
    namespace export queue
}

# ::struct::queue::queue --
#
#	Create a new queue with a given name; if no name is given, use
#	queueX, where X is a number.
#
# Arguments:
#	name	name of the queue; if null, generate one.
#
# Results:
#	name	name of the queue created

proc ::struct::queue::queue {{name ""}} {
    variable queues
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "queue${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create queue"
    }

    # Initialize the queue as empty
    set queues($name) [list ]

    # Create the command to manipulate the queue
    interp alias {} ::$name {} ::struct::queue::QueueProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::queue::QueueProc --
#
#	Command that processes all queue object commands.
#
# Arguments:
#	name	name of the queue object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::queue::QueueProc {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 { [string equal [info commands ::struct::queue::_$cmd] ""] } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    return [eval [list ::struct::queue::_$cmd $name] $args]
}

# ::struct::queue::_clear --
#
#	Clear a queue.
#
# Arguments:
#	name	name of the queue object.
#
# Results:
#	None.

proc ::struct::queue::_clear {name} {
    variable queues
    set queues($name) [list ]
    return
}

# ::struct::queue::_destroy --
#
#	Destroy a queue object by removing it's storage space and 
#	eliminating it's proc.
#
# Arguments:
#	name	name of the queue object.
#
# Results:
#	None.

proc ::struct::queue::_destroy {name} {
    variable queues
    unset queues($name)
    interp alias {} ::$name {}
    return
}

# ::struct::queue::_get --
#
#	Get an item from a queue.
#
# Arguments:
#	name	name of the queue object.
#	count	number of items to get; defaults to 1
#
# Results:
#	item	first count items from the queue; if there are not enough 
#		items in the queue, throws an error.

proc ::struct::queue::_get {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in queue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item gets aren't listified
	set item [lindex $queues($name) 0]
	set queues($name) [lreplace $queues($name) 0 0]
	return $item
    }

    # Otherwise, return a list of items
    set index [expr {$count - 1}]
    set result [lrange $queues($name) 0 $index]
    set queues($name) [lreplace $queues($name) 0 $index]

    return $result
}

# ::struct::queue::_peek --
#
#	Retrive the value of an item on the queue without removing it.
#
# Arguments:
#	name	name of the queue object.
#	count	number of items to peek; defaults to 1
#
# Results:
#	items	top count items from the queue; if there are not enough items
#		to fufill the request, throws an error.

proc ::struct::queue::_peek {name {count 1}} {
    variable queues
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $queues($name)] } {
	error "insufficient items in queue to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	return [lindex $queues($name) 0]
    }

    # Otherwise, return a list of items
    set index [expr {$count - 1}]
    return [lrange $queues($name) 0 $index]
}

# ::struct::queue::_put --
#
#	Put an item into a queue.
#
# Arguments:
#	name	name of the queue object
#	args	items to put.
#
# Results:
#	None.

proc ::struct::queue::_put {name args} {
    variable queues
    if { [llength $args] == 0 } {
	error "wrong # args: should be \"$name put item ?item ...?\""
    }
    foreach item $args {
	lappend queues($name) $item
    }
    return
}

# ::struct::queue::_size --
#
#	Return the number of objects on a queue.
#
# Arguments:
#	name	name of the queue object.
#
# Results:
#	count	number of items on the queue.

proc ::struct::queue::_size {name} {
    variable queues
    return [llength $queues($name)]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































Deleted modules/struct/queue.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] queue.tcl]
namespace import struct::queue::queue

test queue-0.1 {queue errors} {
    queue myqueue
    catch {queue myqueue} msg
    myqueue destroy
    set msg
} "command \"myqueue\" already exists, unable to create queue"
test queue-0.2 {queue errors} {
    queue myqueue
    catch {myqueue} msg
    myqueue destroy
    set msg
} "wrong # args: should be \"myqueue option ?arg arg ...?\""
test queue-0.3 {queue errors} {
    queue myqueue
    catch {myqueue foo} msg
    myqueue destroy
    set msg
} "bad option \"foo\": must be clear, destroy, get, peek, put, or size"
test queue-0.4 {queue errors} {
    catch {queue set} msg
    set msg
} "command \"set\" already exists, unable to create queue"

test queue-1.1 {queue creation} {
    set foo [queue myqueue]
    set cmd [info commands ::myqueue]
    set size [myqueue size]
    myqueue destroy
    list $foo $cmd $size
} {myqueue ::myqueue 0}
test queue-1.2 {queue creation} {
    set foo [queue]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {queue1 ::queue1 0}

test queue-2.1 {queue destroy} {
    queue myqueue
    myqueue destroy
    info commands ::myqueue
} {}

test queue-3.2 {size operation} {
    queue myqueue
    myqueue put a b c d e f g
    set size [myqueue size]
    myqueue destroy
    set size
} 7
test queue-3.3 {size operation} {
    queue myqueue
    myqueue put a b c d e f g
    myqueue get 3
    set size [myqueue size]
    myqueue destroy
    set size
} 4
test queue-3.4 {size operation} {
    queue myqueue
    myqueue put a b c d e f g
    myqueue get 3
    myqueue peek 3
    set size [myqueue size]
    myqueue destroy
    set size
} 4
    
test queue-4.1 {put operation} {
    queue myqueue
    catch {myqueue put} msg
    myqueue destroy
    set msg
} "wrong # args: should be \"myqueue put item ?item ...?\""
test queue-4.2 {put operation, singleton items} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} "a b c"
test queue-4.3 {put operation, multiple items} {
    queue myqueue
    myqueue put a b c
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} "a b c"
test queue-4.4 {put operation, spaces in items} {
    queue myqueue
    myqueue put a b "foo bar"
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} [list a b "foo bar"]
test queue-4.5 {put operation, bad chars in items} {
    queue myqueue
    myqueue put a b \{
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} [list a b \{]

test queue-5.1 {get operation} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue get] [myqueue get] [myqueue get]]
    myqueue destroy
    set result
} [list a b c]
test queue-5.2 {get operation, multiple items} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [myqueue get 3]
    myqueue destroy
    set result
} [list a b c]

test queue-6.1 {peek operation} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue peek] [myqueue peek] [myqueue peek]]
    myqueue destroy
    set result
} [list a a a]

test queue-6.2 {peek operation} {
    queue myqueue
    catch {myqueue peek 0} msg
    myqueue destroy
    set msg
} {invalid item count 0}
test queue-6.3 {peek operation} {
    queue myqueue
    catch {myqueue peek -1} msg
    myqueue destroy
    set msg
} {invalid item count -1}
test queue-6.4 {peek operation} {
    queue myqueue
    catch {myqueue peek} msg
    myqueue destroy
    set msg
} {insufficient items in queue to fill request}
test queue-6.5 {peek operation} {
    queue myqueue
    myqueue put a
    catch {myqueue peek 2} msg
    myqueue destroy
    set msg
} {insufficient items in queue to fill request}

test queue-6.6 {get operation, multiple items} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue peek 3] [myqueue get 3]]
    myqueue destroy
    set result
} [list [list a b c] [list a b c]]

test queue-6.7 {get operation} {
    queue myqueue
    catch {myqueue get 0} msg
    myqueue destroy
    set msg
} {invalid item count 0}
test queue-6.8 {get operation} {
    queue myqueue
    catch {myqueue get -1} msg
    myqueue destroy
    set msg
} {invalid item count -1}
test queue-6.9 {get operation} {
    queue myqueue
    catch {myqueue get} msg
    myqueue destroy
    set msg
} {insufficient items in queue to fill request}
test queue-6.10 {get operation} {
    queue myqueue
    myqueue put a
    catch {myqueue get 2} msg
    myqueue destroy
    set msg
} {insufficient items in queue to fill request}



test queue-7.1 {clear operation} {
    queue myqueue
    myqueue put a
    myqueue put b
    myqueue put c
    set result [list [myqueue peek 3]]
    myqueue clear
    lappend result [myqueue size]
    myqueue destroy
    set result
} [list [list a b c] 0]

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































Deleted modules/struct/record.html.

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

<h1> record(n) 1.2.1 record &quot;Tcl Data Structures&quot;</h1>
<a name="name"><h2>NAME</h2>
<p> record - Define and create records (similar to 'C' structures)
<! -- -*- tcl -*- -->
<! -- Author: Brett Schwarz &lt;[email protected]&gt; -->


<a name="synopsis"><h2>SYNOPSIS</h2>
package require <b>Tcl 8.2</b><br>
package require <b>struct ?1.2.1?</b><br>
<br><table border=1 width=100% cellspacing=0 cellpadding=0><tr            bgcolor=lightyellow><td bgcolor=lightyellow><table 0 width=100% cellspacing=0 cellpadding=0><tr valign=top ><td ><b class='cmd'>record define</b> <i class='arg'>recordName</i> <i class='arg'>recordMembers</i> ?<i class='arg'>instanceName1 instanceName2 ...</i>?</td></tr>
<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>record</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>instances</i> <i class='arg'>recordName</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>members</i> <i class='arg'>recordName</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record show</b> <i class='arg'>values</i> <i class='arg'>instanceName</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record exists</b> <i class='arg'>record</i> <i class='arg'>recordName</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record exists</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record delete</b> <i class='arg'>record</i> <i class='arg'>recordName</i></td></tr>
<tr valign=top ><td ><b class='cmd'>record delete</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i></td></tr>
<tr valign=top ><td ><i class='arg'>recordName</i> <strong><i class='arg'>instanceName|#auto</i></strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?</td></tr>
<tr valign=top ><td ><i class='arg'>instanceName</i> <strong>cget</strong> ?<i class='arg'>-member1 -member2 ...</i>?</td></tr>
<tr valign=top ><td ><i class='arg'>instanceName</i> <strong>configure</strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?</td></tr>
</table></td></tr></table>
<a name="description"><h2>DESCRIPTION</h2>

The <b class='cmd'>::struct::record</b> package provides a mechanism to group variables together
as one data structure, similar to a 'C' structure. The members of a 
record can be variables or other records. However, a record can not contain circular
record, i.e. records that contain the same record as a
member.

<p>
This package was structured so that it is very similar to how Tk objects work. Each record
definition creates a record object that encompasses that definition. Subsequently, that
record object can create instances of that record. These instances can then
be manipulated with the <strong>cget</strong> and <strong>configure</strong> methods.

<p>
The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified.

<dl>

<dt><b class='cmd'>record define</b> <i class='arg'>recordName</i> <i class='arg'>recordMembers</i> ?<i class='arg'>instanceName1 instanceName2 ...</i>?<dd>


Defines a record. <i class='arg'>recordName</i> is the name of the record, and is also
used as an object command. This object command is used to create instances of the
record definition. <i class='arg'>recordMembers</i> are the members of
the record that make up the record definition. These are variables
and other record. If optional <i class='arg'>instanceName</i> args are given, then an instance
is generated after the definition is created for each <i class='arg'>instanceName</i>.

<br><br>
<dt><b class='cmd'>record show</b> <i class='arg'>record</i><dd>


Returns a list of records that have been defined.

<br><br>
<dt><b class='cmd'>record show</b> <i class='arg'>instances</i> <i class='arg'>recordName</i><dd>


Returns the instances that have been instantiated by
<i class='arg'>recordName</i>.

<br><br>
<dt><b class='cmd'>record show</b> <i class='arg'>members</i> <i class='arg'>recordName</i><dd>


Returns the members that are defined for
record <i class='arg'>recordName</i>. It returns the same format as how the
records were defined.

<br><br>
<dt><b class='cmd'>record show</b> <i class='arg'>values</i> <i class='arg'>instanceName</i><dd>


Returns a list of values that are set for the instance
<i class='arg'>instanceName</i>. The output is a list of key/value pairs. If there
are nested records, then the values of the nested records will 
itself be a list.

<br><br>
<dt><b class='cmd'>record exists</b> <i class='arg'>record</i> <i class='arg'>recordName</i><dd>


Tests for the existence of a <i class='arg'>record</i> with the
name <i class='arg'>recordName</i>.

<br><br>
<dt><b class='cmd'>record exists</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i><dd>


Tests for the existence of a <i class='arg'>instance</i> with the
name <i class='arg'>instanceName</i>.

<br><br>
<dt><b class='cmd'>record delete</b> <i class='arg'>record</i> <i class='arg'>recordName</i><dd>


Deletes <i class='arg'>recordName</i>, and all instances of <i class='arg'>recordName</i>. It will return
an error if the record does not exist.

<br><br>
<dt><b class='cmd'>record delete</b> <i class='arg'>instance</i> <i class='arg'>instanceName</i><dd>


Deletes <i class='arg'>instance</i> with the name of <i class='arg'>instanceName</i>. It
will return an error if the instance does not exist.

</dl>
<p>
      
<a name="recordmembers"><h2>RECORD MEMBERS</h2>

Record members can either be variables, or other records, However, the same
record can not be nested witin itself (circular). To define a nested record,
you need to specify the <strong>record</strong> keyword, along the with name of the record, and the name of the instance of that nested
record. For example, it would look like this:

<p>
<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>
# this is the nested record
record define mynestedrecord {
    nest1
    nest2
}

# This is the main record
record define myrecord {
    mem1
    mem2
    {record mynestedrecord mem3}
}

</pre></td></tr></table></p>

You can also assign default or initial values to the members of a record,
by enclosing the member entry in braces:

<p>
<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>

record define myrecord {
    mem1
    {mem2 5}
}

</pre></td></tr></table></p>

All instances created from this record definition, will initially have 5 as
the value for <i class='arg'>mem2</i>. If no default is given, then the value will be the empty string.

<p>
<strong>Getting Values</strong>
<p>

To get a value of a member, there are several ways to do this. 

<ol>

<li>
To get a member value, then use the instance built-in <strong>cget</strong> method:
<br><br>
    <i class='arg'>instanceName</i> <strong>cget</strong> -mem1

<br><br>
<li>
To get multiple member values, you can specify them all in one command:
<br><br>
    <i class='arg'>instanceName</i> <strong>cget</strong> -mem1 -mem2

<br><br>
<li>
To get a list of the key/value of all of the members, there are 3 ways:
<br><br>
    - <i class='arg'>instanceName</i> <strong>cget</strong>
<br><br>
	- <i class='arg'>instanceName</i> <strong>configure</strong>
<br><br>
	- <i class='arg'>instanceName</i>

<br><br>
<li>
To get a value of a nested member, then use the dot notation:
<br><br>
    <i class='arg'>instanceName</i> <strong>cget</strong> -mem3.nest1

</ol>

<p>
<strong>Setting Values</strong>
<p>

To set a value of a member, there are several ways to do this. 

<ol>

<li>
To set a member value, then use the instance built-in <strong>configure</strong> method:
<br><br>
    <i class='arg'>instanceName</i> <strong>configure</strong> -mem1 val1

<br><br>
<li>
To set multiple member values, you can specify them all in one command:
<br><br>
    <i class='arg'>instanceName</i> <strong>configure</strong> -mem1 va1 -mem2 val2

<br><br>
<li>
To set a value of a nested member, then use the dot notation:
<br><br>
    <i class='arg'>instanceName</i> <strong>configure</strong> -mem3.nest1 value

</ol>

<p>
<strong>Alias access</strong>
<p>

In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, 
there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still
exists. It might prove to be helpful to some.

<p>
Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that
member. An example will illustrate the point, using the above defined records:

<p>
<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>
# Create an instance first
% myrecord inst1
::inst1
% # To get a member of an instance, just use the 
% # alias (it behaves like a Tcl command):
% inst1.mem1
%
% # To set a member via the alias, just include 
% # a value (optionally the equal sign - syntactic sugar)
% inst1.mem1 = 5
5
% inst1.mem1
5
% # For nested records, just continue with the 
% # dot notation (note no equal sign)
% inst1.mem3.nest1 10
10
% inst1.mem3.nest1
10
% # just the instance by itself gives all 
% # member/values pairs for that instance
% inst1
-mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}}
% # and to get all members within the nested record
% inst1.mem3
-nest1 10 -nest2 {}
%

</pre></td></tr></table></p>

<a name="recordcommand"><h2>RECORD COMMAND</h2>

The following subcommands and corresponding arguments are available to any
record command:

<dl>

<dt><i class='arg'>recordName</i> <strong><i class='arg'>instanceName|#auto</i></strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?<dd>


Using the <i class='arg'>recordName</i> object command that was created from the record definition, 
instances of the record definition can be created. Once a instance is
created, then it inherits the members of the record definition, very
similar to how objects work. During instance generation, an object command for the instance
is created as well, using <i class='arg'>instanceName</i>. This object command is used
to access the data members of the instance. During the instantiation, values for
that instance can be given, <strong>but</strong> all values must be given, and be given
in key/value pairs. Nested records, need to be in list format.

<br><br>
Optionally, <i class='arg'>#auto</i> can be used in place of <i class='arg'>instanceName</i>. When #auto is used,
then a instance name will automatically be generated, of the form recordName&lt;integer&gt;, where
&lt;integer&gt; is a unique integer (starting at 0) that is generated.

</dl>
<p>

<a name="instancecommand"><h2>INSTANCE COMMAND</h2>
 
The following subcommands and corresponding arguments are available to
any record instance command:

<dl>
 
<dt><i class='arg'>instanceName</i> <strong>cget</strong> ?<i class='arg'>-member1 -member2 ...</i>?<dd>


Each instance has the sub command <strong>cget</strong> associated with it. This
is very similar to how Tk widget's cget command works. It queries
the values of the member for that particular instance. If
no arguments are given, then a key/value list is returned.

<br><br>
<dt><i class='arg'>instanceName</i> <strong>configure</strong> ?<i class='arg'>-member1 value1 -member2 value2 ...</i>?<dd>


Each instance has the sub command <strong>configure</strong> associated with it. This
is very similar to how Tk widget's configure command works. It sets
the values of the particular member for that particular instance. If
no arguments are given, then a key/value list is returned.

</dl>

<a name="examples"><h2>EXAMPLES</h2>
 
Two examples are provided to give an good illustration on how to use
this package.

<p>      
<strong>Example 1</strong>
<p>

Probably the most obvious example would be to hold contact information,
such as addresses, phone numbers, comments, etc. Since a person can have
multiple phone numbers, multiple email addresses, etc, we will use nested
records to define these. So, the first thing we do is define the nested
records:

<p>
<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>

##
##  This is an interactive example, to see what is 
##  returned by each command as well.
##

% namespace import ::struct::record::*

% # define a nested record. Notice that country has default 'USA'.
% record define locations {
    street
    street2
    city
    state
    zipcode
    {country USA}
    phone
}
::locations
% # Define the main record. Notice that it uses the location record twice.
% record define contacts {
    first 
    middle 
    last 
    {record locations home}
    {record locations work}
}
::contacts
% # Create an instance for the contacts record.
% contacts cont1
::cont1
% # Display some introspection values
% record show records
::contacts ::locations
% #
% record show values cont1
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% #
% record show instances contacts
::cont1
% #
% cont1 config
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% #
% cont1 cget
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% # copy one record to another record
% record define contacts2 [record show members contacts]
::contacts2
% record show members contacts2
first middle last {record locations home} {record locations work}
% record show members contacts
first middle last {record locations home} {record locations work}
%
</pre></td></tr></table></p>

<p>      
<strong>Example 1</strong>
<p>

This next example just illustrates a simple linked list
<p>
<p><table><tr><td bgcolor=black>&nbsp;</td><td><pre class='sample'>

% # define a very simple record for linked list
% record define llist {
    value
    next
}
::llist
% llist lstart
::lstart
% lstart config -value 1 -next [llist #auto]
% [lstart cget -next] config -value 2 -next [llist #auto]
% [[lstart cget -next] cget -next] config -value 3 -next &quot;end&quot;
% set next lstart
lstart
% while 1 {
lappend values [$next cget -value]
set next [$next cget -next]
if {[string match &quot;end&quot; $next]} {break}
}
% puts &quot;$values&quot;
1 2 3
% # cleanup linked list
% # We could just use delete record llist also
% foreach I [record show instances llist] {
record delete instance $I
}
% record show instances llist
%

</pre></td></tr></table></p>

<p>

<a name="keywords"><h2>KEYWORDS</h2>
struct, record, data structures
</body></html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/record.man.

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

The [cmd ::struct::record] package provides a mechanism to group variables together
as one data structure, similar to a 'C' structure. The members of a 
record can be variables or other records. However, a record can not contain circular
record, i.e. records that contain the same record as a
member.

[para]
This package was structured so that it is very similar to how Tk objects work. Each record
definition creates a record object that encompasses that definition. Subsequently, that
record object can create instances of that record. These instances can then
be manipulated with the [method cget] and [method configure] methods.

[para]
The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified.

[list_begin definitions]

[call [cmd {record define}] [arg recordName] [arg recordMembers] [opt [arg "instanceName1 instanceName2 ..."]]]

Defines a record. [arg recordName] is the name of the record, and is also
used as an object command. This object command is used to create instances of the
record definition. [arg recordMembers] are the members of
the record that make up the record definition. These are variables
and other record. If optional [arg instanceName] args are given, then an instance
is generated after the definition is created for each [arg instanceName].

[call [cmd {record show}] [arg record]]

Returns a list of records that have been defined.

[call [cmd {record show}] [arg instances] [arg recordName]]

Returns the instances that have been instantiated by
[arg recordName].

[call [cmd {record show}] [arg members] [arg recordName]]

Returns the members that are defined for
record [arg recordName]. It returns the same format as how the
records were defined.

[call [cmd {record show}] [arg values] [arg instanceName]]

Returns a list of values that are set for the instance
[arg instanceName]. The output is a list of key/value pairs. If there
are nested records, then the values of the nested records will 
itself be a list.

[call [cmd {record exists}] [arg record] [arg recordName]]

Tests for the existence of a [arg record] with the
name [arg recordName].

[call [cmd {record exists}] [arg instance] [arg instanceName]]

Tests for the existence of a [arg instance] with the
name [arg instanceName].

[call [cmd {record delete}] [arg record] [arg recordName]]

Deletes [arg recordName], and all instances of [arg recordName]. It will return
an error if the record does not exist.

[call [cmd {record delete}] [arg instance] [arg instanceName]]

Deletes [arg instance] with the name of [arg instanceName]. It
will return an error if the instance does not exist.

[list_end]
[para]
      
[section {RECORD MEMBERS}]

Record members can either be variables, or other records, However, the
same record can not be nested witin itself (circular). To define a
nested record, you need to specify the [const record] keyword, along
the with name of the record, and the name of the instance of that
nested record. For example, it would look like this:

[para]
[example_begin]
# this is the nested record
record define mynestedrecord {
    nest1
    nest2
}

# This is the main record
record define myrecord {
    mem1
    mem2
    {record mynestedrecord mem3}
}

[example_end]

You can also assign default or initial values to the members of a record,
by enclosing the member entry in braces:

[para]
[example_begin]

record define myrecord {
    mem1
    {mem2 5}
}

[example_end]

All instances created from this record definition, will initially have 5 as
the value for [arg mem2]. If no default is given, then the value will be the empty string.

[para]
[emph {Getting Values}]
[para]

To get a value of a member, there are several ways to do this. 

[list_begin enum]

[enum]
To get a member value, then use the instance built-in [method cget] method:
[nl]
    [arg instanceName] [method cget] -mem1

[enum]
To get multiple member values, you can specify them all in one command:
[nl]
    [arg instanceName] [method cget] -mem1 -mem2

[enum]
To get a list of the key/value of all of the members, there are 3 ways:
[nl]
    - [arg instanceName] [method cget]
[nl]
	- [arg instanceName] [method configure]
[nl]
	- [arg instanceName]

[enum]
To get a value of a nested member, then use the dot notation:
[nl]
    [arg instanceName] [method cget] -mem3.nest1

[list_end]

[para]
[emph {Setting Values}]
[para]

To set a value of a member, there are several ways to do this. 

[list_begin enum]

[enum]
To set a member value, then use the instance built-in [method configure] method:
[nl]
    [arg instanceName] [method configure] -mem1 val1

[enum]
To set multiple member values, you can specify them all in one command:
[nl]
    [arg instanceName] [method configure] -mem1 va1 -mem2 val2

[enum]
To set a value of a nested member, then use the dot notation:
[nl]
    [arg instanceName] [method configure] -mem3.nest1 value

[list_end]

[para]
[emph {Alias access}]
[para]

In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However, 
there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still
exists. It might prove to be helpful to some.

[para]
Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that
member. An example will illustrate the point, using the above defined records:

[para]
[example_begin]
# Create an instance first
% myrecord inst1
::inst1
% # To get a member of an instance, just use the 
% # alias (it behaves like a Tcl command):
% inst1.mem1
%
% # To set a member via the alias, just include 
% # a value (optionally the equal sign - syntactic sugar)
% inst1.mem1 = 5
5
% inst1.mem1
5
% # For nested records, just continue with the 
% # dot notation (note no equal sign)
% inst1.mem3.nest1 10
10
% inst1.mem3.nest1
10
% # just the instance by itself gives all 
% # member/values pairs for that instance
% inst1
-mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}}
% # and to get all members within the nested record
% inst1.mem3
-nest1 10 -nest2 {}
%

[example_end]

[section {RECORD COMMAND}]

The following subcommands and corresponding arguments are available to any
record command:

[list_begin definitions]

[call [arg recordName] [method [arg instanceName|#auto]] [opt [arg "-member1 value1 -member2 value2 ..."]]]

Using the [arg recordName] object command that was created from the record definition, 
instances of the record definition can be created. Once a instance is
created, then it inherits the members of the record definition, very
similar to how objects work. During instance generation, an object command for the instance
is created as well, using [arg instanceName]. This object command is used
to access the data members of the instance. During the instantiation, values for
that instance can be given, [emph but] all values must be given, and be given
in key/value pairs. Nested records, need to be in list format.

[nl]
Optionally, [arg #auto] can be used in place of [arg instanceName]. When #auto is used,
then a instance name will automatically be generated, of the form recordName<integer>, where
<integer> is a unique integer (starting at 0) that is generated.

[list_end]
[para]

[section {INSTANCE COMMAND}]
 
The following subcommands and corresponding arguments are available to
any record instance command:

[list_begin definitions]
 
[call [arg instanceName] [method cget] [opt [arg "-member1 -member2 ..."]]]

Each instance has the sub command [method cget] associated with it. This
is very similar to how Tk widget's cget command works. It queries
the values of the member for that particular instance. If
no arguments are given, then a key/value list is returned.

[call [arg instanceName] [method configure] [opt [arg "-member1 value1 -member2 value2 ..."]]]

Each instance has the sub command [method configure] associated with it. This
is very similar to how Tk widget's configure command works. It sets
the values of the particular member for that particular instance. If
no arguments are given, then a key/value list is returned.

[list_end]

[section EXAMPLES]
 
Two examples are provided to give an good illustration on how to use
this package.

[para]      
[emph {Example 1}]
[para]

Probably the most obvious example would be to hold contact information,
such as addresses, phone numbers, comments, etc. Since a person can have
multiple phone numbers, multiple email addresses, etc, we will use nested
records to define these. So, the first thing we do is define the nested
records:

[para]
[example {

##
##  This is an interactive example, to see what is 
##  returned by each command as well.
##

% namespace import ::struct::record::*

% # define a nested record. Notice that country has default 'USA'.
% record define locations {
    street
    street2
    city
    state
    zipcode
    {country USA}
    phone
}
::locations
% # Define the main record. Notice that it uses the location record twice.
% record define contacts {
    first 
    middle 
    last 
    {record locations home}
    {record locations work}
}
::contacts
% # Create an instance for the contacts record.
% contacts cont1
::cont1
% # Display some introspection values
% record show records
::contacts ::locations
% #
% record show values cont1
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% #
% record show instances contacts
::cont1
% #
% cont1 config
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% #
% cont1 cget
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% # copy one record to another record
% record define contacts2 [record show members contacts]
::contacts2
% record show members contacts2
first middle last {record locations home} {record locations work}
% record show members contacts
first middle last {record locations home} {record locations work}
%
}]

[para]      
[emph {Example 1}]
[para]

This next example just illustrates a simple linked list
[para]
[example {

% # define a very simple record for linked list
% record define llist {
    value
    next
}
::llist
% llist lstart
::lstart
% lstart config -value 1 -next [llist #auto]
% [lstart cget -next] config -value 2 -next [llist #auto]
% [[lstart cget -next] cget -next] config -value 3 -next "end"
% set next lstart
lstart
% while 1 {
lappend values [$next cget -value]
set next [$next cget -next]
if {[string match "end" $next]} {break}
}
% puts "$values"
1 2 3
% # cleanup linked list
% # We could just use delete record llist also
% foreach I [record show instances llist] {
record delete instance $I
}
% record show instances llist
%

}]

[para]

[keywords struct record {data structures}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/record.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
'\"
'\" Generated from record.man by mpexpand with fmt.nroff
'\"
.so man.macros
.TH "record" n 1.2.1 record "Tcl Data Structures"
.BS
.SH NAME
record \- Define and create records (similar to 'C' structures)
'\" -*- tcl -*-
'\" Author: Brett Schwarz <[email protected]>
.SH "SYNOPSIS"
package require \fBTcl 8.2\fR
.sp
package require \fBstruct ?1.2.1?\fR
.sp
\fBrecord define\fR \fIrecordName\fR \fIrecordMembers\fR ?\fIinstanceName1 instanceName2 ...\fR?\fR
.sp
\fBrecord show\fR \fIrecord\fR\fR
.sp
\fBrecord show\fR \fIinstances\fR \fIrecordName\fR\fR
.sp
\fBrecord show\fR \fImembers\fR \fIrecordName\fR\fR
.sp
\fBrecord show\fR \fIvalues\fR \fIinstanceName\fR\fR
.sp
\fBrecord exists\fR \fIrecord\fR \fIrecordName\fR\fR
.sp
\fBrecord exists\fR \fIinstance\fR \fIinstanceName\fR\fR
.sp
\fBrecord delete\fR \fIrecord\fR \fIrecordName\fR\fR
.sp
\fBrecord delete\fR \fIinstance\fR \fIinstanceName\fR\fR
.sp
\fIrecordName\fR \fB\fIinstanceName|#auto\fR\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR
.sp
\fIinstanceName\fR \fBcget\fR ?\fI-member1 -member2 ...\fR?\fR
.sp
\fIinstanceName\fR \fBconfigure\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR
.sp
.BE
.SH "DESCRIPTION"
The \fB::struct::record\fR package provides a mechanism to group variables together
as one data structure, similar to a 'C' structure. The members of a
record can be variables or other records. However, a record can not contain circular
record, i.e. records that contain the same record as a
member.
.PP
This package was structured so that it is very similar to how Tk objects work. Each record
definition creates a record object that encompasses that definition. Subsequently, that
record object can create instances of that record. These instances can then
be manipulated with the \fBcget\fR and \fBconfigure\fR methods.
.PP
The package only contains one top level command, but several sub commands (see below). It also obeys the namespace in which the record was define, hence the objects returned are fully qualified.
.TP
\fBrecord define\fR \fIrecordName\fR \fIrecordMembers\fR ?\fIinstanceName1 instanceName2 ...\fR?\fR
Defines a record. \fIrecordName\fR is the name of the record, and is also
used as an object command. This object command is used to create instances of the
record definition. \fIrecordMembers\fR are the members of
the record that make up the record definition. These are variables
and other record. If optional \fIinstanceName\fR args are given, then an instance
is generated after the definition is created for each \fIinstanceName\fR.
.TP
\fBrecord show\fR \fIrecord\fR\fR
Returns a list of records that have been defined.
.TP
\fBrecord show\fR \fIinstances\fR \fIrecordName\fR\fR
Returns the instances that have been instantiated by
\fIrecordName\fR.
.TP
\fBrecord show\fR \fImembers\fR \fIrecordName\fR\fR
Returns the members that are defined for
record \fIrecordName\fR. It returns the same format as how the
records were defined.
.TP
\fBrecord show\fR \fIvalues\fR \fIinstanceName\fR\fR
Returns a list of values that are set for the instance
\fIinstanceName\fR. The output is a list of key/value pairs. If there
are nested records, then the values of the nested records will
itself be a list.
.TP
\fBrecord exists\fR \fIrecord\fR \fIrecordName\fR\fR
Tests for the existence of a \fIrecord\fR with the
name \fIrecordName\fR.
.TP
\fBrecord exists\fR \fIinstance\fR \fIinstanceName\fR\fR
Tests for the existence of a \fIinstance\fR with the
name \fIinstanceName\fR.
.TP
\fBrecord delete\fR \fIrecord\fR \fIrecordName\fR\fR
Deletes \fIrecordName\fR, and all instances of \fIrecordName\fR. It will return
an error if the record does not exist.
.TP
\fBrecord delete\fR \fIinstance\fR \fIinstanceName\fR\fR
Deletes \fIinstance\fR with the name of \fIinstanceName\fR. It
will return an error if the instance does not exist.
.PP
.SH "RECORD MEMBERS"
Record members can either be variables, or other records, However, the same
record can not be nested witin itself (circular). To define a nested record,
you need to specify the \fBrecord\fR keyword, along the with name of the record, and the name of the instance of that nested
record. For example, it would look like this:
.PP
.nf
# this is the nested record
record define mynestedrecord {
    nest1
    nest2
}

# This is the main record
record define myrecord {
    mem1
    mem2
    {record mynestedrecord mem3}
}

.fi
You can also assign default or initial values to the members of a record,
by enclosing the member entry in braces:
.PP
.nf

record define myrecord {
    mem1
    {mem2 5}
}

.fi
All instances created from this record definition, will initially have 5 as
the value for \fImem2\fR. If no default is given, then the value will be the empty string.
.PP
\fBGetting Values\fR
.PP
To get a value of a member, there are several ways to do this.
.IP [1]
To get a member value, then use the instance built-in \fBcget\fR method:
.sp
\fIinstanceName\fR \fBcget\fR -mem1
.IP [2]
To get multiple member values, you can specify them all in one command:
.sp
\fIinstanceName\fR \fBcget\fR -mem1 -mem2
.IP [3]
To get a list of the key/value of all of the members, there are 3 ways:
.sp
- \fIinstanceName\fR \fBcget\fR
.sp
- \fIinstanceName\fR \fBconfigure\fR
.sp
- \fIinstanceName\fR
.IP [4]
To get a value of a nested member, then use the dot notation:
.sp
\fIinstanceName\fR \fBcget\fR -mem3.nest1
.PP
\fBSetting Values\fR
.PP
To set a value of a member, there are several ways to do this.
.IP [1]
To set a member value, then use the instance built-in \fBconfigure\fR method:
.sp
\fIinstanceName\fR \fBconfigure\fR -mem1 val1
.IP [2]
To set multiple member values, you can specify them all in one command:
.sp
\fIinstanceName\fR \fBconfigure\fR -mem1 va1 -mem2 val2
.IP [3]
To set a value of a nested member, then use the dot notation:
.sp
\fIinstanceName\fR \fBconfigure\fR -mem3.nest1 value
.PP
\fBAlias access\fR
.PP
In the original implementation, access was done by using dot notation similar to how 'C' structures are accessed. However,
there was a concensus to make the interface more Tcl like, which made sense. However, the original alias access still
exists. It might prove to be helpful to some.
.PP
Basically, for every member of every instance, an alias is created. This alias is used to get and set values for that
member. An example will illustrate the point, using the above defined records:
.PP
.nf
# Create an instance first
% myrecord inst1
::inst1
% # To get a member of an instance, just use the 
% # alias (it behaves like a Tcl command):
% inst1.mem1
%
% # To set a member via the alias, just include 
% # a value (optionally the equal sign - syntactic sugar)
% inst1.mem1 = 5
5
% inst1.mem1
5
% # For nested records, just continue with the 
% # dot notation (note no equal sign)
% inst1.mem3.nest1 10
10
% inst1.mem3.nest1
10
% # just the instance by itself gives all 
% # member/values pairs for that instance
% inst1
-mem1 5 -mem2 {} -mem3 {-nest1 10 -nest2 {}}
% # and to get all members within the nested record
% inst1.mem3
-nest1 10 -nest2 {}
%

.fi
.SH "RECORD COMMAND"
The following subcommands and corresponding arguments are available to any
record command:
.TP
\fIrecordName\fR \fB\fIinstanceName|#auto\fR\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR
Using the \fIrecordName\fR object command that was created from the record definition,
instances of the record definition can be created. Once a instance is
created, then it inherits the members of the record definition, very
similar to how objects work. During instance generation, an object command for the instance
is created as well, using \fIinstanceName\fR. This object command is used
to access the data members of the instance. During the instantiation, values for
that instance can be given, \fBbut\fR all values must be given, and be given
in key/value pairs. Nested records, need to be in list format.
.sp
Optionally, \fI#auto\fR can be used in place of \fIinstanceName\fR. When #auto is used,
then a instance name will automatically be generated, of the form recordName<integer>, where
<integer> is a unique integer (starting at 0) that is generated.
.PP
.SH "INSTANCE COMMAND"
The following subcommands and corresponding arguments are available to
any record instance command:
.TP
\fIinstanceName\fR \fBcget\fR ?\fI-member1 -member2 ...\fR?\fR
Each instance has the sub command \fBcget\fR associated with it. This
is very similar to how Tk widget's cget command works. It queries
the values of the member for that particular instance. If
no arguments are given, then a key/value list is returned.
.TP
\fIinstanceName\fR \fBconfigure\fR ?\fI-member1 value1 -member2 value2 ...\fR?\fR
Each instance has the sub command \fBconfigure\fR associated with it. This
is very similar to how Tk widget's configure command works. It sets
the values of the particular member for that particular instance. If
no arguments are given, then a key/value list is returned.
.SH "EXAMPLES"
Two examples are provided to give an good illustration on how to use
this package.
.PP
\fBExample 1\fR
.PP
Probably the most obvious example would be to hold contact information,
such as addresses, phone numbers, comments, etc. Since a person can have
multiple phone numbers, multiple email addresses, etc, we will use nested
records to define these. So, the first thing we do is define the nested
records:
.PP
.nf

##
##  This is an interactive example, to see what is 
##  returned by each command as well.
##

% namespace import ::struct::record::*

% # define a nested record. Notice that country has default 'USA'.
% record define locations {
    street
    street2
    city
    state
    zipcode
    {country USA}
    phone
}
::locations
% # Define the main record. Notice that it uses the location record twice.
% record define contacts {
    first 
    middle 
    last 
    {record locations home}
    {record locations work}
}
::contacts
% # Create an instance for the contacts record.
% contacts cont1
::cont1
% # Display some introspection values
% record show records
::contacts ::locations
% #
% record show values cont1
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% #
% record show instances contacts
::cont1
% #
% cont1 config
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% #
% cont1 cget
-first {} -middle {} -last {} -home {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}} -work {-street {} -street2 {} -city {} -state {} -zipcode {} -country USA -phone {}}
% # copy one record to another record
% record define contacts2 [record show members contacts]
::contacts2
% record show members contacts2
first middle last {record locations home} {record locations work}
% record show members contacts
first middle last {record locations home} {record locations work}
%
.fi
.PP
\fBExample 1\fR
.PP
This next example just illustrates a simple linked list
.PP
.nf

% # define a very simple record for linked list
% record define llist {
    value
    next
}
::llist
% llist lstart
::lstart
% lstart config -value 1 -next [llist #auto]
% [lstart cget -next] config -value 2 -next [llist #auto]
% [[lstart cget -next] cget -next] config -value 3 -next "end"
% set next lstart
lstart
% while 1 {
lappend values [$next cget -value]
set next [$next cget -next]
if {[string match "end" $next]} {break}
}
% puts "$values"
1 2 3
% # cleanup linked list
% # We could just use delete record llist also
% foreach I [record show instances llist] {
record delete instance $I
}
% record show instances llist
%

.fi
.PP
.SH "KEYWORDS"
struct, record, data structures
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/record.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
#============================================================
# ::struct::record --
#
#    Implements a container data structure similar to a 'C' 
#    structure. It hides the ugly details about keeping the
#    data organized by using a combination of arrays, lists
#    and namespaces.
#   
#    Each record definition is kept in a master array 
#    (_recorddefn) under the ::struct::record namespace. Each
#    instance of a record is kept within a separate namespace
#    for each record definition. Hence, instances of
#    the same record definition are managed under the
#    same namespace. This avoids possible collisions, and
#    also limits one big global array mechanism.
#
# Copyright (c) 2002 by Brett Schwarz
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This code may be distributed under the same terms as Tcl.
#
# $Id: record.tcl,v 1.5 2003/01/29 06:26:03 schwarzkopf Exp $
#
#============================================================
#
####  FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args)

namespace eval ::struct {}

namespace eval ::struct::record {

    ##
    ##  array of lists that holds the 
    ##  definition (variables) for each 
    ##  record
    ##
    ##  _recorddefn(some_record) var1 var2 var3 ...
    ##
    variable _recorddefn

    ##
    ##  holds the count for each record
    ##  in cases where the instance is
    ##  automatically generated
    ##
    ##  _count(some_record) 0
    ##
    variable _count

    ##
    ##  array that holds the defining record's
    ##  name for each instances
    ##
    ##  _defn(some_instances) name_of_defining_record
    ##
    variable _defn

    ##
    ##  This holds the defaults for a record definition.
    ##  If no default is given for a member of a record,
    ##  then the value is assigned to the empty string
    ##
    variable _defaults

    ##
    ##  These are the possible sub commands
    ##
    variable commands
    set commands [list define delete exists show]

    ##
    ##  This keeps track of the level that we are in
    ##  when handling nested records. This is kind of
    ##  a hack, and probably can be handled better
    ##
    set _level 0

    namespace export record
}

#------------------------------------------------------------
# ::struct::record::record --
#
#    main command used to access the other sub commands
#
# Arguments:
#    cmd_   The sub command (i.e. define, show, delete, exists)
#    args   arguments to pass to the sub command
#
# Results:
#  none returned
#------------------------------------------------------------
#
proc ::struct::record::record {cmd_ args} {
    variable commands

    if {[lsearch $commands $cmd_] < 0} {
        error "Sub command \"$cmd_\" is not recognized. Must be [join $commands ,]"
    }

    set cmd_ [string totitle "$cmd_"]
    return [uplevel 1 ::struct::record::${cmd_} $args]

}; # end proc ::struct::record::record


#------------------------------------------------------------
# ::struct::record::Define --
#
#    Used to define a record
#
# Arguments:
#    defn_    the name of the record definition
#    vars_    the variables of the record (as a list)
#    args     instances to be create during definition
#
# Results:
#   Returns the name of the definition during successful
#   creation.
#------------------------------------------------------------
#
proc ::struct::record::Define {defn_ vars_ args} {

    variable _recorddefn
    variable _count
    variable _defaults

    set defn_ [Qualify $defn_]

    if {[info exists _recorddefn($defn_)]} {
        error "Record definition $defn_ already exists"
    }

    if {[lsearch [info commands] $defn_] >= 0} {
        error "Structure definition name can not be a Tcl command name"
    }

    set _defaults($defn_)   [list]
    set _recorddefn($defn_) [list]


    ##
    ##  Loop through the members of the record
    ##  definition
    ##
    foreach V $vars_ {

        set len [llength $V]
        set D ""

        ##
        ##  2 --> there is a default value
        ##        assigned to the member
        ##
        ##  3 --> there is a nested record
        ##        definition given as a member
        ##
        if {$len == 2} {

            set D [lindex $V 1]
            set V [lindex $V 0]

        } elseif {$len == 3} {

            if {![string match "record" "[lindex $V 0]"]} {

                Delete record $defn_
                error "$V is a Bad member for record definition
                definition creation aborted."
            }

            set new [lindex $V 1]

            set new [Qualify $new]

            ##
            ##  Right now, there can not be circular records
            ##  so, we abort the creation
            ##
            if {[string match "$defn_" "$new"]} {
                Delete record $defn_
                error "Can not have circular records. Structure was not created."
            }

            ##
            ##  Will take care of the nested record later
            ##  We just join by :: because this is how it
            ##  use to be declared, so the parsing code
            ##  is already there.
            ##
            set V [join [lrange $V 1 2] "::"]
        }

        lappend _recorddefn($defn_) $V
        lappend _defaults($defn_)   $D
    }
    

    uplevel #0 [list interp alias {} $defn_ {} ::struct::record::Create $defn_]

    set _count($defn_) 0

    namespace eval ::struct::record${defn_} {
        variable values
        variable instances

        set instances [list]
    }

    ##
    ##    If there were args given (instances), then
    ##    create them now
    ##
    foreach A $args {

        uplevel 1 [list ::struct::record::Create $defn_ $A]
    }

    return $defn_

}; # end proc ::struct::record::Define


#------------------------------------------------------------
# ::struct::record::Create --
#
#    Creates an instance of a record definition
#
# Arguments:
#    defn_    the name of the record definition
#    inst_    the name of the instances to create
#    args     values to set to the record's members
#
# Results:
#   Returns the name of the instance for a successful creation
#------------------------------------------------------------
#
proc ::struct::record::Create {defn_ inst_ args} {

    variable _recorddefn
    variable _count
    variable _defn
    variable _defaults
    variable _level

    set inst_ [Qualify "$inst_"]

    ##
    ##    test to see if the record
    ##    definition has been defined yet
    ##
    if {![info exists _recorddefn($defn_)]} {
        error "Structure $defn_ does not exist"
    }


    ##
    ##    if there was no argument given,
    ##    then assume that the record
    ##    variable is automatically
    ##    generated
    ##
    if {[string match "[Qualify #auto]" "$inst_"]} {
        set c $_count($defn_)
        set inst_ [format "%s%s" ${defn_} $_count($defn_)]
        incr _count($defn_)
    }

    ##
    ##    Test to see if this instance is already
    ##    created. This avoids any collisions with
    ##    previously created instances
    ##
    if {[info exists _defn($inst_)]} {
        incr _count($defn_) -1
        error "Instances $inst_ already exists"
    }

    set _defn($inst_) $defn_

    ##
    ##    Initialize record variables to
    ##    defaults
    ##

    uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_]

    set cnt 0
    foreach V $_recorddefn($defn_) D $_defaults($defn_) {

        set [Ns $inst_]values($inst_,$V) $D

        ##
        ##  Test to see if there is a nested record
        ##
        if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} {

            if {$_level == 0} {
                set _level 2
            }

            ##
            ##  This is to guard against if the creation
            ##  had failed, that there isn't any
            ##  lingering variables/alias around
            ##
            set def [Qualify $def $_level]

            if {![info exists _recorddefn($def)]} {

                Delete inst "$inst_"

                return
            }

            ##
            ##    evaluate the nested record. If there
            ##    were values for the variables passed
            ##    in, then we assume that the value for
            ##    this nested record is a list 
            ##    corresponding the the nested list's
            ##    variables, and so we pass that to
            ##    the nested record's instantiation.
            ##    We then get rid of those args for later
            ##    processing.
            ##
            set cnt_plus [expr {$cnt + 1}]
            set mem [lindex $args $cnt]
            if {![string match "" "$mem"]} {
                 if {![string match "-$inst" "$mem"]} {
                    Delete inst "$inst_"
                    error "$inst is not a member of $defn_"
                }
            }
            incr _level
            eval Create $def ${inst_}.${inst} [lindex $args $cnt_plus]
            set args [lreplace $args $cnt $cnt_plus]

        } else {

            uplevel #0 [list interp alias {} ${inst_}.$V {} ::struct::record::Access $defn_ $inst_ $V]
            incr cnt 2
        }

    }; # end foreach variable

    lappend [Ns $inst_]instances $inst_

    foreach {k v} $args {

        Access $defn_ $inst_ [string trimleft "$k" -] $v

    }; # end foreach arg

    set _level 0
    
    return $inst_

}; # end proc ::struct::record::Create


#------------------------------------------------------------
# ::struct::record::Access --
#
#    Provides a common proc to access the variables
#    from the aliases create for each variable in the record
#
# Arguments:
#    defn_    the name of the record to access
#    inst_    the name of the instance to create
#    var_     the variable of the record to access
#    args     a value to set to var_ (if any)
#
# Results:
#    Returns the value of the record member (var_)
#------------------------------------------------------------
#
proc ::struct::record::Access {defn_ inst_ var_ args} {

    variable _recorddefn
    variable _defn

    set i [lsearch $_recorddefn($defn_) $var_]

    if {$i < 0} {
         error "$var_ does not exist in record $defn_"
    }

    if {![info exists _defn($inst_)]} {

         error "$inst_ does not exist"
    }

    if {[set idx [lsearch $args "="]] >= 0} {
        set args [lreplace $args $idx $idx]
    } 

    ##
    ##    If a value was given, then set it
    ##
    if {[llength $args] != 0} {

        set val_ [lindex $args 0]

        set [Ns $inst_]values($inst_,$var_) $val_
    }

    return [set [Ns $inst_]values($inst_,$var_)]
     
}; # end proc ::struct::record::Access


#------------------------------------------------------------
# ::struct::record::Cmd --
#
#    Used to process the set/get requests.
#
# Arguments:
#    inst_    the record instance name
#    args     For 'get' this is the record members to
#             retrieve. For 'set' this is a member/value
#             pair.
#
# Results:
#   For 'set' returns the empty string. For 'get' it returns
#   the member values.
#------------------------------------------------------------
#
proc ::struct::record::Cmd {inst_ args} {

    variable _defn

    set result [list]

    set len [llength $args]
    if {$len <= 1} {return [Show values "$inst_"]}

    set cmd [lindex $args 0]

    if {[string match "cget" "$cmd"]} {

            set cnt 0
            foreach k [lrange $args 1 end] {
                if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} {
                    error "Bad option \"$k\""
                }

                lappend result $r
                incr cnt
            }
            if {$cnt == 1} {set result [lindex $result 0]}
            return $result

    } elseif {[string match "config*" "$cmd"]} {

            set L [lrange $args 1 end]
            foreach {k v} $L {
                 ${inst_}.[string trimleft ${k} -] $v
            }

    } else {
            error "Wrong argument.
            must be \"object cget|configure args\""
    }

    return [list]

}; # end proc ::struct::record::Cmd


#------------------------------------------------------------
# ::struct::record::Ns --
#
#    This just constructs a fully qualified namespace for a
#    particular instance.
#
# Arguments;
#    inst_    instance to construct the namespace for.
#
# Results:
#    Returns the fully qualified namespace for the instance
#------------------------------------------------------------
#
proc ::struct::record::Ns {inst_} {

    variable _defn

    if {[catch {set ret $_defn($inst_)} err]} {
        return $inst_
    }

    return [format "%s%s%s" "::struct::record" $ret "::"]

}; # end proc ::struct::record::Ns


#------------------------------------------------------------
# ::struct::record::Show --
#
#     Display info about the record that exist
#
# Arguments:
#    what_    subcommand
#    record_  record or instance to process
#
# Results:
#    if what_ = record, then return list of records
#               definition names.
#    if what_ = members, then return list of members
#               or members of the record.
#    if what_ = instance, then return a list of instances
#               with record definition of record_
#    if what_ = values, then it will return the values
#               for a particular instance
#------------------------------------------------------------
#
proc ::struct::record::Show {what_ {record_ ""}} {

    variable _recorddefn
    variable _defn
    variable _defaults

    ##
    ## We just prepend :: to the record_ argument
    ##
    if {![string match "::*" "$record_"]} {set record_ "::$record_"}

    if {[string match "record*" "$what_"]} {
        return [lsort [array names _recorddefn]]
    } elseif {[string match "mem*" "$what_"]} {

       if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} {
           error "Bad arguments while accessing members. Bad record name"
       }

       set res [list]
       set cnt 0
       foreach m $_recorddefn($record_) {
           set def [lindex $_defaults($record_) $cnt]
           if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} {
               lappend res [list record $d $i]
           } elseif {![string match "" "$def"]} {
               lappend res [list $m $def]
           } else {
               lappend res $m
           }

           incr cnt
       }

       return $res

    } elseif {[string match "inst*" "$what_"]} {

        if {![info exists ::struct::record${record_}::instances]} {
            return [list]
        }
        return [lsort [set ::struct::record${record_}::instances]]

    } elseif {[string match "val*" "$what_"]} {

           set ns $_defn($record_)

           if {[string match "" "$record_"] || ([lsearch [set [Ns $record_]instances] $record_] < 0)} {

               error "Wrong arguments to values. Bad instance name"
           }

           set ret [list]
           foreach k $_recorddefn($ns) {

              set v [set [Ns $record_]values($record_,$k)]

              if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} {
                  set v [::struct::record::Show values ${record_}.${inst}]
              }

              lappend ret -[namespace tail $k] $v
           }
           return $ret

    }

    return [list]

}; # end proc ::struct::record::Show


#------------------------------------------------------------
# ::struct::record::Delete --
#
#    Deletes a record instance or a record definition
#
# Arguments:
#    sub_    what to delete. Either 'instance' or 'record'
#    item_   the specific record instance or definition
#            delete.
#
# Returns:
#    none
#
#------------------------------------------------------------
#
proc ::struct::record::Delete {sub_ item_} {

    variable _recorddefn
    variable _defn
    variable _count
    variable _defaults

    ##
    ## We just semi-blindly prepend :: to the record_ argument
    ##
    if {![string match "::*" "$item_"]} {set item_ "::$item_"}

    switch -- $sub_ {

        instance -
        instances -
        inst    {


            if {[Exists instance $item_]} {
        
		set ns $_defn($item_)
                foreach A [info commands ${item_}.*] {
		    Delete inst $A
                }
        
                catch {
                    foreach {k v} [array get [Ns $item_]values $item_,*] {
                        
                        unset [Ns $item_]values($k)
                    }
                    set i [lsearch [set [Ns $item_]instances] $item_]
                    set [Ns $item_]instances [lreplace [set [Ns $item_]instances] $i $i]
                    unset _defn($item_)
                }

                incr _count($ns) -1
        
            } else {
                #error "$item_ is not a instance"
            }
        }
        record  -
        records   {


            ##
            ##  Delete the instances for this
            ##  record
            ##
            foreach I [Show instance "$item_"] {
                catch {Delete instance "$I"}
            }

            catch {
                unset _recorddefn($item_)
                unset _defaults($item_)
                unset _count($item_)
                namespace delete ::struct::record${item_}
            }

            
        }
        default   {
            error "Wrong arguments to delete"
        }

    }; # end switch

    catch { uplevel #0 [list interp alias {} $item_ {}]}

    return

}; # end proc ::struct::record::Delete


#------------------------------------------------------------
# ::struct::record::Exists --
#
#    Tests whether a record definition or record
#    instance exists.
#
# Arguments:
#    sub_    what to test. Either 'instance' or 'record'
#    item_   the specific record instance or definition
#            that needs to be tested.
#    
# Tests to see if a particular instance exists
#
#------------------------------------------------------------
#
proc ::struct::record::Exists {sub_ item_} {


    switch -glob -- $sub_ {
        inst*    {
    
            if {([lsearch ::[Ns $item_]instances $item_] >=0) || [llength [info commands ::${item_}.*]]} {
                return 1
            } else {
                return 0
            }
        }
        record  {
    
            set item_ "::$item_"
            if {[info exists _recorddefn($item_)] || [llength [info commands ${item_}]]} {
                return 1
            } else {
                return 0
            }
        }
        default  {
            error "Wrong arguments. Must be exists record|instance target"
        }
    }; # end switch

}; # end proc ::struct::record::Exists


#------------------------------------------------------------
# ::struct::record::Qualify --
#
#    Contructs the qualified name of the calling scope. This
#    defaults to 2 levels since there is an extra proc call in
#    between.
#
# Arguments:
#    item_   the command that needs to be qualified
#    level_  how many levels to go up (default = 2)
#    
# Results:
#    the item_ passed in fully qualified
#
#------------------------------------------------------------
#
proc ::struct::record::Qualify {item_ {level_ 2}} {

    if {![string match "::*" "$item_"]} {
        set ns [uplevel $level_ [list namespace current]]

        if {![string match "::" "$ns"]} {
            append ns "::"
        }
     
        set item_ "$ns${item_}"
    }

    return "$item_"

}; # end proc ::struct::record::Qualify
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/record.test.

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

source [file join [file dirname [info script]] record.tcl]
namespace import struct::record::*

test record-0.1 {record define} {
    record define phones {home work cell}
} ::phones

test record-0.2 {record define - multi line} {
    record define contact {
	first
	middle
	last
	{record phones phlist}
    }
} ::contact

test record-0.3 {record define - multi line} {
    record define mycontact {
        age
        sex
        {record contact cont}
    }
} ::mycontact

test record-0.4 {definition with instantiation} {
    record define location {
        street
        city
	state
	{country USA}
    } loc(1) loc(5)
} ::location

test record-0.5 {test error with circular records} {
    catch {
	record define circular {
	    one
	    {record circular cir}
	} cir(1)
    } err
    set err
} "Can not have circular records. Structure was not created."

test record-0.6 {single instance} {
    contact cont(1)
} ::cont(1)

test record-0.7 {auto instance} {
    contact #auto
} ::contact0

test record-0.8 {instance of double nested record} {
    mycontact #auto
} ::mycontact0

test record-0.9 {setting a instance var via alias} {
    cont(1).first Brett
} Brett

test record-1.0 {setting a nested instance var via alias} {
    cont(1).phlist.cell 425-555-1212
} 425-555-1212

test record-1.1 {setting a double nested instance var via alias} {
    mycontact0.cont.phlist.cell 206-555-1212
} 206-555-1212

test record-1.2 {setting values via config} {
    cont(1) config -middle Allen -last Schwarz
} ""

test record-1.3 {setting a double nested instance  via config} {
    mycontact0 config -cont.phlist.cell 206-555-1212
} ""

test record-1.4 {get a value via cget} {
    cont(1) cget -first -middle -last
} [list Brett Allen Schwarz]

test record-1.5 {get a double nested value via cget} {
    mycontact0 cget -cont.phlist.cell
} 206-555-1212

test record-1.6 {get a value via alias} {
    cont(1).first
} Brett

test record-1.7 {record default value} {
    loc(1) cget -country
} USA

test record-1.8 {setting values via config} {
    loc(1) config -street somestreet -city somecity -state somestate -country somecountry
} ""

test record-1.9 {setting nested vars via config} {
    cont(1) config -phlist.home 425-555-1212
} ""

test record-2.0 {test value of nested member} {
    cont(1) cget -phlist.home
} 425-555-1212

test record-2.1 {config with no values} {
    loc(1) config
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-2.2 {get with no values} {
    loc(1) cget
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-2.3 {get with just instance command} {
    loc(1)
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-2.4 {get a nest value via alias} {
    cont(1).phlist.cell
} 425-555-1212

test record-2.5 {set values during instantiation} {
    location loc(2) -street street2 -city city2 -state state2 -country country2
} ::loc(2)

test record-2.6 {get the above value via alias} {
    loc(2).street
} street2

test record-2.7 {set values during instantiation - nested record} {
    contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111]
} ::cont(2)

test record-2.8 {copy one instance to another during creation} {
    eval contact cont(3) [cont(1)]
} ::cont(3)

test record-2.9 {get the above values via alias} {
    cont(2).phlist.home
} 425-555-1212

test record-3.0 {copy one definition to another definition} {
    record define new_contact [record show members contact]
} ::new_contact

test record-3.1 {show defined records} {
    record show records
} [lsort [list ::phones ::contact ::location ::new_contact ::mycontact]]

test record-3.2 {show members} {
    record show members phones
} [list home work cell]

test record-3.3 {show members - with default value} {
    record show members location
} [list street city state [list country USA]]

test record-3.4 {show members - nested record} {
    record show members contact
} [list first middle last [list record phones phlist]]

test record-3.5 {show values} {
    record show values loc(1)
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-3.6 {show values - nested} {
    record show values cont(1)
} [list -first Brett -middle Allen -last Schwarz -phlist [list -home 425-555-1212 -work {} -cell 425-555-1212]]

test record-3.7 {show instances} {
    record show instance location
} [list ::loc(1) ::loc(2) ::loc(5)]


test record-3.8 {delete an instance} {
    record delete instance loc(2)
} ""

test record-3.9 {delete a nested instance} {
    record delete instance cont(2)
} ""

test record-4.0 {delete a record} {
    record delete record location
} ""

test record-4.1 {test existence of an instance that was deleted} {
    record exists instance loc(1)
} 0

test record-4.2 {show existence of an instance} {
    record exists instance cont(1)
} 1

test record-4.3 {show non-existent instance} {
    record exists instance junk
} 0

test record-4.4 {show existence of record} {
    record exists record contact
} 1


##
##    NAMESPACE TESTS
##

test record-5.0 {record define} {
    namespace eval myns {
	record define phones {home work cell}
    }
} ::myns::phones

test record-5.1 {record define - multi line} {
    record define ::myns::contact {
	first
	middle
	last
	{record phones phlist}
    }
} ::myns::contact

test record-5.2 {definition with instantiation} {
    namespace eval myns {
	record define location {
	    street
	    city
	    state
	    {country USA}
	} loc(1) loc(5)
    }
} ::myns::location

test record-5.3 {test error with circular records} {
    catch {
	namespace eval myns {
	    record define circular {
		one
		{record ::myns::circular cir}
	    } cir(1)
	}
    } err
    set err
} "Can not have circular records. Structure was not created."

test record-5.4 {single instance} {
    namespace eval myns {
	contact cont(1)
    }
} ::myns::cont(1)

test record-5.5 {auto instance} {
    namespace eval myns {
	contact #auto
    }
} ::myns::contact0

test record-5.6 {setting a instance var via alias} {
    myns::cont(1).first Brett
} Brett

test record-5.7 {setting a nested instance var via alias} {
    myns::cont(1).phlist.cell 425-555-1212
} 425-555-1212

test record-5.8 {setting values via config} {
    myns::cont(1) config -middle Allen -last Schwarz
} ""

test record-5.9 {get a value via cget} {
    myns::cont(1) cget -first -middle -last
} [list Brett Allen Schwarz]

test record-6.0 {record default value} {
    myns::loc(1) cget -country
} USA

test record-6.1 {setting values via config} {
    myns::loc(1) config -street somestreet -city somecity -state somestate -country somecountry
} ""

test record-6.2 {setting nested vars via config} {
    myns::cont(1) config -phlist.home 425-555-1212
} ""

test record-6.3 {test value of nested member} {
    myns::cont(1) cget -phlist.home
} 425-555-1212

test record-6.4 {config with no values} {
    myns::loc(1) config
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-6.5 {get with no values} {
    myns::loc(1) cget
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-6.6 {get with just instance command} {
    myns::loc(1)
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-6.7 {get a nest value via alias} {
    myns::cont(1).phlist.cell
} 425-555-1212

test record-6.8 {set values during instantiation} {
    namespace eval myns {
	location loc(2) -street street2 -city city2 -state state2 -country country2
    }
} ::myns::loc(2)

test record-6.9 {get the above value via alias} {
    myns::loc(2).street
} street2

test record-7.0 {set values during instantiation - nested record} {
    namespace eval myns {
	contact cont(2) -first John -middle Q -last Doe -phlist [list home 425-555-1212 work 425-555-1222 cell 425-555-1111]
    }
} ::myns::cont(2)

test record-7.1 {get the above values via alias} {
    myns::cont(2).phlist.home
} 425-555-1212


test record-7.2 {show defined records} {
    record show records
} [lsort [list ::contact ::myns::phones ::myns::contact ::myns::location ::new_contact ::phones ::mycontact]]

test record-7.3 {show members} {
    record show members myns::phones
} [list home work cell]

test record-7.4 {show members - with default value} {
    record show members myns::location
} [list street city state [list country USA]]

test record-7.5 {show members - nested record} {
    record show members myns::contact
} [list first middle last [list record phones phlist]]

test record-7.6 {show values} {
    record show values myns::loc(1)
} [list -street somestreet -city somecity -state somestate -country somecountry]

test record-7.7 {show values - nested} {
    record show values myns::cont(1)
} [list -first Brett -middle Allen -last Schwarz -phlist [list -home 425-555-1212 -work {} -cell 425-555-1212]]

test record-7.8 {show instances} {
    record show instance myns::location
} [list ::myns::loc(1) ::myns::loc(2) ::myns::loc(5)]


test record-7.9 {delete an instance} {
    record delete instance myns::loc(2)
} ""

test record-8.0 {delete a nested instance} {
    record delete instance myns::cont(2)
} ""

test record-8.1 {delete a record} {
    record delete record myns::location
} ""

test record-8.2 {test existence of an instance that was deleted} {
    record exists instance myns::loc(1)
} 0

test record-8.3 {show existence of an instance} {
    record exists instance myns::cont(1)
} 1

test record-8.4 {show non-existent instance} {
    record exists instance myns::junk
} 0

test record-8.5 {show existence of record} {
    record exists record myns::contact
} 1

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/skiplist.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
[comment {-*- tcl -*-}]
[manpage_begin skiplist n 1.3]
[copyright {2000 Keith Vetter}]
[comment {
    This software is licensed under a BSD license as described in tcl/tk
    license.txt file but with the copyright held by Keith Vetter.
}]
[moddesc   {Tcl Data Structures}]
[titledesc {Create and manipulate skiplists}]
[require Tcl 8.2]
[require struct [opt 1.3]]
[description]
[para]

The [cmd ::struct::skiplist] command creates a new skiplist object
with an associated global Tcl command whose name is
[arg skiplistName]. This command may be used to invoke various
operations on the skiplist. It has the following general form:

[list_begin definitions]
[call [cmd graphName] [arg option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.

[list_end]

[para]

Skip lists are an alternative data structure to binary trees. They can
be used to maintain ordered lists over any sequence of insertions and
deletions. Skip lists use randomness to achieve probabilistic
balancing, and as a result the algorithms for insertion and deletion
in skip lists are much simpler and faster than those for binary trees.

[para]

To read more about skip lists see Pugh, William.
[emph {Skip lists: a probabilistic alternative to balanced trees}]
In: Communications of the ACM, June 1990, 33(6) 668-676.

[para]

Currently, the key can be either a number or a string, and comparisons
are performed with the built in greater than operator.

The following commands are possible for skiplist objects:

[list_begin definitions]
[call [arg skiplistName] [method delete] [arg node] [opt [arg node]...]]

Remove the specified nodes from the skiplist.


[call [arg skiplistName] [method destroy]]

Destroy the skiplist, including its storage space and associated command.


[call [arg skiplistName] [method insert] [arg {key value}]]

Insert a node with the given [arg key] and [arg value] into the
skiplist. If a node with that key already exists, then the that node's
value is updated and its node level is returned. Otherwise a new node
is created and 0 is returned.


[call [arg skiplistName] [method search] [arg node] [opt "[const -key] [arg key]"]]

Search for a given key in a skiplist. If not found then 0 is returned.
If found, then a two element list of 1 followed by the node's value is retuned.


[call [arg skiplistName] [method size]]

Return a count of the number of nodes in the skiplist.

[call [arg skiplistName] [method walk] [arg cmd]]

Walk the skiplist from the first node to the last. At each node, the
command [arg cmd] will be evaluated with the key and value of the
current node appended.

[list_end]

[keywords skiplist]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































Deleted modules/struct/skiplist.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
# skiplist.tcl --
#
#	Implementation of a skiplist data structure for Tcl.
#
#	To quote the inventor of skip lists, William Pugh:
#		Skip lists are a probabilistic data structure that seem likely
#		to supplant balanced trees as the implementation method of
#		choice for many applications. Skip list algorithms have the
#		same asymptotic expected time bounds as balanced trees and are
#		simpler, faster and use less space.
#
#	For more details on how skip lists work, see Pugh, William. Skip
#	lists: a probabilistic alternative to balanced trees in
#	Communications of the ACM, June 1990, 33(6) 668-676. Also, see
#	ftp://ftp.cs.umd.edu/pub/skipLists/
# 
# Copyright (c) 2000 by Keith Vetter
# This software is licensed under a BSD license as described in tcl/tk
# license.txt file but with the copyright held by Keith Vetter.
#
# TODO:
#	customize key comparison to a user supplied routine

namespace eval ::struct {}

namespace eval ::struct::skiplist {
    # Data storage in the skiplist module
    # -------------------------------
    #
    # For each skiplist, we have the following arrays
    #   state - holds the current level plus some magic constants
    #	nodes - all the nodes in the skiplist, including a dummy header node
    
    # counter is used to give a unique name for unnamed skiplists
    variable counter 0

    # Internal constants
    variable MAXLEVEL 16
    variable PROB .5
    variable MAXINT [expr {0x7FFFFFFF}]

    # commands is the list of subcommands recognized by the skiplist
    variable commands [list \
	    "destroy"	\
	    "delete"	\
	    "insert"	\
	    "search"	\
	    "size"	\
	    "walk"	\
	    ]

    # State variables that can be set in the instantiation
    variable vars [list maxlevel probability]
    
    # Only export one command, the one used to instantiate a new skiplist
    namespace export skiplist
}

# ::struct::skiplist::skiplist --
#
#	Create a new skiplist with a given name; if no name is given, use
#	skiplistX, where X is a number.
#
# Arguments:
#	name	name of the skiplist; if null, generate one.
#
# Results:
#	name	name of the skiplist created

proc ::struct::skiplist::skiplist {{name ""} args} {
    set usage "skiplist name ?-maxlevel ##? ?-probability ##?"
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "skiplist${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create skiplist"
    }

    # Handle the optional arguments
    set more_eval ""
    for {set i 0} {$i < [llength $args]} {incr i} {
	set flag [lindex $args $i]
	incr i
	if { $i >= [llength $args] } {
	    error "value for \"$flag\" missing: should be \"$usage\""
	}
	set value [lindex $args $i]
	switch -glob -- $flag {
	    "-maxl*" {
		set n [catch {set value [expr $value]}]
		if {$n || $value <= 0} {
		    error "value for the maxlevel option must be greater than 0"
		}
		append more_eval "; set state(maxlevel) $value"
	    }
	    "-prob*" {
		set n [catch {set value [expr $value]}]
		if {$n || $value <= 0 || $value >= 1} {
		    error "probability must be between 0 and 1"
		}
		append more_eval "; set state(prob) $value"
	    }
	    default {
		error "unknown option \"$flag\": should be \"$usage\""
	    }
	}
    }
    
    # Set up the namespace for this skiplist
    namespace eval ::struct::skiplist::skiplist$name {
	variable state
	variable nodes

	# NB. maxlevel and prob may be overridden by $more_eval at the end
	set state(maxlevel) $::struct::skiplist::MAXLEVEL
	set state(prob) $::struct::skiplist::PROB
	set state(level) 1
	set state(cnt) 0
	set state(size) 0

	set nodes(nil,key) $::struct::skiplist::MAXINT
	set nodes(header,key) "---"
	set nodes(header,value) "---"

	for {set i 1} {$i < $state(maxlevel)} {incr i} {
	    set nodes(header,$i) nil
	}
    } $more_eval

    # Create the command to manipulate the skiplist
    interp alias {} ::$name {} ::struct::skiplist::SkiplistProc $name

    return $name
}

###########################
# Private functions follow

# ::struct::skiplist::SkiplistProc --
#
#	Command that processes all skiplist object commands.
#
# Arguments:
#	name	name of the skiplist object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::skiplist::SkiplistProc {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 ::struct::skiplist::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::skiplist::_$cmd $name] $args
}

## ::struct::skiplist::_destroy --
#
#	Destroy a skiplist, including its associated command and data storage.
#
# Arguments:
#	name	name of the skiplist.
#
# Results:
#	None.

proc ::struct::skiplist::_destroy {name} {
    namespace delete ::struct::skiplist::skiplist$name
    interp alias {} ::$name {}
}

# ::struct::skiplist::_search --
#
#	Searches for a key in a skiplist
#
# Arguments:
#	name		name of the skiplist.
#	key		key for the node to search for
#
# Results:
#	0 if not found
#	[list 1 node_value] if found

proc ::struct::skiplist::_search {name key} {
    upvar ::struct::skiplist::skiplist${name}::state state
    upvar ::struct::skiplist::skiplist${name}::nodes nodes

    set x header
    for {set i $state(level)} {$i >= 1} {incr i -1} {
	while {1} {
	    set fwd $nodes($x,$i)
	    if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break
	    if {$nodes($fwd,key) >= $key} break
	    set x $fwd
	}
    }
    set x $nodes($x,1)
    if {$nodes($x,key) == $key} {
	return [list 1 $nodes($x,value)]
    }
    return 0
}

# ::struct::skiplist::_insert --
#
#	Add a node to a skiplist.
#
# Arguments:
#	name		name of the skiplist.
#	key		key for the node to insert
#	value		value of the node to insert
#
# Results:
#	0      if new node was created
#       level  if existing node was updated

proc ::struct::skiplist::_insert {name key value} {
    upvar ::struct::skiplist::skiplist${name}::state state
    upvar ::struct::skiplist::skiplist${name}::nodes nodes
    
    set x header
    for {set i $state(level)} {$i >= 1} {incr i -1} {
	while {1} {
	    set fwd $nodes($x,$i)
	    if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break
	    if {$nodes($fwd,key) >= $key} break
	    set x $fwd
	}
	set update($i) $x
    }
    set x $nodes($x,1)

    # Does the node already exist?
    if {$nodes($x,key) == $key} {
	set nodes($x,value) $value
	return 0
    }

    # Here to insert item
    incr state(size)
    set lvl [randomLevel $state(prob) $state(level) $state(maxlevel)]

    # Did the skip list level increase???
    if {$lvl > $state(level)} {
	for {set i [expr {$state(level) + 1}]} {$i <= $lvl} {incr i} {
	    set update($i) header
	}
	set state(level) $lvl
    }

    # Create a unique new node name and fill in the key, value parts
    set x [incr state(cnt)] 
    set nodes($x,key) $key
    set nodes($x,value) $value

    for {set i 1} {$i <= $lvl} {incr i} {
	set nodes($x,$i) $nodes($update($i),$i)
	set nodes($update($i),$i) $x
    }

    return $lvl
}

# ::struct::skiplist::_delete --
#
#	Deletes a node from a skiplist
#
# Arguments:
#	name		name of the skiplist.
#	key		key for the node to delete
#
# Results:
#	1 if we deleted a node
#       0 otherwise

proc ::struct::skiplist::_delete {name key} {
    upvar ::struct::skiplist::skiplist${name}::state state
    upvar ::struct::skiplist::skiplist${name}::nodes nodes
    
    set x header
    for {set i $state(level)} {$i >= 1} {incr i -1} {
	while {1} {
	    set fwd $nodes($x,$i)
	    if {$nodes($fwd,key) >= $key} break
	    set x $fwd
	}
	set update($i) $x
    }
    set x $nodes($x,1)

    # Did we find a node to delete?
    if {$nodes($x,key) != $key} {
	return 0
    }
    
    # Here when we found a node to delete
    incr state(size) -1
    
    # Unlink this node from all the linked lists that include to it
    for {set i 1} {$i <= $state(level)} {incr i} {
	set fwd $nodes($update($i),$i)
	if {$nodes($fwd,key) != $key} break
	set nodes($update($i),$i) $nodes($x,$i)
    }
    
    # Delete all traces of this node
    foreach v [array names nodes($x,*)] {
	unset nodes($v)
    }

    # Fix up the level in case it went down
    while {$state(level) > 1} {
	if {! [string equal "nil" $nodes(header,$state(level))]} break
	incr state(level) -1
    }

    return 1
}

# ::struct::skiplist::_size --
#
#	Returns how many nodes are in the skiplist
#
# Arguments:
#	name		name of the skiplist.
#
# Results:
#	number of nodes in the skiplist

proc ::struct::skiplist::_size {name} {
    upvar ::struct::skiplist::skiplist${name}::state state

    return $state(size)
}

# ::struct::skiplist::_walk --
#
#	Walks a skiplist performing a specified command on each node.
#	Command is executed at the global level with the actual command
#	executed is:  command key value
#
# Arguments:
#	name	name of the skiplist.
#	cmd		command to run on each node
#
# Results:
#	none.

proc ::struct::skiplist::_walk {name cmd} {
    upvar ::struct::skiplist::skiplist${name}::nodes nodes

    for {set x $nodes(header,1)} {$x != "nil"} {set x $nodes($x,1)} {
	# Evaluate the command at this node
	set cmdcpy $cmd
	lappend cmdcpy $nodes($x,key) $nodes($x,value)
	uplevel 2 $cmdcpy
    }
}

# ::struct::skiplist::randomLevel --
#
#	Generates a random level for a new node. We limit it to 1 greater
#	than the current level. 
#
# Arguments:
#	prob		probability to use in generating level
#	level		current biggest level
#	maxlevel	biggest possible level
#
# Results:
#	an integer between 1 and $maxlevel

proc ::struct::skiplist::randomLevel {prob level maxlevel} {

    set lvl 1
    while {[expr rand()] < $prob && $lvl < $maxlevel} {
	incr lvl
    }

    if {$lvl > $level} {
	set lvl [expr {$level + 1}]
    }
    
    return $lvl
}

# ::struct::skiplist::_dump --
#
#	Dumps out a skip list. Useful for debugging.
#
# Arguments:
#	name	name of the skiplist.
#
# Results:
#	none.

proc ::struct::skiplist::_dump {name} {
    upvar ::struct::skiplist::skiplist${name}::state state
    upvar ::struct::skiplist::skiplist${name}::nodes nodes


    puts "Current level $state(level)"
    puts "Maxlevel:     $state(maxlevel)"
    puts "Probability:  $state(prob)"
    puts ""
    puts "NODE    KEY  FORWARD"
    for {set x header} {$x != "nil"} {set x $nodes($x,1)} {
	puts -nonewline [format "%-6s  %3s %4s" $x $nodes($x,key) $nodes($x,1)]
	for {set i 2} {[info exists nodes($x,$i)]} {incr i} {
	    puts -nonewline [format %4s $nodes($x,$i)]
	}
	puts ""
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/skiplist.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

#lappend auto_path [pwd]
package require struct
#namespace import struct::*

# ::shuffle --
#
#   creates a randomly ordered list of the integers from 0 to n-1.
#
# Arguments:
#   n   size of the list to shuffle
#
# Results:
#   list of integers from 0 to n-1 in a random order

proc shuffle {n} {
	set t [list ]
	set tt [list ]
	for {set i 0} {$i < $n} {incr i} {
		lappend t $i
	}

    # Select a random item out of list t and append to list tt

	for {set i [expr {$n - 1}]} {$i >= 0} {incr i -1} {
		set r [expr rand()]
		set x [expr {int($r * ($i + 1))}]
		lappend tt [lindex $t $x]
		set t [lreplace $t $x $x]
	}

	return $tt
}

test skiplist-0.1 {skiplist errors} {
    struct::skiplist myskiplist
    catch {struct::skiplist myskiplist} msg
    myskiplist destroy
    set msg
} "command \"myskiplist\" already exists, unable to create skiplist"

test skiplist-0.2 {skiplist errors} {
    struct::skiplist myskiplist
    catch {myskiplist} msg
    myskiplist destroy
    set msg
} "wrong # args: should be \"myskiplist option ?arg arg ...?\""

test skiplist-0.3 {skiplist errors} {
    struct::skiplist myskiplist
    catch {myskiplist foo} msg
    myskiplist destroy
    set msg
} "bad option \"foo\": must be destroy, delete, insert, search, size, or walk"

test skiplist-0.4 {skiplist errors} {
    catch {struct::skiplist set} msg
    set msg
} "command \"set\" already exists, unable to create skiplist"

test skiplist-0.5 {skiplist errors} {
	catch {struct::skiplist myskiplist -foo bar} msg
	set msg
} "unknown option \"-foo\": should be \"skiplist name ?-maxlevel ##? ?-probability ##?\""

test skiplist-0.6 {skiplist errors} {
	catch {struct::skiplist myskiplist -maxlevel bar} msg
	set msg
} "value for the maxlevel option must be greater than 0"

test skiplist-0.7 {skiplist errors} {
	catch {struct::skiplist myskiplist -probability bar} msg
	set msg
} "probability must be between 0 and 1"




test skiplist-1.0 {insert} {
	struct::skiplist myskiplist
	myskiplist insert 5 value_5
	set t [myskiplist search 5]
	myskiplist destroy
	set t
}  "1 value_5"

test skiplist-1.1 {insert} {
	struct::skiplist myskiplist
	myskiplist insert 5 value_5
	myskiplist insert 5 value_5.2
	myskiplist insert 5 value_5.3
	myskiplist insert 5 value_5.4
	set t [myskiplist search 5]
	myskiplist destroy
	set t
}  "1 value_5.4"

test skiplist-1.2 {insert} {
	struct::skiplist myskiplist
	unset a
	foreach a [list 9 7 5 3 1 8 6 4 2] {
		myskiplist insert $a value_$a
	}
	set t [list ]
	myskiplist walk {lappend t}
	myskiplist destroy
	set t
}  "1 value_1 2 value_2 3 value_3 4 value_4 5 value_5 6 value_6 7 value_7 8 value_8 9 value_9"

test skiplist-1.3 {insert} {
	struct::skiplist myskiplist
	foreach a [shuffle 500] {
		set a2 [expr {$a + 1}]
		myskiplist insert $a $a2
	}
	set t [list ]
	myskiplist walk {lappend t}
	myskiplist destroy
	set sum [set sum2 0]
	foreach {key value} $t {
		set sum [expr {$sum + $key}]
		set sum2 [expr {$sum2 + $value}]
	}
	set sum "$sum $sum2"
}  "124750 125250"

test skiplist-1.4 {insert} {
	struct::skiplist myskiplist
	foreach a [shuffle 500] {
		myskiplist insert $a -1
	}
	foreach a [shuffle 500] {
		myskiplist insert $a $a
	}
	set t [list ]
	myskiplist walk {lappend t}
	myskiplist destroy
	set sum 0
	foreach {key value} $t {
		set sum [expr {$sum + $value}]
	}
	set sum
} "124750"

test skiplist-1.5 {insert} {
	struct::skiplist myskiplist
	foreach a [list k e i t h p o w l v r] {
		myskiplist insert $a value_$a
	}
	set t [list ]
	myskiplist walk {lappend t }
	set str ""
	foreach {key value} $t {
		append str $key
	}
	myskiplist destroy
	set str
} "ehikloprtvw"
	
		

test skiplist-2.0 {delete} {
	struct::skiplist myskiplist
	myskiplist insert 4 value_4
	set t [myskiplist delete 4]
	myskiplist destroy
	set t
} "1"

test skiplist-2.1 {delete} {
	struct::skiplist myskiplist
	myskiplist insert 4 value_4
	myskiplist delete 4
	set t [myskiplist search 4]
	myskiplist destroy
	set t
} "0"

test skiplist-2.2 {delete} {
	struct::skiplist myskiplist
	myskiplist insert 4 value_4
	set t [myskiplist delete 5]
	myskiplist destroy
	set t
} "0"

test skiplist-2.3 {delete} {
	struct::skiplist myskiplist
	myskiplist insert 8 value_8
	myskiplist insert 7 value_7
	myskiplist insert 6 value_6
	myskiplist insert 5 value_5
	myskiplist insert 4 value_4
	myskiplist delete 6
	myskiplist delete 5
	myskiplist delete 4

	set t [myskiplist search 7]
	myskiplist destroy
	set t
} "1 value_7"

test skiplist-2.4 {delete} {
	struct::skiplist myskiplist
	set data [shuffle 100]
	foreach a $data {
		myskiplist insert $a value_$a
		if {$a == 1} {
			myskiplist insert 999 value_999
		}
	}
	foreach a $data {
		myskiplist delete $a
	}
	
	set size [myskiplist size]
	set search [myskiplist search 999]
	myskiplist destroy
	
	if {$size != 1} {
		return "size is $size but should be 1"
	}
	set search
} "1 value_999"




test skiplist-3.0 {search} {
	struct::skiplist myskiplist
	myskiplist insert 5 value_5
	myskiplist insert 4 value_4
	myskiplist insert 3 value_3
	set t [myskiplist search 4]
	myskiplist destroy
	set t
}  "1 value_4"

test skiplist-3.1 {search} {
	struct::skiplist myskiplist
	myskiplist insert 5 value_5
	myskiplist insert 4 value_4
	myskiplist insert 3 value_3
	set t [myskiplist search 14]
	myskiplist destroy
	set t
}  "0"


test skiplist-4.0 {size} {
	struct::skiplist myskiplist
	myskiplist insert 5 value_5
	myskiplist insert 4 value_4
	myskiplist insert 3 value_3
	set t [myskiplist size]
	myskiplist destroy
	set t
}  "3"

test skiplist-4.1 {size} {
	struct::skiplist myskiplist
	for {set i 0} {$i < 500} {incr i} {
		myskiplist insert $i value_$i
	}
	set t [myskiplist size]
	myskiplist destroy
	set t
}  "500"



test skiplist-5.0 {walk} {
	struct::skiplist myskiplist
	myskiplist insert 5 value_5
	myskiplist insert 4 value_4
	myskiplist insert 3 value_3
	set t [list ]
	myskiplist walk {lappend t }
	myskiplist destroy
	set t
} "3 value_3 4 value_4 5 value_5"

test skiplist-5.1 {walk} {
	struct::skiplist myskiplist
	foreach a [shuffle 500] {
		set a2 [expr {$a + 1}]
		myskiplist insert $a $a2
	}
	set t [list ]
	myskiplist walk {lappend t}
	myskiplist destroy
	set sum 0
	set sum2 0
	foreach {key value} $t {
		set sum [expr {$sum + $key}]
		set sum2 [expr {$sum2 + $value}]
	}
	set sum "$sum $sum2"
}  "124750 125250"

test skiplist-5.2 {walk} {
	struct::skiplist myskiplist1
	struct::skiplist myskiplist2
	foreach a [shuffle 500] {
		myskiplist1 insert $a value_$a
	}
	myskiplist1 walk {myskiplist2 insert }
	set size [myskiplist2 size]
	myskiplist1 destroy
	myskiplist2 destroy
	set size
} "500"

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/stack.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
[manpage_begin stack n 1.2.1]
[moddesc   {Tcl Data Structures}]
[titledesc {Create and manipulate stack objects}]
[require Tcl 8.2]
[require struct [opt 1.3]]
[description]

The [cmd ::struct::stack] command creates a new stack object with an
associated global Tcl command whose name is [emph stackName].  This
command may be used to invoke various operations on the stack.  It has
the following general form:

[list_begin definitions]

[call [arg stackName] [cmd option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.  The following commands are possible for stack objects:


[call [arg stackName] [cmd clear]]

Remove all items from the stack.


[call [arg stackName] [cmd destroy]]

Destroy the stack, including its storage space and associated command.


[call [arg stackName] [cmd peek] [opt "[arg count]"]]

Return the top [arg count] items of the stack, without removing them from
the stack.  If [arg count] is not specified, it defaults to 1.  If
[arg count] is 1, the result is a simple string; otherwise, it is a
list.  If specified, [arg count] must be greater than or equal to 1.
If there are no items on the stack, this command will return

[arg count] empty strings.


[call [arg stackName] [cmd pop] [opt "[arg count]"]]

Return the top [arg count] items of the stack, and remove them
from the stack.  If [arg count] is not specified, it defaults to 1.
If [arg count] is 1, the result is a simple string; otherwise, it is a
list.  If specified, [arg count] must be greater than or equal to 1.
If there are no items on the stack, this command will return

[arg count] empty strings.


[call [arg stackName] [cmd push] [arg item] [opt "[arg "item ..."]"]]

Push the [arg item] or items specified onto the stack.  If more than
one [arg item] is given, they will be pushed in the order they are
listed.


[call [arg stackName] [cmd size]]

Return the number of items on the stack.


[list_end]

[keywords queue matrix tree graph]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































Deleted modules/struct/stack.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: stack.n,v 1.6 2002/02/01 22:59:09 andreas_kupries Exp $
'\" 
.so man.macros
.TH stack n 1.2.1 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::stack \- Create and manipulate stack objects
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require struct ?1.2.1?\fR
.sp
\fB::struct::stack\fR \fIstackName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::stack\fR command creates a new stack object with an
associated global Tcl command whose name is \fIstackName\fR.  This command
may be used to invoke various operations on the stack.  It has the
following general form:
.CS
\fIstackName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  The following
commands are possible for stack objects:
.TP
\fIstackName \fBclear\fR
Remove all items from the stack.
.TP
\fIstackName \fBdestroy\fR
Destroy the stack, including its storage space and associated command.
.TP
\fIstackName \fBpeek\fR ?\fIcount\fR?
Return the top \fIcount\fR items of the stack, without removing them
from the stack.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items on the stack, this command will return \fIcount\fR
empty strings.
.TP
\fIstackName \fBpop\fR ?\fIcount\fR?
Return the top \fIcount\fR items of the stack and remove them
from the stack.  If \fIcount\fR is not specified, it defaults to 1.
If \fIcount\fR is 1, the result is a simple string; otherwise, it is a list.
If specified, \fIcount\fR must be greater than or equal to 1.  If
there are no items on the stack, this command will return \fIcount\fR
empty strings.
.TP
\fIstackName \fBpush\fR \fIitem\fR ?\fIitem ...\fR?
Push the item or items specified onto the stack.  If more than one
item is given, they will be pushed in the order they are listed.
.TP
\fIstackName \fBsize\fR
Return the number of items on the stack.

.SH KEYWORDS
stack, queue
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































Deleted modules/struct/stack.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
# stack.tcl --
#
#	Stack implementation for Tcl.
#
# 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: stack.tcl,v 1.3 2000/06/02 18:43:56 ericm Exp $

namespace eval ::struct {}

namespace eval ::struct::stack {
    # The stacks array holds all of the stacks you've made
    variable stacks
    
    # counter is used to give a unique name for unnamed stacks
    variable counter 0

    # commands is the list of subcommands recognized by the stack
    variable commands [list \
	    "clear"	\
	    "destroy"	\
	    "peek"	\
	    "pop"	\
	    "push"	\
	    "rotate"	\
	    "size"	\
	    ]

    # Only export one command, the one used to instantiate a new stack
    namespace export stack
}

# ::struct::stack::stack --
#
#	Create a new stack with a given name; if no name is given, use
#	stackX, where X is a number.
#
# Arguments:
#	name	name of the stack; if null, generate one.
#
# Results:
#	name	name of the stack created

proc ::struct::stack::stack {{name ""}} {
    variable stacks
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "stack${counter}"
    }

    if { ![string equal [info commands ::$name] ""] } {
	error "command \"$name\" already exists, unable to create stack"
    }
    set stacks($name) [list ]

    # Create the command to manipulate the stack
    interp alias {} ::$name {} ::struct::stack::StackProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::stack::StackProc --
#
#	Command that processes all stack object commands.
#
# Arguments:
#	name	name of the stack object to manipulate.
#	args	command name and args for the command
#
# Results:
#	Varies based on command to perform

proc ::struct::stack::StackProc {name cmd args} {
    # Split the args into command and args components
    if { [lsearch -exact $::struct::stack::commands $cmd] == -1 } {
	set optlist [join $::struct::stack::commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::stack::_$cmd $name] $args
}

# ::struct::stack::_clear --
#
#	Clear a stack.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	None.

proc ::struct::stack::_clear {name} {
    set ::struct::stack::stacks($name) [list ]
    return
}

# ::struct::stack::_destroy --
#
#	Destroy a stack object by removing it's storage space and 
#	eliminating it's proc.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	None.

proc ::struct::stack::_destroy {name} {
    unset ::struct::stack::stacks($name)
    interp alias {} ::$name {}
    return
}

# ::struct::stack::_peek --
#
#	Retrive the value of an item on the stack without popping it.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to pop; defaults to 1
#
# Results:
#	items	top count items from the stack; if there are not enough items
#		to fufill the request, throws an error.

proc ::struct::stack::_peek {name {count 1}} {
    variable stacks
    if { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count > [llength $stacks($name)] } {
	error "insufficient items on stack to fill request"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	set item [lindex $stacks($name) end]
	return $item
    }

    # Otherwise, return a list of items
    set result [list ]
    for {set i 0} {$i < $count} {incr i} {
	lappend result [lindex $stacks($name) "end-${i}"]
    }
    return $result
}

# ::struct::stack::_pop --
#
#	Pop an item off a stack.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to pop; defaults to 1
#
# Results:
#	item	top count items from the stack; if the stack is empty, 
#		returns a list of count nulls.

proc ::struct::stack::_pop {name {count 1}} {
    variable stacks
    if { $count > [llength $stacks($name)] } {
	error "insufficient items on stack to fill request"
    } elseif { $count < 1 } {
	error "invalid item count $count"
    }

    if { $count == 1 } {
	# Handle this as a special case, so single item pops aren't listified
	set item [lindex $stacks($name) end]
	set stacks($name) [lreplace $stacks($name) end end]
	return $item
    }

    # Otherwise, return a list of items
    set result [list ]
    for {set i 0} {$i < $count} {incr i} {
	lappend result [lindex $stacks($name) "end-${i}"]
    }

    # Remove these items from the stack
    incr i -1
    set stacks($name) [lreplace $stacks($name) "end-${i}" end]

    return $result
}

# ::struct::stack::_push --
#
#	Push an item onto a stack.
#
# Arguments:
#	name	name of the stack object
#	args	items to push.
#
# Results:
#	None.

proc ::struct::stack::_push {name args} {
    if { [llength $args] == 0 } {
	error "wrong # args: should be \"$name push item ?item ...?\""
    }
    foreach item $args {
	lappend ::struct::stack::stacks($name) $item
    }
}

# ::struct::stack::_rotate --
#
#	Rotate the top count number of items by step number of steps.
#
# Arguments:
#	name	name of the stack object.
#	count	number of items to rotate.
#	steps	number of steps to rotate.
#
# Results:
#	None.

proc ::struct::stack::_rotate {name count steps} {
    variable stacks
    set len [llength $stacks($name)]
    if { $count > $len } {
	error "insufficient items on stack to fill request"
    }

    # Rotation algorithm:
    # do
    #   Find the insertion point in the stack
    #   Move the end item to the insertion point
    # repeat $steps times

    set start [expr {$len - $count}]
    set steps [expr {$steps % $count}]
    for {set i 0} {$i < $steps} {incr i} {
	set item [lindex $stacks($name) end]
	set stacks($name) [lreplace $stacks($name) end end]
	set stacks($name) [linsert $stacks($name) $start $item]
    }
    return
}

# ::struct::stack::_size --
#
#	Return the number of objects on a stack.
#
# Arguments:
#	name	name of the stack object.
#
# Results:
#	count	number of items on the stack.

proc ::struct::stack::_size {name} {
    return [llength $::struct::stack::stacks($name)]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































Deleted modules/struct/stack.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] stack.tcl]
namespace import struct::stack::stack

test stack-0.1 {stack errors} {
    stack mystack
    catch {stack mystack} msg
    mystack destroy
    set msg
} "command \"mystack\" already exists, unable to create stack"
test stack-0.2 {stack errors} {badTest} {
    stack mystack
    catch {mystack} msg
    mystack destroy
    set msg
} "wrong # args: should be \"mystack option ?arg arg ...?\""
test stack-0.3 {stack errors} {
    stack mystack
    catch {mystack foo} msg
    mystack destroy
    set msg
} "bad option \"foo\": must be clear, destroy, peek, pop, push, rotate, or size"
test stack-0.4 {stack errors} {
    catch {stack set} msg
    set msg
} "command \"set\" already exists, unable to create stack"

test stack-1.1 {stack creation} {
    set foo [stack mystack]
    set cmd [info commands ::mystack]
    set size [mystack size]
    mystack destroy
    list $foo $cmd $size
} {mystack ::mystack 0}
test stack-1.2 {stack creation} {
    set foo [stack]
    set cmd [info commands ::$foo]
    set size [$foo size]
    $foo destroy
    list $foo $cmd $size
} {stack1 ::stack1 0}

test stack-2.1 {stack destroy} {
    stack mystack
    mystack destroy
    info commands ::mystack
} {}

test stack-3.2 {size operation} {
    stack mystack
    mystack push a b c d e f g
    set size [mystack size]
    mystack destroy
    set size
} 7
test stack-3.3 {size operation} {
    stack mystack
    mystack push a b c d e f g
    mystack pop 3
    set size [mystack size]
    mystack destroy
    set size
} 4
test stack-3.4 {size operation} {
    stack mystack
    mystack push a b c d e f g
    mystack pop 3
    mystack peek 3
    set size [mystack size]
    mystack destroy
    set size
} 4
    
test stack-4.1 {push operation} {
    stack mystack
    catch {mystack push} msg
    mystack destroy
    set msg
} "wrong # args: should be \"mystack push item ?item ...?\""
test stack-4.2 {push operation, singleton items} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} "c b a"
test stack-4.3 {push operation, multiple items} {
    stack mystack
    mystack push a b c
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} "c b a"
test stack-4.4 {push operation, spaces in items} {
    stack mystack
    mystack push a b "foo bar"
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} [list "foo bar" b a]
test stack-4.5 {push operation, bad chars in items} {
    stack mystack
    mystack push a b \{
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} [list \{ b a]

test stack-5.1 {pop operation} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack pop] [mystack pop] [mystack pop]]
    mystack destroy
    set result
} [list c b a]
test stack-5.2 {pop operation, multiple items} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [mystack pop 3]
    mystack destroy
    set result
} [list c b a]

test stack-6.1 {peek operation} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack peek] [mystack peek] [mystack peek]]
    mystack destroy
    set result
} [list c c c]

test stack-6.2 {peek operation} {
    stack mystack
    catch {mystack peek 0} msg
    mystack destroy
    set msg
} {invalid item count 0}
test stack-6.3 {peek operation} {
    stack mystack
    catch {mystack peek -1} msg
    mystack destroy
    set msg
} {invalid item count -1}
test stack-6.4 {peek operation} {
    stack mystack
    catch {mystack peek} msg
    mystack destroy
    set msg
} {insufficient items on stack to fill request}
test stack-6.5 {peek operation} {
    stack mystack
    mystack push a
    catch {mystack peek 2} msg
    mystack destroy
    set msg
} {insufficient items on stack to fill request}

test stack-6.6 {pop operation, multiple items} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack peek 3] [mystack pop 3]]
    mystack destroy
    set result
} [list [list c b a] [list c b a]]

test stack-6.7 {pop operation} {
    stack mystack
    catch {mystack pop 0} msg
    mystack destroy
    set msg
} {invalid item count 0}
test stack-6.8 {pop operation} {
    stack mystack
    catch {mystack pop -1} msg
    mystack destroy
    set msg
} {invalid item count -1}
test stack-6.9 {pop operation} {
    stack mystack
    catch {mystack pop} msg
    mystack destroy
    set msg
} {insufficient items on stack to fill request}
test stack-6.10 {pop operation} {
    stack mystack
    mystack push a
    catch {mystack pop 2} msg
    mystack destroy
    set msg
} {insufficient items on stack to fill request}

test stack-7.1 {clear operation} {
    stack mystack
    mystack push a
    mystack push b
    mystack push c
    set result [list [mystack peek 3]]
    mystack clear
    lappend result [mystack size]
    mystack destroy
    set result
} [list [list c b a] 0]

test stack-8.1 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 3 1
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list g f h e d c b a]
test stack-8.2 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 3 2
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list f h g e d c b a]
test stack-8.3 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 3 5
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list f h g e d c b a]
test stack-8.4 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 8 1
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list g f e d c b a h]
test stack-8.4 {rotate operation} {
    stack mystack
    mystack push a b c d e f g h
    mystack rotate 8 -1
    set result [mystack peek [mystack size]]
    mystack destroy
    set result
} [list a h g f e d c b]

test stack-8.5 {rotate operation} {
    stack mystack
    catch {mystack rotate 8 -1} msg
    mystack destroy
    set msg
} {insufficient items on stack to fill request}
test stack-8.6 {rotate operation} {
    stack mystack
    mystack push a b c d
    catch {mystack rotate 8 -1} msg
    mystack destroy
    set msg
} {insufficient items on stack to fill request}

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































Deleted modules/struct/struct.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
package require Tcl 8.2
package provide struct 1.3

source [file join [file dirname [info script]] graph.tcl]
source [file join [file dirname [info script]] queue.tcl]
source [file join [file dirname [info script]] stack.tcl]
source [file join [file dirname [info script]] tree.tcl]
source [file join [file dirname [info script]] matrix.tcl]
source [file join [file dirname [info script]] pool.tcl]
source [file join [file dirname [info script]] record.tcl]
source [file join [file dirname [info script]] list.tcl]
source [file join [file dirname [info script]] prioqueue.tcl]
source [file join [file dirname [info script]] skiplist.tcl]

namespace eval ::struct {
    namespace import -force graph::*
    namespace import -force queue::*
    namespace import -force stack::*
    namespace import -force tree::*
    namespace import -force matrix::*
    namespace import -force pool::*
    namespace import -force record::*
    namespace import -force list::*
    namespace import -force prioqueue::*
    namespace import -force skiplist::*
    namespace export *
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































Deleted modules/struct/struct_list.man.

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

[para]

The [cmd ::struct::list] namespace contains several useful commands
for processing Tcl lists. Generally speaking, they implement
algorithms more complex or specialized than the ones provided by Tcl
itself.

[para]

It exports only a single command, [cmd struct::list]. All
functionality provided here can be reached through a subcommand of
this command.

[section COMMANDS]
[list_begin definitions]

[call [cmd ::struct::list] [method longestCommonSubsequence] \
	[arg sequence1] [arg sequence2] [opt [arg maxOccurs]]]

Returns the longest common subsequence of elements in the two lists
[arg sequence1] and [arg sequence2]. If the [arg maxOccurs] parameter
is provided, the common subsequence is restricted to elements that
occur no more than [arg maxOccurs] times in [arg sequence2].

[nl]

The return value is a list of two lists of equal length. The first
sublist is of indices into [arg sequence1], and the second sublist is
of indices into [arg sequence2].  Each corresponding pair of indices
corresponds to equal elements in the sequences; the sequence returned
is the longest possible.

[call [cmd ::struct::list] [method longestCommonSubsequence2] \
	[arg {sequence1 sequence2}] [opt [arg maxOccurs]]]

Returns an approximation to the longest common sequence of elements in
the two lists [arg sequence1] and [arg sequence2].

If the [arg maxOccurs] parameter is omitted, the subsequence computed
is exactly the longest common subsequence; otherwise, the longest
common subsequence is approximated by first determining the longest
common sequence of only those elements that occur no more than

[arg maxOccurs] times in [arg sequence2], and then using that result
to align the two lists, determining the longest common subsequences of
the sublists between the two elements.

[nl]

As with [method longestCommonSubsequence], the return value is a list
of two lists of equal length.  The first sublist is of indices into
[arg sequence1], and the second sublist is of indices into

[arg sequence2].  Each corresponding pair of indices corresponds to
equal elements in the sequences.  The sequence approximates the
longest common subsequence.


[call [cmd ::struct::list] [method lcsInvert] [arg lcsData] [arg len1] [arg len2]]

This command takes a description of a longest common subsequence

([arg lcsData]), inverts it, and returns the result. Inversion means
here that as the input describes which parts of the two sequences are
identical the output describes the differences instead.

[nl]

To be fully defined the lengths of the two sequences have to be known
and are specified through [arg len1] and [arg len2].

[nl]

The result is a list where each element describes one chunk of the
differences between the two sequences. This description is a list
containing three elements, a type and two pairs of indices into

[arg sequence1] and [arg sequence2] respectively, in this order.

The type can be one of three values:

[list_begin definitions]
[lst_item [const added]]

Describes an addition. I.e. items which are missing in [arg sequence1]
can be found in [arg sequence2].

The pair of indices into [arg sequence1] describes where the added
range had been expected to be in [arg sequence1]. The first index
refers to the item just before the added range, and the second index
refers to the item just after the added range.

The pair of indices into [arg sequence2] describes the range of items
which has been added to it. The first index refers to the first item
in the range, and the second index refers to the last item in the
range.

[lst_item [const deleted]]

Describes a deletion. I.e. items which are in [arg sequence1] are
missing from [arg sequence2].

The pair of indices into [arg sequence1] describes the range of items
which has been deleted. The first index refers to the first item in
the range, and the second index refers to the last item in the range.

The pair of indices into [arg sequence2] describes where the deleted
range had been expected to be in [arg sequence2]. The first index
refers to the item just before the deleted range, and the second index
refers to the item just after the deleted range.

[lst_item [const changed]]

Describes a general change. I.e a range of items in [arg sequence1]
has been replaced by a different range of items in [arg sequence2].

The pair of indices into [arg sequence1] describes the range of items
which has been replaced. The first index refers to the first item in
the range, and the second index refers to the last item in the range.

The pair of indices into [arg sequence2] describes the range of items
replacing the original range. Again the first index refers to the
first item in the range, and the second index refers to the last item
in the range.

[list_end]

[nl]
[example {
    sequence 1 = {a b r a c a d a b r a}
    lcs 1      =   {1 2   4 5     8 9 10}
    lcs 2      =   {0 1   3 4     5 6 7}
    sequence 2 =   {b r i c a     b r a c}

    Inversion  = {{deleted  {0  0} {-1 0}}
                  {changed  {3  3}  {2 2}}
                  {deleted  {6  7}  {4 5}}
                  {added   {10 11}  {8 8}}}
}]

[emph Notes:]
[nl]
[list_begin bullet]
[bullet]
An index of [const -1] in a [term deleted] chunk refers to just before
the first element of the second sequence.

[bullet]
Also an index equal to the length of the first sequence in an
[term added] chunk refers to just behind the end of the sequence.

[list_end]


[call [cmd ::struct::list] [method lcsInvert2] [arg lcs1] [arg lcs2] [arg len1] [arg len2]]

Similar to [method lcsInvert]. Instead of directly taking the result
of a call to [method longestCommonSubsequence] this subcommand expects
the indices for the two sequences in two separate lists.


[call [cmd ::struct::list] [method lcsInvertMerge] [arg lcsData] [arg len1] [arg len2]]

Similar to [method lcsInvert]. It returns essentially the same
structure as that command, except that it may contain chunks of type
[const unchanged] too.

[nl]

These new chunks describe the parts which are unchanged between the
two sequences. This means that the result of this command describes
both the changed and unchanged parts of the two sequences in one
structure.

[nl]
[example {
    sequence 1 = {a b r a c a d a b r a}
    lcs 1      =   {1 2   4 5     8 9 10}
    lcs 2      =   {0 1   3 4     5 6 7}
    sequence 2 =   {b r i c a     b r a c}

    Inversion/Merge  = {{deleted   {0  0} {-1 0}}
                        {unchanged {1  2}  {0 1}}
                        {changed   {3  3}  {2 2}}
                        {unchanged {4  5}  {3 4}}
                        {deleted   {6  7}  {4 5}}
                        {unchanged {8 10}  {5 7}}
                        {added    {10 11}  {8 8}}}
}]


[call [cmd ::struct::list] [method lcsInvertMerge2] [arg lcs1] [arg lcs2] [arg len1] [arg len2]]

Similar to [method lcsInvertMerge]. Instead of directly taking the
result of a call to [method longestCommonSubsequence] this subcommand
expects the indices for the two sequences in two separate lists.



[call [cmd ::struct::list] [method reverse] [arg sequence]]

The subcommand takes a single [arg sequence] as argument and returns a new
sequence containing the elements of the input sequence in reverse
order.


[call [cmd ::struct::list] [method assign] [arg sequence] [opt [arg varname]]...]

The subcommand assigns the first [var n] elements of the input

[arg sequence] to the zero or more variables whose names were listed
after the sequence, where [var n] is the number of specified
variables.

[nl]

If there are more variables specified than there are elements in the
[arg sequence] the empty string will be assigned to the superfluous
variables.

[nl]

If there are more elements in the [arg sequence] than variable names
specified the subcommand returns a list containing the unassigned
elements. Else an empty list is returned.

[example {
    tclsh> ::struct::list assign {a b c d e} foo bar
    c d e
    tclsh> set foo
    a
    tclsh> set bar
    b
}]


[call [cmd ::struct::list] [method flatten] [opt [option -full]] [opt [option --]] [arg sequence]]

The subcommand takes a single [arg sequence] and returns a new
sequence where one level of nesting was removed from the input
sequence. In other words, the sublists in the input sequence are
replaced by their elements.

[nl]

The subcommand will remove any nesting it finds if the option
[option -full] is specified.

[example {
    tclsh> ::struct::list flatten {1 2 3 {4 5} {6 7} {{8 9}} 10}
    1 2 3 4 5 6 7 {8 9} 10
    tclsh> ::struct::list flatten -full {1 2 3 {4 5} {6 7} {{8 9}} 10}
    1 2 3 4 5 6 7 8 9 10
}]


[call [cmd ::struct::list] [method map] [arg sequence] [arg cmdprefix]]

The subcommand takes a [arg sequence] to operate on and a command
prefix ([arg cmdprefix]) specifying an operation, applies the command
prefix to each element of the sequence and returns a sequence
consisting of the results of that application.

[nl]

The command prefix will be evaluated with a single word appended to
it. The evaluation takes place in the context of the caller of the
subcommand.

[nl]

[example {
    tclsh> # squaring all elements in a list

    tclsh> proc sqr {x} {expr {$x*$x}}
    tclsh> ::struct::list map {1 2 3 4 5} sqr
    1 4 9 16 25

    tclsh> # Retrieving the second column from a matrix
    tclsh> # given as list of lists.

    tclsh> proc projection {n list} {::lindex $list $n}
    tclsh> ::struct::list map {{a b c} {1 2 3} {d f g}} {projection 1}
    b 2 f
}]


[call [cmd ::struct::list] [method fold] [arg sequence] [arg initialvalue] [arg cmdprefix]]

The subcommand takes a [arg sequence] to operate on, an arbitrary
string [arg {initial value}] and a command prefix ([arg cmdprefix])
specifying an operation.

[nl]

The command prefix will be evaluated with two words appended to
it. The second of these words will always be an element of the
sequence. The evaluation takes place in the context of the caller of
the subcommand.

[nl]

It then reduces the sequence into a single value through repeated
application of the command prefix and returns that value. This
reduction is done by

[list_begin definitions]
[lst_item [const 1]]

Application of the command to the initial value and the first element
of the list.

[lst_item [const 2]]

Application of the command to the result of the last call and the
second element of the list.

[lst_item [const ...]]
[lst_item [const i]]

Application of the command to the result of the last call and the
[var i]'th element of the list.

[lst_item [const ...]]
[lst_item [const end]]

Application of the command to the result of the last call and the last
element of the list. The result of this call is returned as the result
of the subcommand.

[list_end]
[nl]
[example {
    tclsh> # summing the elements in a list.
    tclsh> proc + {a b} {expr {$a + $b}}
    tclsh> ::listx fold {1 2 3 4 5} 0 +
    15
}]

[call [cmd ::struct::list] [method iota] [arg n]]

The subcommand returns a list containing the integer numbers
in the range [const {[0,n)}]. The element at index [var i]
of the list contain the number [const i].

[nl]

For "[arg n] == [const 0]" an empty list will be returned.


[call [cmd ::struct::list] [method equal] [arg a] [arg b]]

The subcommand compares the two lists [arg a] and [arg b] for
equality. In other words, they have to be of the same length and have
to contain the same elements in the same order. If an element is a
list the same definition of equality applies recursively.

[nl]

A boolean vlaue will be returned as the result of the command.
This value will be [const true] if the two lists are equal, and
[const false] else.


[call [cmd ::struct::list] [method repeat] [arg value] [arg size]...]

The subcommand creates a (nested) list containing the [arg value] in
all positions. The exact size and degree of nesting is determined by
the [arg size] arguments, all of which have to be integer numbers
greater than or equal to zero.

[nl]

A single argument [arg size] which is a list of more than one element
will be treated as if more than argument [arg size] was specified.

[nl]

If only one argument [arg size] is present the returned list will not
be nested, of length [arg size] and contain [arg value] in all
positions.

If more than one [arg size] argument is present the returned
list will be nested, and of the length specified by the last
[arg size] argument given to it. The elements of that list
are defined as the result of [cmd Repeat] for the same arguments,
but with the last [arg size] value removed.

[nl]

An empty list will be returned if no [arg size] arguments are present.

[nl]
[example {
    tclsh> lrepeat  0 3 4
    {0 0 0} {0 0 0} {0 0 0} {0 0 0}
    tclsh> lrepeat  0 {3 4}
    {0 0 0} {0 0 0} {0 0 0} {0 0 0}
    tclsh> lrepeat  0 {3 4 5}
    {{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}}
}]


[list_end]

[section {LONGEST COMMON SUBSEQUENCE AND FILE COMPARISON}]

[para]

The [method longestCommonSubsequence] subcommand forms the core of a
flexible system for doing differential comparisons of files, similar
to the capability offered by the Unix command [syscmd diff].

While this procedure is quite rapid for many tasks of file comparison,
its performance degrades severely if [arg sequence2] contains many
equal elements (as, for instance, when using this procedure to compare
two files, a quarter of whose lines are blank.  This drawback is
intrinsic to the algorithm used (see the Reference for details).

[para]

One approach to dealing with the performance problem that is sometimes
effective in practice is arbitrarily to exclude elements that appear
more than a certain number of times. 

This number is provided as the [arg maxOccurs] parameter.  If frequent
lines are excluded in this manner, they will not appear in the common
subsequence that is computed; the result will be the longest common
subsequence of infrequent elements.

The procedure [method longestCommonSubsequence2] implements this
heuristic.

It functions as a wrapper around [method longestCommonSubsequence]; it
computes the longest common subsequence of infrequent elements, and
then subdivides the subsequences that lie between the matches to
approximate the true longest common subsequence.

[section REFERENCES]

J. W. Hunt and M. D. McIlroy, "An algorithm for differential 
file comparison," Comp. Sci. Tech. Rep. #41, Bell Telephone 
Laboratories (1976). Available on the Web at the second
author's personal site: [uri http://www.cs.dartmouth.edu/~doug/]

[keywords list diff differential comparison common subsequence]
[keywords {longest common subsequence}]
[keywords reverse]
[keywords assign]
[keywords flatten]
[keywords map]
[keywords folding reduce]
[keywords equality equal repetition repeating]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/tree.man.

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

The [cmd ::struct::tree] command creates a new tree object with an
associated global Tcl command whose name is [arg treeName]. This
command may be used to invoke various operations on the tree. It has
the following general form:

[list_begin definitions]
[call [cmd treeName] [method option] [opt [arg "arg arg ..."]]]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.

[list_end]

[para]

A tree is a collection of elements, called nodes, one of which is
distinguished as a root, along with a relation ("parenthood") that
places a hierarchical structure on the nodes. (Data Structures and
Algorithms; Aho, Hopcroft and Ullman; Addison-Wesley, 1987).  In
addition to maintaining the node relationships, this tree
implementation allows any number of keyed values to be associated with
each node.

[para]

The following commands are possible for tree objects:

[list_begin definitions]

[call [arg treeName] [method append] [arg node] [opt "-key [arg key]"] [arg value]]

Appends a [arg value] to one of the keyed values associated with an
node. If no [arg key] is specified, the key [const data] is assumed.


[call [arg treeName] [method children] [arg node]]

Return a list of the children of [arg node].


[call [arg treeName] [method cut] [arg node]]

Removes the node specified by [arg node] from the tree, but not its
children.  The children of [arg node] are made children of the parent
of the [arg node], at the index at which [arg node] was located.


[call [arg treeName] [method delete] [arg node] [opt "[arg node] ..."]]

Remove the specified nodes from the tree.  All of the nodes' children
will be removed as well to prevent orphaned nodes.


[call [arg treeName] [method depth] [arg node]]

Return the number of steps from node [arg node] to the root node.


[call [arg treeName] [method destroy]]

Destroy the tree, including its storage space and associated command.


[call [arg treeName] [method exists] [arg node]]

Remove true if the specified node exists in the tree.


[call [arg treeName] [method get] [arg node] [opt "[option -key] [arg key]"]]

Return the value associated with the key [arg key] for the node

[arg node]. If no key is specified, the key [const data] is assumed.

[call [arg treeName] [method getall] [arg node]]

Returns a serialized list of key/value pairs (suitable for use with
[lb][cmd {array set}][rb]) for the [arg node].


[call [arg treeName] [method keys] [arg node]]

Returns a list of keys for the [arg node].


[call [arg treeName] [method keyexists] [arg node] [opt "-key [arg key]"]]

Return true if the specified [arg key] exists for the [arg node]. If
no [arg key] is specified, the key [const data] is assumed.


[call [arg treeName] [method index] [arg node]]

Returns the index of [arg node] in its parent's list of children.  For
example, if a node has [term nodeFoo], [term nodeBar], and

[term nodeBaz] as children, in that order, the index of

[term nodeBar] is 1.


[call [arg treeName] [method insert] [arg parent] [arg index] [opt "[arg child] [opt "[arg child] ..."]"]]

Insert one or more nodes into the tree as children of the node

[arg parent]. The nodes will be added in the order they are given. If
[arg parent] is [const root], it refers to the root of the tree. The
new nodes will be added to the [arg parent] node's child list at the
index given by [arg index]. The [arg index] can be [const end] in
which case the new nodes will be added after the current last child.

[nl]

If any of the specified children already exist in [arg treeName],
those nodes will be moved from their original location to the new
location indicated by this command.

[nl]

If no [arg child] is specified, a single node will be added, and a
name will be generated for the new node. The generated name is of the
form [emph node][var x], where [var x] is a number. If names are
specified they must neither contain whitespace nor colons (":").

[nl]

The return result from this command is a list of nodes added.


[call [arg treeName] [method isleaf] [arg node]]

Returns true if [arg node] is a leaf of the tree (if [arg node] has no
children), false otherwise.


[call [arg treeName] [method lappend] [arg node] [opt "-key [arg key]"] [arg value]]

Appends a [arg value] (as a list) to one of the keyed values
associated with an [arg node]. If no [arg key] is specified, the key
[const data] is assumed.


[call [arg treeName] [method move] [arg parent] [arg index] [arg node] [opt "[arg node] ..."]]

Make the specified nodes children of [arg parent], inserting them into
the parent's child list at the index given by [arg index]. Note that
the command will take all nodes out of the tree before inserting them
under the new parent, and that it determines the position to place
them into after the removal, before the re-insertion. This behaviour
is important when it comes to moving one or more nodes to a different
index without changing their parent node.

[call [arg treeName] [method next] [arg node] ]

Return the right sibling of [arg node], or the empty string if

[arg node] was the last child of its parent.


[call [arg treeName] [method numchildren] [arg node]]

Return the number of immediate children of [arg node].


[call [arg treeName] [method parent] [arg node]]

Return the parent of [arg node].


[call [arg treeName] [method previous] [arg node] ]

Return the left sibling of [arg node], or the empty string if

[arg node] was the first child of its parent.


[call [arg treeName] [method set] [arg node] [opt "[option -key] [arg key]"] [opt [arg value]]]

Set or get one of the keyed values associated with a node. If no key
is specified, the key [const data] is assumed.  Each node that is
added to a tree has the value "" assigned to the key [const data]
automatically.  A node may have any number of keyed values associated
with it.  If [arg value] is not specified, this command returns the
current value assigned to the key; if [arg value] is specified, this
command assigns that value to the key.


[call [arg treeName] [method size] [opt [arg node]]]


Return a count of the number of descendants of the node [arg node]; if
no node is specified, [const root] is assumed.


[call [arg treeName] [method splice] [arg parent] [arg from] [opt [arg to]] [opt [arg child]]]

Insert a node named [arg child] into the tree as a child of the node
[arg parent]. If [arg parent] is [const root], it refers to the root
of the tree. The new node will be added to the parent node's child
list at the index given by [arg from].  The children of [arg parent]
which are in the range of the indices [arg from] and [arg to] are made
children of [arg child].  If the value of [arg to] is not specified it
defaults to [const end].  If no name is given for [arg child], a name
will be generated for the new node.  The generated name is of the form
[emph node][var x], where [var x] is a number.  The return result
from this command is the name of the new node.


[call [arg treeName] [method swap] [arg node1] [arg node2]]

Swap the position of [arg node1] and [arg node2] in the tree.


[call [arg treeName] [method unset] [arg node] [opt "[option -key] [arg key]"]]

Remove a keyed value from the node [arg node].  If no key is
specified, the key [const data] is assumed.


[call [arg treeName] [method walk] [arg node] [opt "[option -order] [arg order]"] [opt "[option -type] [arg type]"] [option -command] [arg cmd]]

Perform a breadth-first or depth-first walk of the tree starting at
the node [arg node].  The type of walk, breadth-first or depth-first,
is determined by the value of [arg type]; [const bfs] indicates
breadth-first, [const dfs] indicates depth-first.  Depth-first is the
default. The order of the walk, pre-, post-, both- or in-order is
determined by the value of [arg order]; [const pre] indicates
pre-order, [const post] indicates post-order, [const both] indicates
both-order and [const in] indicates in-order. Pre-order is the
default.

[nl]

Pre-order walking means that a parent node is visited before any of
its children.  For example, a breadth-first search starting from the
root will visit the root, followed by all of the root's children,
followed by all of the root's grandchildren. Post-order walking means
that a parent node is visited after any of its children. Both-order
walking means that a parent node is visited before [emph and] after
any of its children. In-order walking means that a parent node is
visited after its first child and before the second. This is a
generalization of in-order walking for binary trees and will do the
right thing if a binary is walked. The combination of a breadth-first
walk with in-order is illegal.

[nl]

As the walk progresses, the command [arg cmd] will be evaluated at
each node.  Percent substitution will be performed on [arg cmd] before
evaluation, just as in a [cmd bind] script.  The following
substitutions are recognized:

[list_begin definitions]

[lst_item [const %%]]

Insert the literal % character.

[lst_item [const %t]]

Name of the tree object.

[lst_item [const %n]]

Name of the current node.

[lst_item [const %a]]

Name of the action occurring; one of [const enter], [const leave],
or [const visit].  [const enter] actions occur during pre-order
walks; [const leave] actions occur during post-order walks;

[const visit] actions occur during in-order walks.  In a both-order
walk, the command will be evaluated twice for each node; the action is
[const enter] for the first evaluation, and [const leave] for the
second.

[list_end]
[list_end]

[keywords tree]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































Deleted modules/struct/tree.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
'\"
'\" Copyright (c) 1998-2000 by Ajuba Solutions.
'\" All rights reserved.
'\" 
'\" RCS: @(#) $Id: tree.n,v 1.16 2002/05/09 05:46:04 andreas_kupries Exp $
'\" 
.so man.macros
.TH tree n 1.2.1 Struct "Tcl Data Structures"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::struct::tree \- Create and manipulate tree objects
.SH SYNOPSIS
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require struct ?1.2.1?\fR
.sp
\fB::struct::tree\fR \fItreeName\fR
.sp
.BE
.SH DESCRIPTION
.PP
The \fB::struct::tree\fR command creates a new tree object with an
associated global Tcl command whose name is \fItreeName\fR.  This command
may be used to invoke various operations on the tree.  It has the
following general form:
.CS
\fItreeName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs
determine the exact behavior of the command.  
.PP
A tree is a collection of elements, called nodes, one of which is
distinguished as a root, along with a relation ("parenthood") that
places a hierarchical structure on the nodes. (\fIData Structures and
Algorithms\fR; Aho, Hopcroft and Ullman; Addison-Wesley, 1987).  In
addition to maintaining the node relationships, this tree
implementation allows any number of keyed values to be associated with
each node.
.PP
The following commands are possible for tree objects:
.TP 
\fItreeName\fR \fBappend\fR \fInode\fR ?\fI-key key\fR? \fIvalue\fR
Appends a value to one of the keyed values associated with an node.
If no key is specified, the key \fBdata\fR is assumed.
.TP
\fItreeName\fR \fBchildren\fR \fInode\fR
Return a list of the children of \fInode\fR.
.TP
\fItreeName\fR \fBcut\fR \fInode\fR
Removes the node specified by \fInode\fR from the tree, but not its
children.  The children of \fInode\fR are made children of the parent of
the \fInode\fR, at the index at which \fInode\fR was located.
.TP
\fItreeName\fR \fBdelete\fR \fInode\fR ?\fInode\fR ...?
Remove the specified nodes from the tree.  All of the nodes' children
will be removed as well to prevent orphaned nodes.
.TP
\fItreeName \fBdepth\fR \fInode\fR
Return the number of steps from node \fInode\fR to the root node.
.TP
\fItreeName \fBdestroy\fR
Destroy the tree, including its storage space and associated command.
.TP
\fItreeName\fR \fBexists\fR \fInode\fR
Remove true if the specified node exists in the tree.
.TP
\fItreeName\fR \fBget\fR \fInode\fR ?\fI-key key\fR?
Return the value associated with the key \fIkey\fR for the node
\fInode\fR.  If no key is specified, the key \fBdata\fR is assumed.
.TP
\fItreeName\fR \fBgetall\fR \fInode\fR
Returns a serialized list of key/value pairs (suitable for use with
\fB[array set]\fR) for the \fInode\fR.
.TP
\fItreeName\fR \fBkeys\fR \fInode\fR
Returns a list of keys for the \fInode\fR.
.TP
\fItreeName\fR \fBkeyexists\fR \fInode\fR ?\fI-key key\fR?
Return true if the specified \fIkey\fR exists for the \fInode\fR.
If no key is specified, the key \fBdata\fR is assumed.
.TP
\fItreeName \fBindex\fR \fInode\fR
Returns the index of \fInode\fR in its parent's list of children.  For
example, if a node has \fBnodeFoo\fR, \fBnodeBar\fR, and \fBnodeBaz\fR as
children, in that order, the index of \fBnodeBar\fR is 1.
.TP
\fItreeName\fR \fBinsert\fR \fIparent\fR \fIindex\fR ?\fIchild\fR ?\fIchild ...\fR??
Insert one or more nodes into the tree as children of the node
\fIparent\fR.  The nodes will be added in the order they are given.
If \fIparent\fR is \fBroot\fR, it refers to the root of the tree.  The
new nodes will be added to the \fIparent\fR node's child list at the
index given by \fIindex\fR. The \fIindex\fR can be \fBend\fR in which
case the new nodes will be added after the current last child.

If any of the specified children already exist in \fItreeName\fR,
those nodes will be moved from their original location to the new
location indicated by this command.

If no \fIchild\fR is specified, a single node will be added, and a
name will be generated for the new node. The generated name is of the
form \fBnode\fR\fIx\fR, where \fIx\fR is a number. If names are
specified they must neither contain whitespace nor colons (\fB:\fR).

The return result from this command is a list of nodes added.
.TP
\fItreeName \fBisleaf\fR \fInode\fR
Returns true if \fInode\fR is a leaf of the tree (if \fInode\fR has no
children), false otherwise.
.TP
\fItreeName\fR \fBlappend\fR \fInode\fR ?\fI-key key\fR? \fIvalue\fR
Appends a value (as a list) to one of the keyed values associated with an node.
If no key is specified, the key \fBdata\fR is assumed. 
.TP
\fItreeName\fR \fBmove\fR \fIparent\fR \fIindex\fR \fInode\fR ?\fInode ...\fR?
Make the specified nodes children of \fIparent\fR, inserting them
into the parent's child list at the index given by \fIindex\fR.
.TP
\fItreeName\fR \fBnext\fR \fInode\fR 
Return the right sibling of \fInode\fR, or the empty string if
\fInode\fR was the last child of its parent.
.TP
\fItreeName\fR \fBnumchildren\fR \fInode\fR
Return the number of immediate children of \fInode\fR.
.TP
\fItreeName\fR \fBparent\fR \fInode\fR
Return the parent of \fInode\fR.
.TP
\fItreeName\fR \fBprevious\fR \fInode\fR 
Return the left sibling of \fInode\fR, or the empty string if
\fInode\fR was the first child of its parent.
.TP
\fItreeName\fR \fBset\fR \fInode\fR ?\fI-key key\fR? ?\fIvalue\fR?
Set or get one of the keyed values associated with a node.  If no key
is specified, the key \fBdata\fR is assumed.  Each node that is added
to a tree has the value "" assigned to the key \fBdata\fR
automatically.  A node may have any number of keyed values associated
with it.  If \fIvalue\fR is not specified, this command returns the
current value assigned to the key; if \fIvalue\fR is specified, this
command assigns that value to the key.
.TP
\fItreeName\fR \fBsize\fR ?\fInode\fR?
Return a count of the number of descendants of the node \fInode\fR; if
no node is specified, \fBroot\fR is assumed.
.TP
\fItreeName\fR \fBsplice\fR \fIparent\fR \fIfrom\fR ?\fIto\fR? ?\fIchild\fR?
Insert a node named \fIchild\fR into the tree as a child of the node
\fIparent\fR. If \fIparent\fR is \fBroot\fR, it refers to the root of
the tree. The new node will be added to the parent node's child list
at the index given by \fIfrom\fR.  The children of \fIparent\fR which
are in the range of the indices \fIfrom\fR and \fIto\fR are made
children of \fIchild\fR.  If the value of \fIto\fR is not specified it
defaults to \fBend\fR.  If no name is given for \fIchild\fR, a name
will be generated for the new node.  The generated name is of the form
\fBnode\fR\fIx\fR, where \fIx\fR is a number.  The return result from
this command is the name of the new node.
.TP
\fItreeName\fR \fBswap\fR \fInode1\fR \fInode2\fR
Swap the position of \fInode1\fR and \fInode2\fR in the tree.
.TP
\fItreeName\fR \fBunset\fR \fInode\fR ?\fI-key key\fR?
Remove a keyed value from the node \fInode\fR.  If no key is
specified, the key \fBdata\fR is assumed.
.TP
\fItreeName\fR \fBwalk\fR \fInode\fR ?\fI-order order\fR? ?\fI-type type\fR? \fI-command cmd\fR

Perform a breadth-first or depth-first walk of the tree starting at
the node \fInode\fR.  The type of walk, breadth-first or depth-first,
is determined by the value of \fItype\fR; \fBbfs\fR indicates
breadth-first, \fBdfs\fR indicates depth-first.  Depth-first is the
default. The order of the walk, pre-, post-, both- or in-order is
determined by the value of \fIorder\fR; \fBpre\fR indicates pre-order,
\fBpost\fR indicates post-order, \fBboth\fR indicates both-order and
\fBin\fR indicates in-order. Pre-order is the default.

Pre-order walking means that a parent node is visited before any of
its children.  For example, a breadth-first search starting from the
root will visit the root, followed by all of the root's children,
followed by all of the root's grandchildren. Post-order walking means
that a parent node is visited after any of its children. Both-order
walking means that a parent node is visited before \fBand\fR after any
of its children. In-order walking means that a parent node is visited
after its first child and before the second. This is a generalization
of in-order walking for binary trees and will do the right thing if a
binary is walked. The combination of a breadth-first walk with
in-order is illegal.

As the walk progresses, the command \fIcmd\fR will be evaluated at
each node.  Percent substitution will be performed on \fIcmd\fR before
evaluation, just as in a \fBbind\fR script.  The following
substitutions are recognized:
.RS
.IP \fB%%\fR
Insert the literal % character.
.IP \fB%t\fR
Name of the tree object.
.IP \fB%n\fR
Name of the current node.
.IP \fB%a\fR
Name of the action occurring; one of \fBenter\fR, \fBleave\fR, or
\fBvisit\fR.  \fBenter\fR actions occur during pre-order walks;
\fBleave\fR actions occur during post-order walks; \fBvisit\fR actions
occur during in-order walks.  In a both-order walk, the command will
be evaluated twice for each node; the action is \fBenter\fR for the
first evaluation, and \fBleave\fR for the second.
.RE

.SH KEYWORDS
tree
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































Deleted modules/struct/tree.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
# tree.tcl --
#
#	Implementation of a tree data structure for Tcl.
#
# 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: tree.tcl,v 1.18 2002/08/06 20:52:54 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::struct {}

namespace eval ::struct::tree {
    # Data storage in the tree module
    # -------------------------------
    #
    # There's a lot of bits to keep track of for each tree:
    #	nodes
    #	node values
    #	node relationships
    #
    # It would quickly become unwieldy to try to keep these in arrays or lists
    # within the tree namespace itself.  Instead, each tree structure will get
    # its own namespace.  Each namespace contains:
    #	children	array mapping nodes to their children list
    #	parent		array mapping nodes to their parent node
    #	node:$node	array mapping keys to values for the node $node
    
    # counter is used to give a unique name for unnamed trees
    variable counter 0

    # commands is the list of subcommands recognized by the tree
    variable commands [list \
	    "append"		\
	    "children"		\
	    "cut"		\
	    "destroy"		\
	    "delete"		\
	    "depth"		\
	    "exists"		\
	    "get"		\
	    "getall"		\
	    "index"		\
	    "insert"		\
	    "isleaf"		\
	    "keys"		\
	    "keyexists"		\
	    "lappend"		\
	    "move"		\
	    "next"		\
	    "numchildren"	\
	    "parent"		\
	    "previous"		\
	    "set"		\
	    "size"		\
	    "splice"		\
	    "swap"		\
	    "unset"		\
	    "walk"		\
	    ]

    # Only export one command, the one used to instantiate a new tree
    namespace export tree
}

# ::struct::tree::tree --
#
#	Create a new tree with a given name; if no name is given, use
#	treeX, where X is a number.
#
# Arguments:
#	name	Optional name of the tree; if null or not given, generate one.
#
# Results:
#	name	Name of the tree created

proc ::struct::tree::tree {{name ""}} {
    variable counter
    
    if { [llength [info level 0]] == 1 } {
	incr counter
	set name "tree${counter}"
    }

    if { [llength [info commands ::$name]] } {
	error "command \"$name\" already exists, unable to create tree"
    }

    # Set up the namespace
    namespace eval ::struct::tree::tree$name {
	# Set up root node's child list
	variable children
	set children(root) [list ]

	# Set root node's parent
	variable parent
	set parent(root) [list ]

	# Set up the root node's data
	variable noderoot
	set noderoot(data) ""

	# Set up a value for use in creating unique node names
	variable nextUnusedNode
	set nextUnusedNode 1
    }

    # Create the command to manipulate the tree
    interp alias {} ::$name {} ::struct::tree::TreeProc $name

    return $name
}

##########################
# Private functions follow

# ::struct::tree::TreeProc --
#
#	Command that processes all tree object commands.
#
# Arguments:
#	name	Name of the tree object to manipulate.
#	cmd	Subcommand to invoke.
#	args	Arguments for subcommand.
#
# Results:
#	Varies based on command to perform

proc ::struct::tree::TreeProc {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 ::struct::tree::_$cmd]] == 0 } {
	variable commands
	set optlist [join $commands ", "]
	set optlist [linsert $optlist "end-1" "or"]
	error "bad option \"$cmd\": must be $optlist"
    }
    eval [list ::struct::tree::_$cmd $name] $args
}

# ::struct::tree::_children --
#
#	Return the child list for a given node of a tree.
#
# Arguments:
#	name	Name of the tree object.
#	node	Node to look up.
#
# Results:
#	children	List of children for the node.

proc ::struct::tree::_children {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::children children
    return $children($node)
}

# ::struct::tree::_cut --
#
#	Destroys the specified node of a tree, but not its children.
#	These children are made into children of the parent of the
#	destroyed node at the index of the destroyed node.
#
# Arguments:
#	name	Name of the tree object.
#	node	Node to look up and cut.
#
# Results:
#	None.

proc ::struct::tree::_cut {name node} {
    if { [string equal $node "root"] } {
	# Can't delete the special root node
	error "cannot cut root node"
    }
    
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::parent   parent
    upvar ::struct::tree::tree${name}::children children
    
    # Locate our parent, children and our location in the parent
    set parentNode $parent($node)
    set childNodes $children($node)
    
    set index [lsearch -exact $children($parentNode) $node]
    
    # Excise this node from the parent list, 
    set newChildren [lreplace $children($parentNode) $index $index]

    # Put each of the children of $node into the parent's children list,
    # in the place of $node, and update the parent pointer of those nodes.
    foreach child $childNodes {
	set newChildren [linsert $newChildren $index $child]
	set parent($child) $parentNode
	incr index
    }
    set children($parentNode) $newChildren

    # Remove all record of $node
    unset parent($node)
    unset children($node)
    # FRINK: nocheck
    unset ::struct::tree::tree${name}::node$node

    return
}

# ::struct::tree::_delete --
#
#	Remove a node from a tree, including all of its values.  Recursively
#	removes the node's children.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to delete.
#
# Results:
#	None.

proc ::struct::tree::_delete {name node} {
    if { [string equal $node "root"] } {
	# Can't delete the special root node
	error "cannot delete root node"
    }
    
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::parent parent

    # Remove this node from its parent's children list
    set parentNode $parent($node)
    set index [lsearch -exact $children($parentNode) $node]
    set children($parentNode) [lreplace $children($parentNode) $index $index]

    # Yes, we could use the stack structure implemented in ::struct::stack,
    # but it's slower than inlining it.  Since we don't need a sophisticated
    # stack, don't bother.
    set st [list ]
    foreach child $children($node) {
	lappend st $child
    }

    unset children($node)
    unset parent($node)
    # FRINK: nocheck
    unset ::struct::tree::tree${name}::node$node

    while { [llength $st] > 0 } {
	set node [lindex $st end]
	set st [lreplace $st end end]
	foreach child $children($node) {
	    lappend st $child
	}
	unset children($node)
	unset parent($node)
	# FRINK: nocheck
	unset ::struct::tree::tree${name}::node$node
    }
    return
}

# ::struct::tree::_depth --
#
#	Return the depth (distance from the root node) of a given node.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to find.
#
# Results:
#	depth	Number of steps from node to the root node.

proc ::struct::tree::_depth {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    upvar ::struct::tree::tree${name}::parent parent
    set depth 0
    while { ![string equal $node "root"] } {
	incr depth
	set node $parent($node)
    }
    return $depth
}

# ::struct::tree::_destroy --
#
#	Destroy a tree, including its associated command and data storage.
#
# Arguments:
#	name	Name of the tree to destroy.
#
# Results:
#	None.

proc ::struct::tree::_destroy {name} {
    namespace delete ::struct::tree::tree$name
    interp alias {} ::$name {}
}

# ::struct::tree::_exists --
#
#	Test for existance of a given node in a tree.
#
# Arguments:
#	name	Name of the tree to query.
#	node	Node to look for.
#
# Results:
#	1 if the node exists, 0 else.

proc ::struct::tree::_exists {name node} {
    return [info exists ::struct::tree::tree${name}::parent($node)]
}

# ::struct::tree::__generateUniqueNodeName --
#
#	Generate a unique node name for the given tree.
#
# Arguments:
#	name	Name of the tree to generate a unique node name for.
#
# Results:
#	node	Name of a node guaranteed to not exist in the tree.

proc ::struct::tree::__generateUniqueNodeName {name} {
    upvar ::struct::tree::tree${name}::nextUnusedNode nextUnusedNode
    while {[_exists $name "node${nextUnusedNode}"]} {
	incr nextUnusedNode
    }
    return "node${nextUnusedNode}"
}

# ::struct::tree::_get --
#
#	Get a keyed value from a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to query.
#	flag	Optional flag specifier; if present, must be "-key".
#	key	Optional key to lookup; defaults to data.
#
# Results:
#	value	Value associated with the key given.

proc ::struct::tree::_get {name node {flag -key} {key data}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::node${node} data
    if { ![info exists data($key)] } {
	error "invalid key \"$key\" for node \"$node\""
    }
    return $data($key)
}

# ::struct::tree::_getall --
#
#	Get a serialized list of key/value pairs from a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to query.
#
# Results:
#	value	A serialized list of key/value pairs.

proc ::struct::tree::_getall {name node args} { 
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    if { [llength $args] } {
	error "wrong # args: should be \"$name getall $node\""
    }
    
    upvar ::struct::tree::tree${name}::node${node} data
    return [array get data]
}

# ::struct::tree::_keys --
#
#	Get a list of keys from a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to query.
#
# Results:
#	value	A serialized list of key/value pairs.

proc ::struct::tree::_keys {name node args} { 
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    if { [llength $args] } {
	error "wrong # args: should be \"$name keys $node\""
    }

    upvar ::struct::tree::tree${name}::node${node} data
    return [array names data]
}

# ::struct::tree::_keyexists --
#
#	Test for existance of a given key for a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to query.
#	flag	Optional flag specifier; if present, must be "-key".
#	key	Optional key to lookup; defaults to data.
#
# Results:
#	1 if the key exists, 0 else.

proc ::struct::tree::_keyexists {name node {flag -key} {key data}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    if { ![string equal $flag "-key"] } {
	error "invalid option \"$flag\": should be -key"
    }
    
    upvar ::struct::tree::tree${name}::node${node} data
    return [info exists data($key)]
}

# ::struct::tree::_index --
#
#	Determine the index of node with in its parent's list of children.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to look up.
#
# Results:
#	index	The index of the node in its parent

proc ::struct::tree::_index {name node} {
    if { [string equal $node "root"] } {
	# The special root node has no parent, thus no index in it either.
	error "cannot determine index of root node"
    }
    
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::parent   parent

    # Locate the parent and ourself in its list of children
    set parentNode $parent($node)

    return [lsearch -exact $children($parentNode) $node]
}

# ::struct::tree::_insert --
#
#	Add a node to a tree; if the node(s) specified already exist, they
#	will be moved to the given location.
#
# Arguments:
#	name		Name of the tree.
#	parentNode	Parent to add the node to.
#	index		Index at which to insert.
#	args		Node(s) to insert.  If none is given, the routine
#			will insert a single node with a unique name.
#
# Results:
#	nodes		List of nodes inserted.

proc ::struct::tree::_insert {name parentNode index args} {
    if { [llength $args] == 0 } {
	# No node name was given; generate a unique one
	set args [list [__generateUniqueNodeName $name]]
    } else {
	# Validate the node names
	foreach child $args {
	    if {[regexp "\[\r\t\n :\]" $child]} {
		return -code error "invalid node name \"$child\""
	    }
	}
    }

    if { ![_exists $name $parentNode] } {
	error "parent node \"$parentNode\" does not exist in tree \"$name\""
    }

    upvar ::struct::tree::tree${name}::parent parent
    upvar ::struct::tree::tree${name}::children children
    
    # Make sure the index is numeric
    if { ![string is integer $index] } {
	# If the index is not numeric, make it numeric by lsearch'ing for
	# the value at index, then incrementing index (because "end" means
	# just past the end for inserts)
	set val [lindex $children($parentNode) $index]
	set index [expr {[lsearch -exact $children($parentNode) $val] + 1}]
    }

    foreach node $args {
	if { [_exists $name $node] } {
	    # Move the node to its new home
	    if { [string equal $node "root"] } {
		error "cannot move root node"
	    }
	    
	    # Cannot make a node its own descendant (I'm my own grandpaw...)
	    set ancestor $parentNode
	    while { ![string equal $ancestor "root"] } {
		if { [string equal $ancestor $node] } {
		    error "node \"$node\" cannot be its own descendant"
		}
		set ancestor $parent($ancestor)
	    }
	    # Remove this node from its parent's children list
	    set oldParent $parent($node)
	    set ind [lsearch -exact $children($oldParent) $node]
	    set children($oldParent) [lreplace $children($oldParent) $ind $ind]
	    
	    # If the node is moving within its parent, and its old location
	    # was before the new location, decrement the new location, so that
	    # it gets put in the right spot
	    if { [string equal $oldParent $parentNode] && $ind < $index } {
		incr index -1
	    }
	} else {
	    # Set up the new node
	    upvar ::struct::tree::tree${name}::node${node} data
	    set children($node) [list ]
	    set data(data) ""
	}

	# Add this node to its parent's children list
	set children($parentNode) [linsert $children($parentNode) $index $node]

	# Update the parent pointer for this node
	set parent($node) $parentNode
	incr index
    }

    return $args
}

# ::struct::tree::_isleaf --
#
#	Return whether the given node of a tree is a leaf or not.
#
# Arguments:
#	name	Name of the tree object.
#	node	Node to look up.
#
# Results:
#	isleaf	True if the node is a leaf; false otherwise.

proc ::struct::tree::_isleaf {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::children children
    return [expr {[llength $children($node)] == 0}]
}

# ::struct::tree::_move --
#
#	Move a node (and all its subnodes) from where ever it is to a new
#	location in the tree.
#
# Arguments:
#	name		Name of the tree
#	parentNode	Parent to add the node to.
#	index		Index at which to insert.
#	node		Node to move; the node must exist in the tree.
#	args		Additional nodes to move; these nodes must exist
#			in the tree.
#
# Results:
#	None.

proc ::struct::tree::_move {name parentNode index node args} {
    set args [linsert $args 0 $node]

    # Can only move a node to a real location in the tree
    if { ![_exists $name $parentNode] } {
	error "parent node \"$parentNode\" does not exist in tree \"$name\""
    }

    upvar ::struct::tree::tree${name}::parent parent
    upvar ::struct::tree::tree${name}::children children
    
    # Make sure the index is numeric
    if { ![string is integer $index] } {
	# If the index is not numeric, make it numeric by lsearch'ing for
	# the value at index, then incrementing index (because "end" means
	# just past the end for inserts)
	set val [lindex $children($parentNode) $index]
	set index [expr {[lsearch -exact $children($parentNode) $val] + 1}]
    }

    # Validate all nodes to move before trying to move any.
    foreach node $args {
	if { [string equal $node "root"] } {
	    error "cannot move root node"
	}

	# Can only move real nodes
	if { ![_exists $name $node] } {
	    error "node \"$node\" does not exist in tree \"$name\""
	}

	# Cannot move a node to be a descendant of itself
	set ancestor $parentNode
	while { ![string equal $ancestor "root"] } {
	    if { [string equal $ancestor $node] } {
		error "node \"$node\" cannot be its own descendant"
	    }
	    set ancestor $parent($ancestor)
	}
    }

    # Remove all nodes from their current parent's children list
    foreach node $args {
	set oldParent $parent($node)
	set ind [lsearch -exact $children($oldParent) $node]

	set children($oldParent) [lreplace $children($oldParent) $ind $ind]

	# Update the nodes parent value
	set parent($node) $parentNode
    }

    # Add all nodes to their new parent's children list
    set children($parentNode) [eval linsert [list $children($parentNode)] $index $args]

    return
}

# ::struct::tree::_next --
#
#	Return the right sibling for a given node of a tree.
#
# Arguments:
#	name		Name of the tree object.
#	node		Node to retrieve right sibling for.
#
# Results:
#	sibling		The right sibling for the node, or null if node was
#			the rightmost child of its parent.

proc ::struct::tree::_next {name node} {
    # The 'root' has no siblings.
    if { [string equal $node "root"] } {
	return {}
    }
    
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    # Locate the parent and our place in its list of children.
    upvar ::struct::tree::tree${name}::parent   parent
    upvar ::struct::tree::tree${name}::children children
    
    set parentNode $parent($node)
    set  index [lsearch -exact $children($parentNode) $node]
    
    # Go to the node to the right and return its name.
    return [lindex $children($parentNode) [incr index]]
}

# ::struct::tree::_numchildren --
#
#	Return the number of immediate children for a given node of a tree.
#
# Arguments:
#	name		Name of the tree object.
#	node		Node to look up.
#
# Results:
#	numchildren	Number of immediate children for the node.
 
proc ::struct::tree::_numchildren {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::children children
    return [llength $children($node)]
}

# ::struct::tree::_parent --
#
#	Return the name of the parent node of a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to look up.
#
# Results:
#	parent	Parent of node $node

proc ::struct::tree::_parent {name node} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    # FRINK: nocheck
    return [set ::struct::tree::tree${name}::parent($node)]
}

# ::struct::tree::_previous --
#
#	Return the left sibling for a given node of a tree.
#
# Arguments:
#	name		Name of the tree object.
#	node		Node to look up.
#
# Results:
#	sibling		The left sibling for the node, or null if node was 
#			the leftmost child of its parent.

proc ::struct::tree::_previous {name node} {
    # The 'root' has no siblings.
    if { [string equal $node "root"] } {
	return {}
    }
    
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    # Locate the parent and our place in its list of children.
    upvar ::struct::tree::tree${name}::parent   parent
    upvar ::struct::tree::tree${name}::children children
    
    set parentNode $parent($node)
    set  index [lsearch -exact $children($parentNode) $node]
    
    # Go to the node to the right and return its name.
    return [lindex $children($parentNode) [incr index -1]]
}

# ::struct::tree::_set --
#
#	Set or get a value for a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to modify or query.
#	args	Optional arguments specifying a key and a value.  Format is
#			?-key key? ?value?
#		If no key is specified, the key "data" is used.
#
# Results:
#	val	Value associated with the given key of the given node

proc ::struct::tree::_set {name node args} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    upvar ::struct::tree::tree${name}::node$node data

    if { [llength $args] > 3 } {
	error "wrong # args: should be \"$name set $node ?-key key?\
		?value?\""
    }
    
    set key "data"
    set haveValue 0
    if { [llength $args] > 1 } {
	foreach {flag key} $args break
	if { ![string match "${flag}*" "-key"] } {
	    error "invalid option \"$flag\": should be key"
	}
	if { [llength $args] == 3 } {
	    set haveValue 1
	    set value [lindex $args end]
	}
    } elseif { [llength $args] == 1 } {
	set haveValue 1
	set value [lindex $args end]
    }

    if { $haveValue } {
	# Setting a value
	return [set data($key) $value]
    } else {
	# Getting a value
	if { ![info exists data($key)] } {
	    error "invalid key \"$key\" for node \"$node\""
	}
	return $data($key)
    }
}

# ::struct::tree::_append --
#
#	Append a value for a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to modify or query.
#	args	Optional arguments specifying a key and a value.  Format is
#			?-key key? ?value?
#		If no key is specified, the key "data" is used.
#
# Results:
#	val	Value associated with the given key of the given node

proc ::struct::tree::_append {name node args} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    upvar ::struct::tree::tree${name}::node$node data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name set $node ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [append data($key) $value]
}

# ::struct::tree::_lappend --
#
#	lappend a value for a node in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to modify or query.
#	args	Optional arguments specifying a key and a value.  Format is
#			?-key key? ?value?
#		If no key is specified, the key "data" is used.
#
# Results:
#	val	Value associated with the given key of the given node

proc ::struct::tree::_lappend {name node args} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    upvar ::struct::tree::tree${name}::node$node data

    if { [llength $args] != 1 && [llength $args] != 3 } {
	error "wrong # args: should be \"$name lappend $node ?-key key?\
		value\""
    }
    
    if { [llength $args] == 3 } {
	foreach {flag key} $args break
	if { ![string equal $flag "-key"] } {
	    error "invalid option \"$flag\": should be -key"
	}
    } else {
	set key "data"
    }

    set value [lindex $args end]

    return [lappend data($key) $value]
}

# ::struct::tree::_size --
#
#	Return the number of descendants of a given node.  The default node
#	is the special root node.
#
# Arguments:
#	name	Name of the tree.
#	node	Optional node to start counting from (default is root).
#
# Results:
#	size	Number of descendants of the node.

proc ::struct::tree::_size {name {node root}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    # If the node is the root, we can do the cheap thing and just count the
    # number of nodes (excluding the root node) that we have in the tree with
    # array names
    if { [string equal $node "root"] } {
	set size [llength [array names ::struct::tree::tree${name}::parent]]
	return [expr {$size - 1}]
    }

    # Otherwise we have to do it the hard way and do a full tree search
    upvar ::struct::tree::tree${name}::children children
    set size 0
    set st [list ]
    foreach child $children($node) {
	lappend st $child
    }
    while { [llength $st] > 0 } {
	set node [lindex $st end]
	set st [lreplace $st end end]
	incr size
	foreach child $children($node) {
	    lappend st $child
	}
    }
    return $size
}

# ::struct::tree::_splice --
#
#	Add a node to a tree, making a range of children from the given 
#	parent children of the new node.
#
# Arguments:
#	name		Name of the tree.
#	parentNode	Parent to add the node to.
#	from		Index at which to insert.
#	to		Optional end of the range of children to replace.
#			Defaults to 'end'.
#	node		Optional node name; if given, must be unique.  If not
#			given, a unique name will be generated.
#
# Results:
#	node		Name of the node added to the tree.

proc ::struct::tree::_splice {name parentNode from {to end} args} {
    if { [llength $args] == 0 } {
	# No node name given; generate a unique node name
	set node [__generateUniqueNodeName $name]
    } else {
	set node [lindex $args 0]
    }

    if { [_exists $name $node] } {
	error "node \"$node\" already exists in tree \"$name\""
    }
    
    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::parent   parent

    # Save the list of children that are moving
    set moveChildren [lrange $children($parentNode) $from $to]
    
    # Remove those children from the parent
    set children($parentNode) [lreplace $children($parentNode) $from $to]

    # Add the new node
    _insert $name $parentNode $from $node
    
    # Move the children
    set children($node) $moveChildren
    foreach child $moveChildren {
	set parent($child) $node
    }
    
    return $node
}

# ::struct::tree::_swap --
#
#	Swap two nodes in a tree.
#
# Arguments:
#	name	Name of the tree.
#	node1	First node to swap.
#	node2	Second node to swap.
#
# Results:
#	None.

proc ::struct::tree::_swap {name node1 node2} {
    # Can't swap the magic root node
    if { [string equal $node1 "root"] || [string equal $node2 "root"] } {
	error "cannot swap root node"
    }
    
    # Can only swap two real nodes
    if { ![_exists $name $node1] } {
	error "node \"$node1\" does not exist in tree \"$name\""
    }
    if { ![_exists $name $node2] } {
	error "node \"$node2\" does not exist in tree \"$name\""
    }

    # Can't swap a node with itself
    if { [string equal $node1 $node2] } {
	error "cannot swap node \"$node1\" with itself"
    }

    # Swapping nodes means swapping their labels and values
    upvar ::struct::tree::tree${name}::children children
    upvar ::struct::tree::tree${name}::parent parent
    upvar ::struct::tree::tree${name}::node${node1} node1Vals
    upvar ::struct::tree::tree${name}::node${node2} node2Vals

    set parent1 $parent($node1)
    set parent2 $parent($node2)

    # Replace node1 with node2 in node1's parent's children list, and
    # node2 with node1 in node2's parent's children list
    set i1 [lsearch -exact $children($parent1) $node1]
    set i2 [lsearch -exact $children($parent2) $node2]

    set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2]
    set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1]
    
    # Make node1 the parent of node2's children, and vis versa
    foreach child $children($node2) {
	set parent($child) $node1
    }
    foreach child $children($node1) {
	set parent($child) $node2
    }
    
    # Swap the children lists
    set children1 $children($node1)
    set children($node1) $children($node2)
    set children($node2) $children1

    if { [string equal $node1 $parent2] } {
	set parent($node1) $node2
	set parent($node2) $parent1
    } elseif { [string equal $node2 $parent1] } {
	set parent($node1) $parent2
	set parent($node2) $node1
    } else {
	set parent($node1) $parent2
	set parent($node2) $parent1
    }

    # Swap the values
    set value1 [array get node1Vals]
    unset node1Vals
    array set node1Vals [array get node2Vals]
    unset node2Vals
    array set node2Vals $value1

    return
}

# ::struct::tree::_unset --
#
#	Remove a keyed value from a node.
#
# Arguments:
#	name	Name of the tree.
#	node	Node to modify.
#	args	Optional additional args specifying which key to unset;
#		if given, must be of the form "-key key".  If not given,
#		the key "data" is unset.
#
# Results:
#	None.

proc ::struct::tree::_unset {name node {flag -key} {key data}} {
    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }
    
    if { ![string match "${flag}*" "-key"] } {
	error "invalid option \"$flag\": should be \"$name unset\
		$node ?-key key?\""
    }

    upvar ::struct::tree::tree${name}::node${node} data
    if { [info exists data($key)] } {
	unset data($key)
    }
    return
}

# ::struct::tree::_walk --
#
#	Walk a tree using a pre-order depth or breadth first
#	search. Pre-order DFS is the default.  At each node that is visited,
#	a command will be called with the name of the tree and the node.
#
# Arguments:
#	name	Name of the tree.
#	node	Node at which to start.
#	args	Optional additional arguments specifying the type and order of
#		the tree walk, and the command to execute at each node.
#		Format is
#		    ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd
#
# Results:
#	None.

proc ::struct::tree::_walk {name node args} {
    set usage "$name walk $node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd"

    if {[llength $args] > 6 || [llength $args] < 2} {
	error "wrong # args: should be \"$usage\""
    }

    if { ![_exists $name $node] } {
	error "node \"$node\" does not exist in tree \"$name\""
    }

    # Set defaults
    set type dfs
    set order pre
    set cmd ""

    for {set i 0} {$i < [llength $args]} {incr i} {
	set flag [lindex $args $i]
	incr i
	if { $i >= [llength $args] } {
	    error "value for \"$flag\" missing: should be \"$usage\""
	}
	switch -glob -- $flag {
	    "-type" {
		set type [string tolower [lindex $args $i]]
	    }
	    "-order" {
		set order [string tolower [lindex $args $i]]
	    }
	    "-command" {
		set cmd [lindex $args $i]
	    }
	    default {
		error "unknown option \"$flag\": should be \"$usage\""
	    }
	}
    }
    
    # Make sure we have a command to run, otherwise what's the point?
    if { [string equal $cmd ""] } {
	error "no command specified: should be \"$usage\""
    }

    # Validate that the given type is good
    switch -glob -- $type {
	"dfs" {
	    set type "dfs"
	}
	"bfs" {
	    set type "bfs"
	}
	default {
	    error "invalid search type \"$type\": should be dfs, or bfs"
	}
    }
    
    # Validate that the given order is good
    switch -glob -- $order {
	"pre" {
	    set order pre
	}
	"post" {
	    set order post
	}
	"in" {
	    set order in
	}
	"both" {
	    set order both
	}
	default {
	    error "invalid search order \"$order\":\
		    should be pre, post, both, or in"
	}
    }

    if {[string equal $order "in"] && [string equal $type "bfs"]} {
	error "unable to do a ${order}-order breadth first walk"
    }

    # Do the walk
    upvar ::struct::tree::tree${name}::children children
    set st [list ]
    lappend st $node

    # Compute some flags for the possible places of command evaluation
    set leave [expr {[string equal $order post] \
	    || [string equal $order both]}]
    set enter [expr {[string equal $order pre] \
	    || [string equal $order both]}]
    set touch [string equal $order in]

    if {$leave} {
	set lvlabel leave
    } elseif {$touch} {
	# in-order does not provide a sense
	# of nesting for the parent, hence
	# no enter/leave, just 'visit'.
	set lvlabel visit
    }

    if { [string equal $type "dfs"] } {
	# Depth-first walk, several orders of visiting nodes
	# (pre, post, both, in)

	array set visited {}

	while { [llength $st] > 0 } {
	    set node [lindex $st end]

	    if {[info exists visited($node)]} {
		# Second time we are looking at this 'node'.
		# Pop it, then evaluate the command (post, both, in).

		set st [lreplace $st end end]

		if {$leave || $touch} {
		    # Evaluate the command at this node
		    WalkCall $name $node $lvlabel $cmd
		}
	    } else {
		# First visit of this 'node'.
		# Do *not* pop it from the stack so that we are able
		# to visit again after its children

		# Remember it.
		set visited($node) .

		if {$enter} {
		    # Evaluate the command at this node (pre, both)
		    WalkCall $name $node "enter" $cmd
		}

		# Add the children of this node to the stack.
		# The exact behaviour depends on the chosen
		# order. For pre, post, both-order we just
		# have to add them in reverse-order so that
		# they will be popped left-to-right. For in-order
		# we have rearrange the stack so that the parent
		# is revisited immediately after the first child.
		# (but only if there is ore than one child,)

		set clist        $children($node)
		set len [llength $clist]

		if {$touch && ($len > 1)} {
		    # Pop node from stack, insert into list of children
		    set st    [lreplace $st end end]
		    set clist [linsert $clist 1 $node]
		    incr len
		}

		for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} {
		    lappend st [lindex $clist $i]
		}
	    }
	}
    } else {
	# Breadth first walk (pre, post, both)
	# No in-order possible. Already captured.

	if {$leave} {
	    set backward $st
	}

	while { [llength $st] > 0 } {
	    set node [lindex   $st 0]
	    set st   [lreplace $st 0 0]

	    if {$enter} {
		# Evaluate the command at this node
		WalkCall $name $node "enter" $cmd
	    }

	    # Add this node's children
	    # And create a mirrored version in case of post/both order.

	    foreach child $children($node) {
		lappend st $child
		if {$leave} {
		    set backward [linsert $backward 0 $child]
		}
	    }
	}

	if {$leave} {
	    foreach node $backward {
		# Evaluate the command at this node
		WalkCall $name $node "leave" $cmd
	    }
	}
    }
    return
}

# ::struct::tree::WalkCall --
#
#	Helper command to 'walk' handling the evaluation
#	of the user-specified command. Information about
#	the tree, node and current action are substituted
#	into the command before it evaluation.
#
# Arguments:
#	tree	Tree we are walking
#	node	Node we are at.
#	action	The current action.
#	cmd	The command to call, already partially substituted.
#
# Results:
#	None.

proc ::struct::tree::WalkCall {tree node action cmd} {
    uplevel 3 [string map [list \
	    %n [list $node]	\
	    %a [list $action]	\
	    %t [list $tree]	\
	    %% %] 		\
	    $cmd]
    return
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/struct/tree.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
# tree.test:  tests for the tree 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) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: tree.test,v 1.17 2002/08/08 16:49:59 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join [file dirname [info script]] tree.tcl]
namespace import struct::tree::tree

test tree-0.1 {tree errors} {
    tree mytree
    catch {tree mytree} msg
    mytree destroy
    set msg
} "command \"mytree\" already exists, unable to create tree"
test tree-0.2 {tree errors} {
    tree mytree
    catch {mytree} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree option ?arg arg ...?\""
test tree-0.3 {tree errors} {
    tree mytree
    catch {mytree foo} msg
    mytree destroy
    set msg
} "bad option \"foo\": must be append, children, cut, destroy, delete, depth, exists, get, getall, index, insert, isleaf, keys, keyexists, lappend, move, next, numchildren, parent, previous, set, size, splice, swap, unset, or walk"
test tree-0.4 {tree errors} {
    catch {tree set} msg
    set msg
} "command \"set\" already exists, unable to create tree"

test tree-1.1 {children} {
    tree mytree
    set result [list ]
    lappend result [mytree children root]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert node0 end node3
    mytree insert node0 end node4
    lappend result [mytree children root]
    lappend result [mytree children node0]
    mytree destroy
    set result
} [list {} {node0 node1 node2} {node3 node4}]
test tree-1.2 {children, bad node} {
    tree mytree
    set result [catch {mytree children foobar} msg]
    mytree destroy
    list $result $msg
} [list 1 "node \"foobar\" does not exist in tree \"mytree\""]

test tree-2.1 {create} {
    tree mytree
    set result [string equal [info commands ::mytree] "::mytree"]
    mytree destroy
    set result
} 1
test tree-2.2 {create} {
    set name [tree]
    set result [list $name [string equal [info commands ::$name] "::$name"]]
    $name destroy
    set result
} [list tree1 1]

test tree-3.1 {destroy} {
    tree mytree
    mytree destroy
    string equal [info commands ::mytree] ""
} 1

test tree-4.1 {delete} {
    tree mytree
    catch {mytree delete root} msg
    mytree destroy
    set msg
} "cannot delete root node"
test tree-4.2 {delete} {
    tree mytree
    catch {mytree delete node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-4.3 {delete} {
    tree mytree
    mytree insert root end node0
    mytree delete node0
    set result [list [mytree exists node0] [mytree children root]]
    mytree destroy
    set result
} {0 {}}
test tree-4.4 {delete} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree delete node0
    set result [list [mytree exists node0] \
	    [mytree exists node1] \
	    [mytree exists node2]]
    mytree destroy
    set result
} {0 0 0}

test tree-5.1 {exists} {
    tree mytree
    set result [list ]
    lappend result [mytree exists root]
    mytree insert root end node0
    lappend result [mytree exists node0]
    mytree delete node0
    lappend result [mytree exists node0]
    mytree destroy
    set result
} {1 1 0}

test tree-6.1 {insert creates and initializes node} {
    tree mytree
    mytree insert root end node0
    set result [list ]
    lappend result [mytree exists node0]
    lappend result [mytree parent node0]
    lappend result [mytree children node0]
    lappend result [mytree set node0]
    lappend result [mytree children root]
    mytree destroy
    set result
} {1 root {} {} node0}
test tree-6.2 {insert insert nodes in correct location} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root 0 node2
    set result [mytree children root]
    mytree destroy
    set result
} {node2 node0 node1}
test tree-6.3 {insert gives error when trying to insert to a fake parent} {
    tree mytree
    catch {mytree insert node0 end node1} msg
    mytree destroy
    set msg
} "parent node \"node0\" does not exist in tree \"mytree\""
test tree-6.4 {insert generates node name when none is given} {
    tree mytree
    set result [list [mytree insert root end]]
    lappend result [mytree insert root end]
    mytree insert root end node3
    lappend result [mytree insert root end]
    mytree destroy
    set result
} [list node1 node2 node4]
test tree-6.5 {insert inserts multiple nodes properly} {
    tree mytree
    mytree insert root end a b c d e f
    set result [mytree children root]
    mytree destroy
    set result
} [list a b c d e f]
test tree-6.6 {insert moves nodes that exist} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree insert node0 end node4 node5 node6
    mytree insert root end node4
    set result [list [mytree children root] [mytree children node0]]
    mytree destroy
    set result
} [list [list node0 node1 node2 node3 node4] [list node5 node6]]
test tree-6.7 {insert moves nodes that already exist properly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree insert root end node1 node2
    set result [list			\
	    [mytree children root]	\
	    [mytree children node0]	\
	    [mytree children node1]	\
	    [mytree parent node1]	\
	    [mytree parent node2]	\
	    ]
    mytree destroy
    set result
} [list [list node0 node1 node2] {} {} root root]
test tree-6.8 {insert moves multiple nodes properly} {
    tree mytree
    mytree insert root end node0 node1 node2
    mytree insert root 0 node1 node2
    set result [list			\
	    [mytree children root]	\
	    ]
    mytree destroy
    set result
} [list [list node1 node2 node0]]
test tree-6.9 {insert moves multiple nodes properly} {
    tree mytree
    mytree insert root end node0 node1 node2
    mytree insert root 1 node0 node1
    set result [mytree children root]
    mytree destroy
    set result
} [list node0 node1 node2]
test tree-6.10 {insert moves node within parent properly} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree insert root 2 node1
    set result [mytree children root]
    mytree destroy
    set result
} [list node0 node1 node2 node3]
test tree-6.11 {insert moves node within parent properly} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree insert node3 end node4 node5 node6
    mytree insert root 2 node0 node4 node5 node6
    set result [mytree children root]
    mytree destroy
    set result
} [list node1 node0 node4 node5 node6 node2 node3]
test tree-6.12 {insert moves node in parent properly when oldInd < newInd} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree insert root 2 node0
    set result [mytree children root]
    mytree destroy
    set result
} [list node1 node0 node2 node3]
test tree-6.13 {insert gives error when trying to move root} {
    tree mytree
    catch {mytree insert root end root} msg
    mytree destroy
    set msg
} "cannot move root node"
test tree-6.14 {insert gives error when trying to make node its descendant} {
    tree mytree
    mytree insert root end node0
    catch {mytree insert node0 end node0} msg
    mytree destroy
    set msg
} "node \"node0\" cannot be its own descendant"
test tree-6.15 {insert gives error when trying to make node its descendant} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    catch {mytree insert node2 end node0} msg
    mytree destroy
    set msg
} "node \"node0\" cannot be its own descendant"
test tree-6.16 {insert gives error for invalid node names} {
    tree mytree
    catch {mytree insert root end ":\n\t "} msg
    mytree destroy
    set msg
} "invalid node name \":\n\t \""

test tree-7.1 {move gives error when trying to move root} {
    tree mytree
    mytree insert root end node0
    catch {mytree move node0 end root} msg
    mytree destroy
    set msg
} "cannot move root node"
test tree-7.2 {move gives error when trying to move non existant node} {
    tree mytree
    catch {mytree move root end node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-7.3 {move gives error when trying to move to non existant parent} {
    tree mytree
    catch {mytree move node0 end node0} msg
    mytree destroy
    set msg
} "parent node \"node0\" does not exist in tree \"mytree\""
test tree-7.4 {move gives error when trying to make node its own descendant} {
    tree mytree
    mytree insert root end node0
    catch {mytree move node0 end node0} msg
    mytree destroy
    set msg
} "node \"node0\" cannot be its own descendant"
test tree-7.5 {move gives error when trying to make node its own descendant} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    catch {mytree move node2 end node0} msg
    mytree destroy
    set msg
} "node \"node0\" cannot be its own descendant"
test tree-7.6 {move correctly moves a node} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree move node0 end node2
    set result [list [mytree children node0] [mytree children node1]]
    lappend result [mytree parent node2]
    mytree destroy
    set result
} {{node1 node2} {} node0}
test tree-7.7 {move moves multiple nodes properly} {
    tree mytree
    mytree insert root end node0 node1 node2
    mytree move root 0 node1 node2
    set result [list			\
	    [mytree children root]	\
	    ]
    mytree destroy
    set result
} [list [list node1 node2 node0]]
test tree-7.8 {move moves multiple nodes properly} {
    tree mytree
    mytree insert root end node0 node1 node2
    mytree move root 1 node0 node1
    set result [mytree children root]
    mytree destroy
    set result
} [list node2 node0 node1]
test tree-7.9 {move moves node within parent properly} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree move root 2 node1
    set result [mytree children root]
    mytree destroy
    set result
} [list node0 node2 node1 node3]
test tree-7.10 {move moves node within parent properly} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree insert node3 end node4 node5 node6
    mytree move root 2 node0 node4 node5 node6
    set result [mytree children root]
    mytree destroy
    set result
} [list node1 node2 node0 node4 node5 node6 node3]
test tree-7.11 {move moves node in parent properly when oldInd < newInd} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree move root 2 node0
    set result [mytree children root]
    mytree destroy
    set result
} [list node1 node2 node0 node3]
test tree-7.12 {move node up one} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree move root [mytree index [mytree next node0]] node0
    set result [mytree children root]
    mytree destroy
    set result
} [list node1 node0 node2 node3]
test tree-7.13 {move node down one} {
    tree mytree
    mytree insert root end node0 node1 node2 node3
    mytree move root [mytree index [mytree previous node2]] node2
    set result [mytree children root]
    mytree destroy
    set result
} [list node0 node2 node1 node3]

test tree-8.1 {parent gives error on fake node} {
    tree mytree
    catch {mytree parent node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-8.2 {parent gives correct value} {
    tree mytree
    mytree insert root end node0
    set result [list [mytree parent node0] [mytree parent root]]
    mytree destroy
    set result
} {root {}}

test tree-9.1 {size gives error on bogus node} {
    tree mytree
    catch {mytree size node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-9.2 {size uses root node as default} {
    tree mytree
    set result [mytree size]
    mytree destroy
    set result
} 0
test tree-9.3 {size gives correct value} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert root end node3
    mytree insert root end node4
    mytree insert root end node5
    set result [mytree size]
    mytree destroy
    set result
} 6
test tree-9.4 {size gives correct value} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node0 end node2
    mytree insert node0 end node3
    mytree insert node1 end node4
    mytree insert node1 end node5
    set result [mytree size node0]
    mytree destroy
    set result
} 5
test tree-9.5 {size gives correct value} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node0 end node2
    mytree insert node0 end node3
    mytree insert node1 end node4
    mytree insert node1 end node5
    set result [mytree size node1]
    mytree destroy
    set result
} 2

test tree-10.1 {set gives error on bogus node} {
    tree mytree
    catch {mytree set node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-10.2 {set with node name gets/sets "data" value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    set result [mytree set node0]
    mytree destroy
    set result
} "foobar"
test tree-10.3 {set with node name and key gets/sets key value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key baz foobar
    set result [list [mytree set node0] [mytree set node0 -key baz]]
    mytree destroy
    set result
} [list "" "foobar"]
test tree-10.4 {set with too many args gives error} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 foo bar baz boo} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree set node0 ?-key key? ?value?\""
test tree-10.5 {set with bad args} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 foo bar} msg
    mytree destroy
    set msg
} "invalid option \"foo\": should be key"
test tree-10.6 {set with bad args} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 foo bar baz} msg
    mytree destroy
    set msg
} "invalid option \"foo\": should be key"
test tree-10.7 {set with bad key gives error} {
    tree mytree
    mytree insert root end node0
    catch {mytree set node0 -key foo} msg
    mytree destroy
    set msg
} "invalid key \"foo\" for node \"node0\""

test tree-11.1 {depth} {
    tree mytree
    catch {mytree depth node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-11.2 {depth of root is 0} {
    tree mytree
    set result [mytree depth root]
    mytree destroy
    set result
} 0
test tree-11.2 {depth is computed correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node1
    mytree insert node1 end node2
    mytree insert node2 end node3
    set result [mytree depth node3]
    mytree destroy
    set result
} 4

test tree-12.1 {pre dfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type dfs -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root    enter mytree node0 enter mytree node0.1 \
	enter mytree node0.2 enter mytree node1 \
	enter mytree node1.1 enter mytree node1.2]

test tree-12.1.0 {post dfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -order post -type dfs -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list leave mytree node0.1 leave mytree node0.2 leave mytree node0 \
	leave mytree node1.1 leave mytree node1.2 \
	leave mytree node1   leave mytree root]

test tree-12.1.1 {both dfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -order both -type dfs -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root enter mytree node0 enter mytree node0.1 \
	leave mytree node0.1 enter mytree node0.2 leave mytree node0.2 \
	leave mytree node0 enter mytree node1 enter mytree node1.1 \
	leave mytree node1.1 enter mytree node1.2 leave mytree node1.2 \
	leave mytree node1   leave mytree root]

test tree-12.1.3 {in dfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -order in -type dfs -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list visit mytree node0.1 visit mytree node0   visit mytree node0.2 \
	visit mytree root    visit mytree node1.1 visit mytree node1 \
	visit mytree node1.2]

test tree-12.1.4 {pre dfs walk, different % specifiers} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type dfs -command {lappend t %n %%}
    mytree destroy
    set t
} [list root % node0 % node0.1 % \
	node0.2 % node1 % \
	node1.1 % node1.2 %]

test tree-12.1.5 {pre dfs walk, different % specifiers} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type dfs -command {lappend t %% %t}
    mytree destroy
    set t
} [list % mytree % mytree % mytree \
	% mytree % mytree \
	% mytree % mytree]

test tree-12.1.6 {pre dfs walk, nodes with spaces in names} {
    tree mytree
    set t [list ]
    mytree insert root end "node/0"
    mytree insert root end "node/1"
    mytree insert "node/0" end "node/0/1"
    mytree insert "node/0" end "node/0/2"
    mytree insert "node/1" end "node/1/1"
    mytree insert "node/1" end "node/1/2"
    mytree walk root -type dfs -command {lappend t %n}
    mytree destroy
    set t
} [list root "node/0" "node/0/1" "node/0/2" "node/1" "node/1/1" "node/1/2"]

test tree-12.2 {pre bfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type bfs -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root    enter mytree node0   enter mytree node1   \
	enter mytree node0.1 enter mytree node0.2 enter mytree node1.1 \
	enter mytree node1.2]

test tree-12.2.0 {post bfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type bfs -order post -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list leave mytree node1.2 leave mytree node1.1 leave mytree node0.2 \
	leave mytree node0.1 leave mytree node1   leave mytree node0 \
	leave mytree root]

test tree-12.2.1 {both bfs walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -type bfs -order both -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root    enter mytree node0   enter mytree node1   \
	enter mytree node0.1 enter mytree node0.2 enter mytree node1.1 \
	enter mytree node1.2 leave mytree node1.2 leave mytree node1.1 \
	leave mytree node0.2 leave mytree node0.1 leave mytree node1   \
	leave mytree node0   leave mytree root]

test tree-12.3 {pre dfs is default walk} {
    tree mytree
    set t [list ]
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root enter mytree node0 enter mytree node0.1 \
	enter mytree node0.2 enter mytree node1 \
	enter mytree node1.1 enter mytree node1.2]
test tree-12.4 {walk with too few args} {badTest} {
    tree mytree
    catch {mytree walk} msg
    mytree destroy
    set msg
} "no value given for parameter \"node\" to \"::struct::tree::_walk\""
test tree-12.5 {walk with too few args} {
    tree mytree
    catch {mytree walk root} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\""
test tree-12.6 {walk with too many args} {
    tree mytree
    catch {mytree walk root -foo bar -baz boo -foo2 boo -foo3 baz} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\""
test tree-12.7 {walk with fake node} {
    tree mytree
    catch {mytree walk node0 -command {}} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-12.8 {walk gives error on invalid search type} {
    tree mytree
    catch {mytree walk root -type foo -command foo} msg
    mytree destroy
    set msg
} {invalid search type "foo": should be dfs, or bfs}
test tree-12.9 {walk gives error on invalid search order} {
    tree mytree
    catch {mytree walk root -order foo -command foo} msg
    mytree destroy
    set msg
} {invalid search order "foo": should be pre, post, both, or in}
test tree-12.10 {walk gives error on invalid combination of order and type} {
    tree mytree
    catch {mytree walk root -order in -type bfs -command foo} msg
    mytree destroy
    set msg
} {unable to do a in-order breadth first walk}
test tree-12.11 {walk with unknown options} {
    tree mytree
    catch {mytree walk root -foo bar} msg
    mytree destroy
    set msg
} "unknown option \"-foo\": should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\""
test tree-12.12 {walk, option without value} {
    tree mytree
    catch {mytree walk root -type dfs -order} msg
    mytree destroy
    set msg
} "value for \"-order\" missing: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\""
test tree-12.13 {walk without command} {
    tree mytree
    catch {mytree walk root -order pre} msg
    mytree destroy
    set msg
} "no command specified: should be \"mytree walk root ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd\""


test tree-13.1 {swap gives error when trying to swap root} {
    tree mytree
    catch {mytree swap root node0} msg
    mytree destroy
    set msg
} "cannot swap root node"
test tree-13.2 {swap gives error when trying to swap non existant node} {
    tree mytree
    catch {mytree swap node0 node1} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-13.3 {swap gives error when trying to swap non existant node} {
    tree mytree
    mytree insert root end node0
    catch {mytree swap node0 node1} msg
    mytree destroy
    set msg
} "node \"node1\" does not exist in tree \"mytree\""
test tree-13.3 {swap gives error when trying to swap node with self} {
    tree mytree
    mytree insert root end node0
    catch {mytree swap node0 node0} msg
    mytree destroy
    set msg
} "cannot swap node \"node0\" with itself"
test tree-13.4 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node0.1 end node0.1.1
    mytree insert node0.1 end node0.1.2
    mytree swap node0 node0.1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root      enter mytree node0.1   enter mytree node0 \
	enter mytree node0.1.1 enter mytree node0.1.2 enter mytree node0.2]
test tree-13.5 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node0.1 end node0.1.1
    mytree insert node0.1 end node0.1.2
    mytree swap node0 node0.1.1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root enter mytree node0.1.1 enter mytree node0.1 \
	enter mytree node0 enter mytree node0.1.2 enter mytree node0.2]
test tree-13.6 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert node0 end node0.1
    mytree insert node1 end node1.1
    mytree swap node0 node1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root enter mytree node1 enter mytree node0.1 \
	enter mytree node0 enter mytree node1.1]
test tree-13.7 {swap swaps node relationships correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert node0 end node0.1
    mytree insert node0 end node0.2
    mytree insert node0.1 end node0.1.1
    mytree insert node0.1 end node0.1.2
    mytree swap node0.1 node0
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} [list enter mytree root      enter mytree node0.1   enter mytree node0 \
	enter mytree node0.1.1 enter mytree node0.1.2 enter mytree node0.2]

test tree-14.1 {get gives error on bogus node} {
    tree mytree
    catch {mytree get node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-14.2 {get gives error on bogus key} {
    tree mytree
    mytree insert root end node0
    catch {mytree get node0 -key bogus} msg
    mytree destroy
    set msg
} "invalid key \"bogus\" for node \"node0\""
test tree-14.2 {get uses data as default key} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    set result [mytree get node0]
    mytree destroy
    set result
} "foobar"
test tree-14.3 {get respects -key flag} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key boom foobar
    set result [mytree get node0 -key boom]
    mytree destroy
    set result
} "foobar"

test tree-15.1 {unset gives error on bogus node} {
    tree mytree
    catch {mytree unset node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-15.2 {unset does not give error on bogus key} {
    tree mytree
    mytree insert root end node0
    set result [catch {mytree unset node0 -key bogus}]
    mytree destroy
    set result
} 0
test tree-15.3 {unset removes a keyed value from a node} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key foobar foobar
    mytree unset node0 -key foobar
    catch {mytree get node0 -key foobar} msg
    mytree destroy
    set msg
} "invalid key \"foobar\" for node \"node0\""
test tree-15.4 {unset requires -key} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key foobar foobar
    catch {mytree unset node0 flaboozle foobar} msg
    mytree destroy
    set msg
} "invalid option \"flaboozle\": should be \"mytree unset node0 ?-key key?\""

test tree-16.1 {isleaf} {
    tree mytree
    set t [mytree isleaf root]
    mytree insert root end node0
    lappend t [mytree isleaf root] [mytree isleaf node0]
    mytree destroy
    set t
} [list 1 0 1]
test tree-16.2 {isleaf} {
    tree mytree
    catch {mytree isleaf node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""

test tree-17.1 {index of root fails} {
    tree mytree
    catch {mytree index root} msg
    mytree destroy
    set msg
} "cannot determine index of root node"
test tree-17.2 {index} {
    tree mytree
    mytree insert root end node1
    mytree insert root end node0
    set result [list [mytree index node0] [mytree index node1]]
    mytree destroy
    set result
} [list 1 0]
test tree-17.3 {index of non-existant node} {
    tree mytree
    catch {mytree index node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""

test tree-18.1 {numchildren} {
    tree mytree
    set t [mytree numchildren root]
    mytree insert root end node0
    lappend t [mytree numchildren root] [mytree numchildren node0]
    mytree destroy
    set t
} [list 0 1 0]
test tree-18.2 {numchildren} {
    tree mytree
    catch {mytree numchildren node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""

test tree-19.1 {next from root} {
    tree mytree
    set res [mytree next root]
    mytree destroy
    set res
} {}
test tree-19.2 {next from fake node} {
    tree mytree
    catch {mytree next node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-19.3 {next} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    set res [list [mytree next node0] [mytree next node1]]
    mytree destroy
    set res
} [list node1 {}]

test tree-20.1 {previous from root} {
    tree mytree
    set res [mytree previous root]
    mytree destroy
    set res
} {}
test tree-20.2 {previous from fake node} {
    tree mytree
    catch {mytree previous node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-20.3 {next} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    set res [list [mytree previous node0] [mytree previous node1]]
    mytree destroy
    set res
} [list {} node0]

test tree-21.1 {cutting nodes} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert node1 end node1.0
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree cut node1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} {enter mytree root enter mytree node0 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2}
test tree-21.2 {cutting nodes} {
    tree mytree
    catch {mytree cut root} msg
    mytree destroy
    set msg
} {cannot cut root node}
test tree-21.3 {cut sets parent values of relocated nodes} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert node1 end node1.0
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree cut node1
    set res [list \
	    [mytree parent node1.0] \
	    [mytree parent node1.1] \
	    [mytree parent node1.2]]
    mytree destroy
    set res
} [list root root root]
test tree-21.4 {cut removes node} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1
    mytree insert root end node2
    mytree insert node1 end node1.0
    mytree insert node1 end node1.1
    mytree insert node1 end node1.2
    mytree cut node1
    set res [mytree exists node1]
    mytree destroy
    set res
} 0
test tree-21.5 {cut removes node} {
    tree mytree
    catch {mytree cut node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""

test tree-22.1 {splicing nodes} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1.0
    mytree insert root end node1.1
    mytree insert root end node1.2
    mytree insert root end node2
    mytree splice root 1 3 node1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} {enter mytree root enter mytree node0 enter mytree node1 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2}
test tree-22.2 {splicing nodes with no node name given} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1.0
    mytree insert root end node1.1
    mytree insert root end node1.2
    mytree insert root end node2
    set res [mytree splice root 1 3]
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    list $res $t
} [list node1 {enter mytree root enter mytree node0 enter mytree node1 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2}]
test tree-22.3 {splicing nodes errors on duplicate node name} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1.0
    mytree insert root end node1.1
    mytree insert root end node1.2
    mytree insert root end node2
    catch {mytree splice root 1 3 node0} msg
    mytree destroy
    set msg
} "node \"node0\" already exists in tree \"mytree\""
test tree-22.4 {splicing node sets parent values correctly} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1.0
    mytree insert root end node1.1
    mytree insert root end node1.2
    mytree insert root end node2
    mytree splice root 1 3 node1
    set res [list \
	    [mytree parent node1] \
	    [mytree parent node1.0] \
	    [mytree parent node1.1] \
	    [mytree parent node1.2]]
    mytree destroy
    set res
} [list root node1 node1 node1]
test tree-22.5 {splicing node works with strange index} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1.0
    mytree insert root end node1.1
    mytree insert root end node1.2
    mytree insert root end node2
    mytree splice root -5 12 node1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} {enter mytree root enter mytree node1 enter mytree node0 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2}
test tree-22.6 {splicing nodes with no node name and no "to" index given} {
    tree mytree
    mytree insert root end node0
    mytree insert root end node1.0
    mytree insert root end node1.1
    mytree insert root end node1.2
    mytree insert root end node2
    mytree splice root 1
    set t [list ]
    mytree walk root -command {lappend t %a %t %n}
    mytree destroy
    set t
} {enter mytree root enter mytree node0 enter mytree node1 enter mytree node1.0 enter mytree node1.1 enter mytree node1.2 enter mytree node2}

test tree-23.1 {getall gives error on bogus node} {
    tree mytree
    catch {mytree getall node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-23.2 {getall gives error when key specified} {
    tree mytree
    catch {mytree getall node0 -key data} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-23.3 {getall with node name returns list of key/value pairs} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    mytree set node0 -key other thing
    set results [mytree getall node0]
    mytree destroy
    lsort $results
} "data foobar other thing"
  
test tree-24.1 {keys gives error on bogus node} {
    tree mytree
    catch {mytree keys node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-24.2 {keys gives error when key specified} {
    tree mytree
    catch {mytree keys node0 -key data} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-24.3 {keys with node name returns list of keys} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    mytree set node0 -key other thing
    set results [mytree keys node0]
    mytree destroy
    lsort $results
} "data other"
  
test tree-25.1 {keyexists gives error on bogus node} {
    tree mytree
    catch {mytree keyexists node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-25.2 {keyexists returns false on non-existant key} {
    tree mytree
    mytree insert root end node0
    catch {mytree keyexists node0 -key bogus} msg
    mytree destroy
    set msg
} "0"
test tree-25.3 {keyexists uses data as default key} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foobar
    set result [mytree keyexists node0]
    mytree destroy
    set result
} "1"
test tree-25.4 {keyexists respects -key flag} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key boom foobar
    set result [mytree keyexists node0 -key boom]
    mytree destroy
    set result
} "1"

test tree-26.1 {append gives error on bogus node} {
    tree mytree
    catch {mytree append node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-26.2 {append with node name appends to "data" value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foo
    set result [mytree append node0 bar]
    mytree destroy
    set result
} "foobar"
test tree-26.3 {append with node name and key appends key value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key baz foo
    set result [mytree append node0 -key baz bar]
    mytree destroy
    set result
} "foobar"
test tree-26.4 {append with too many args gives error} {
    tree mytree
    mytree insert root end node0
    catch {mytree append node0 foo bar baz boo} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree set node0 ?-key key? value\""
test tree-26.5 {append with bad args} {
    tree mytree
    mytree insert root end node0
    catch {mytree append node0 -foo bar baz} msg
    mytree destroy
    set msg
} "invalid option \"-foo\": should be -key"
test tree-26.6 {append respects -key flag} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key baz foo
    set result [mytree append node0 -key baz bar]
    mytree destroy
    set result
} "foobar"

test tree-27.1 {lappend gives error on bogus node} {
    tree mytree
    catch {mytree lappend node0} msg
    mytree destroy
    set msg
} "node \"node0\" does not exist in tree \"mytree\""
test tree-27.2 {lappend with node name appends to "data" value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 foo
    set result [mytree lappend node0 bar]
    mytree destroy
    set result
} "foo bar"
test tree-27.3 {lappend with node name and key appends key value} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key baz foo
    set result [mytree lappend node0 -key baz bar]
    mytree destroy
    set result
} "foo bar"
test tree-27.4 {lappend with too many args gives error} {
    tree mytree
    mytree insert root end node0
    catch {mytree lappend node0 foo bar baz boo} msg
    mytree destroy
    set msg
} "wrong # args: should be \"mytree lappend node0 ?-key key? value\""
test tree-27.5 {lappend with bad args} {
    tree mytree
    mytree insert root end node0
    catch {mytree lappend node0 -foo bar baz} msg
    mytree destroy
    set msg
} "invalid option \"-foo\": should be -key"
test tree-27.6 {lappend respects -key flag} {
    tree mytree
    mytree insert root end node0
    mytree set node0 -key baz foo
    set result [mytree lappend node0 -key baz bar]
    mytree destroy
    set result
} "foo bar"

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/ChangeLog.

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

	* pkgIndex.tcl:
	* expander.man:
	* expander.tcl: Set version of the package to to 1.2

	* pkgIndex.tcl:
	* textutil.man: 
	* textutil.tcl: Fixed bug #614591. Set version
	  of the package to to 0.5

2003-03-31  Andreas Kupries  <[email protected]>

	* tabify.tcl (tabify, untabify): Changed from regsub to string map
	  This closes FR #693194 by David Welton
	  <[email protected]>.

2003-03-29  Andreas Kupries  <[email protected]>

	* expander.man:
	* expander.tcl: Added method 'ctopandclear' to retrieve data
	  captured in the current context without having to pop the
	  context (and loose state information). User: Plain text
	  formatter in 'doctools'.

2003-03-28  Andreas Kupries  <[email protected]>

	* adjust.test:
	* textutil.test: Added testsuite for new commands. Fixed typo bug
	  in yesterday's 'blank' and 'indent'.

	* adjust.tcl: New command 'undent'.
	* textutil.tcl: New command 'longestCommonPrefix'.

	* textutil.man: documented the new commands.

2003-03-27  Andreas Kupries  <[email protected]>

	* textutil.man:
	* adjust.tcl:
	* trim.tcl:
	* textutil.tcl: New commands: blank, chop, tail, cap, uncap,
	  indent, trimPrefix, and trimEmptyHeading. Imported from my own
	  Pool library. Also fixed some typos in the manpage: Superfluous
	  closing brackets. ... This closes Tcllib FR #514476.

2003-02-27  Andreas Kupries  <[email protected]>

	* textutil.man: Added two new commands,
	* textutil.tcl: ::textutil::adjust::listPredefined and
	                ::textutil::adjust::getPredefined to the
			package. They allow the user of the package to
			find the names and full paths of the hyphenation
			files coming with the package itself, making their
			use easier.

2003-01-27  Andreas Kupries  <[email protected]>

	* expander.man: Fixed typo in documentation.

2003-01-18  Andreas Kupries  <[email protected]>

	* adjust_hyph.test: Rewrote the file into a proper testsuite.

2003-01-16  Andreas Kupries  <[email protected]>

	* expander.man: More semantic markup, less visual one.
	* textutil.man:

2003-01-07  Andreas Kupries  <[email protected]>

	* textutil.tcl: Changed patchlevel in provide to match the
	  ifneeded in pkgIndex.tcl.

2002-08-11  vogeler <[email protected]>

        * adjust.tcl: added hyphenation (TeX). Hyphenation has been
          tested  for german, english, italian and spanish

2002-04-24  Andreas Kupries  <[email protected]>

        * expander.man: Fixed typo.

2002-03-26  Andreas Kupries  <[email protected]>

        * expander.man: New file, doctools manpage.

2002-03-14  Andreas Kupries  <[email protected]>

        * expander.tcl (Op_expand): Fix for SF Bug #530056. Added code
          checking start and end levels for pushed/popped contexts and
          alert the caller if the numbers do not match, indicating that
          the macros pushed more or less contexts than popped.

2002-02-26  Joe English  <[email protected]

        * tabify.tcl, tabify.test: fix for #521590,
          [tabify2 ""] and [untabify2 ""] raised an error.

2002-02-14  Tcl Project  <[email protected]>

        * expander.tcl: Frink run.

        * Versions are now 1.0.1 and 0.5 to distinguish this from the code
          in tcllib release 1.2

2002-01-18  Andreas Kupries  <[email protected]>

        * Bumped version to 0.4, Expander to 1.0.

2002-01-17  Joe English  <[email protected]>

        * textutil.n, expander.n: Fixed nroff markup errors.

2001-12-12  Andreas Kupries  <[email protected]>

        * expander.n:
        * expander.ehtml:
        * expander.html:
        * expander.tcl: Added 'textcmd' method which is called for all
          plain text encountered by the processor. Note: The textcmd is
          run through the evalcmd, i.e. it is treated as a special macro
          surrounding all plain text. It defaults to empty, meaning
          'identity'. Also moved the code handling errors in a macro into
          a separate function to make usage in multiple places
          easier. This is patch #492156.

2001-12-11  Andreas Kupries  <[email protected]>

        * textutil.n:
        * split.test:
        * split.tcl: Fixed item #476988, the handling of the empty input
          string, reported by Glenn Jackman
          <[email protected]>. Also added code to detect and
          handle an empty regular expression. In that case "splitx"
          degenerates to a simple "split".

2001-12-10  Andreas Kupries  <[email protected]>

        * expander.test:
        * expander.tcl:
        * expander.n:
        * expander.ehtml:
        * expander.html:
        * expander_notes.txt: Applied update on behalf of William
          implementing the 'evalcmd' feature, i.e. instead of using
          'uplevel #0' directly expander objects now have a configurable
          callback for the execution of macros. The default is still
          'uplevel #0' but this can be changed.

2001-12-07  Andreas Kupries  <[email protected]>

        * expander.test: Fixed a problem with the expander testsuite. It
          checked for the wrong namespace and thus did not load the
          functionality to be tested.

2001-11-28  Reinhard Max  <[email protected]>

        * split.tcl: Speed improvement by using [regexp -start] instead of
        repeatedly copying the tail of the string.

2001-11-12  Andreas Kupries  <[email protected]>

        * textutil.n:
        * adjust.tcl:
        * adjust.tcl: Added code, tests and documentation for option
          -strictlength as provided by Dan Kuchler <[email protected]>.

        * expander.tcl:
        * expander.test:
        * expander.ehtml:
        * expander.html:
        * expander.n:
        * expander_license.txt:
        * expander_notes.txt: Documentation, code and testsuite for
          expander objects; the heart of the expand macro processor by
          William H. Duquette <[email protected]> packaged up as a
          library.

2001-10-16  Andreas Kupries  <[email protected]>

        * pkgIndex.tcl:
        * textutil.n:
        * textutil.tcl: Version up to 0.3

2001-09-18   Andreas Kupries <[email protected]>

        * tabify.tcl (tabifyLine): Documentation of the algorithm
          expanded. Text provided by Helmut Giese.

2001-09-17    Andreas Kupries <[email protected]>

        * tabify.tcl: Added (un)tabify code provided by Helmut Giese
          <[email protected]> which is more editor-like than the
          existing code. The existing code was not deleted so both
          behaviours can be used in the future. This fixes [439016].

2001-07-10  Andreas Kupries <[email protected]>

        * tabify.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

        * split.tcl:
        * adjust.tcl:
        * trim.tcl: Fixed dubious code reported by frink.

2001-03-23 Andreas Kupries <[email protected]>

        * textutil.tcl: Reworked the implementation of 'StrRepeat', made
          it much faster (used code from Pool_Base). Renamed to
          'strRepeat' and exported.

          **Note** that the tcl implementation is one order of magnitude
          faster than [string repeat] for num >= 1000.

        * textutil.n: Added description of 'strRepeat'.
        * repeat.test: New file, tests 'strRepeat'.

2000-11-02  Eric Melski  <[email protected]>

        * textutil.test:
        * adjust.test:
        * split.test:
        * tabify.test:
        * trim.test:
        * adjust.tcl:
        * split.tcl:
        * tabify.tcl:
        * trim.tcl:
        * textutil.tcl: Added functions from Joel Saunier (adjust, splitx,
        tabify, trim, trimleft, trimright, untabify).

2000-07-01  Eric Melski  <[email protected]>

        * pkgIndex.tcl: Standard package index.

        * textutil.tcl: Added [package provide]; no actual functions yet,
        just the package stub.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































Deleted modules/textutil/adjust.tcl.

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

namespace eval ::textutil {

    namespace eval adjust {

	variable here [file dirname [info script]]
        variable StrRepeat [ namespace parent ]::strRepeat
        variable Justify  left
        variable Length   72
        variable FullLine 0
        variable StrictLength 0
        variable Hyphenate    0
        variable HyphPatterns

        namespace export adjust indent undent

        # This will be redefined later. We need it just to let
        # a chance for the next import subcommand to work
        #
        proc adjust { text args } { }
        proc indent { text args } { }
        proc undent { text args } { }
    }

    namespace import -force adjust::adjust adjust::indent adjust::undent
    namespace export adjust indent undent

}

#########################################################################

proc ::textutil::adjust::adjust { text args } {

    if { [ string length [ string trim $text ] ] == 0 } then {
        return ""
    }

    Configure $args
    Adjust text newtext

    return $newtext
}

proc ::textutil::adjust::Configure { args } {
  variable Justify         left
  variable Length    72
  variable FullLine  0
  variable StrictLength 0
  variable Hyphenate    0
  variable HyphPatterns;                       # hyphenation patterns (TeX)

    set args [ lindex $args 0 ]
    foreach { option value } $args {
      switch -exact -- $option {
        -full {
          if { ![ string is boolean -strict $value ] } then {
            error "expected boolean but got \"$value\""
          }
          set FullLine [ string is true $value ]
        }
        -hyphenate {
          if { ![ string is boolean -strict $value ] } then {
            error "expected boolean but got \"$value\""
          }
          set Hyphenate [string is true $value]
          if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} {
            error "hyphenation patterns not loaded!"
          }
        }
        -justify {
          set lovalue [ string tolower $value ]
          switch -exact -- $lovalue {
            left -
            right -
            center -
            plain {
              set Justify $lovalue
            }
            default {
              error "bad value \"$value\": should be center, left, plain or right"
            }
          }
        }
        -length {
          if { ![ string is integer $value ] } then {
            error "expected positive integer but got \"$value\""
          }
          if { $value < 1 } then {
            error "expected positive integer but got \"$value\""
          }
          set Length $value
        }
        -strictlength {
          if { ![ string is boolean -strict $value ] } then {
            error "expected boolean but got \"$value\""
          }
          set StrictLength [ string is true $value ]
        }
        default {
          error "bad option \"$option\": must be -full, -hyphenate, \
          -justify, -length, or -strictlength"
        }
      }
    }

    return ""
}

#
# Dies ist die relevante Routine
#

proc ::textutil::adjust::Adjust { varOrigName varNewName } {
  variable Length
  variable StrictLength
  variable Hyphenate

  upvar $varOrigName orig
  upvar $varNewName  text

  regsub -all -- "(\n)|(\t)"     $orig  " "  text
  regsub -all -- " +"            $text  " "  text
  regsub -all -- "(^ *)|( *\$)"  $text  ""   text

  set ltext [ split $text ]

  if { $StrictLength } then {

    # Limit the length of a line to $Length. If any single
    # word is long than $Length, then split the word into multiple
    # words.

    set i 0
    foreach tmpWord $ltext {
      if { [ string length $tmpWord ] > $Length } then {

        # Since the word is longer than the line length,
        # remove the word from the list of words.  Then
        # we will insert several words that are less than
        # or equal to the line length in place of this word.

        set ltext [ lreplace $ltext $i $i ]
        incr i -1
        set j 0

        # Insert a series of shorter words in place of the
        # one word that was too long.

        while { $j < [ string length $tmpWord ] } {

          # Calculate the end of the string range for this word.

          if { [ expr { [string length $tmpWord ] - $j } ] > $Length } then {
            set end [ expr { $j + $Length - 1} ]
          } else {
            set end [ string length $tmpWord ]
          }

          set ltext [ linsert $ltext [ expr {$i + 1} ] [ string range $tmpWord $j $end ] ]
          incr i
          incr j [ expr { $end - $j + 1 } ]
        }
      }
      incr i
    }
  }

  # End if { $StrictLength } ...

  set line [ lindex $ltext 0 ]
  set pos [ string length $line ]
  set text ""
  set numline 0
  set numword 1
  set words(0) 1
  set words(1) [ list $pos $line ]

  foreach word [ lrange $ltext 1 end ] {
    set size [ string length $word ]
    if { ( $pos + $size ) < $Length } then {
      # the word fits into the actual line ...
      #
      append line " $word"
      incr numword
      incr words(0)
      set words($numword) [ list $size $word ]
      incr pos
      incr pos $size
    } elseif { $Hyphenate } {
      # the word does not fit into the line and we must try to hyphenate

      set word2 [Hyphenation $word];
      set word2 [string trim $word2];
      set word3 "";
      set word4 ""

      set i 0;
      set iMax [llength $word2];

      # build up the part of the word to be kept in the current line

      while { $i < $iMax } {
        set syl [lindex $word2 $i]
        if { $pos + [string length " $word3$syl-"] > $Length } { break }
        append word3 $syl;
        incr i;
      }

      # build up the part of the hyphenated word to be transferred to
      # the next line

      while { $i < $iMax } {
        set syl [lindex $word2 $i];
        append word4 $syl;
        incr i;
      }

      # to be done in the future: code that guarantees that the
      # parts of the hyphenated word have a minimum length ..

      if {[string length $word3] && [string length $word4]} {
        # hyphenation was succesful: keep $word3 and the hyphen in the
        # current line and begin next line with $word4
        #
        # current line

        append line " $word3-"
        incr numword
        incr words(0)
        set words($numword) [list [string length $word3] $word3];
        incr pos;
        incr pos [string length $word3];

        if [string length $text] { append text "\n" }
        append text [ Justification $line [ incr numline ] words ]

        # next line

        set line "$word4"
        set pos [string length $word4];
        catch { unset words }
        set numword 1
        set words(0) 1
        set words(1) [ list $size $word ]
      } else {
        # hyphenation failed => close current line and begin
        # the next line with the unhyphenated word ($word)

        if [string length $text] { append text "\n" }
        append text [Justification $line [incr numline] words]

        set line "$word"
        set pos $size
        catch { unset words }
        set numword 1
        set words(0) 1
      }
    } else {
      # no hyphenation
      if [string length $text] { append text "\n" }
      append text [Justification $line [ incr numline ] words ]

      set line "$word"
      set pos $size
      catch { unset words }
      set numword 1
      set words(0) 1
      set words(1) [ list $size $word ]
    }
  }
  if [string length $text] { append text "\n" }
  append text [Justification $line end words]

  return $text
}

#
# Ende der relevanten Routine
#

proc ::textutil::adjust::Justification { line index arrayName } {
    variable Justify
    variable Length
    variable FullLine
    variable StrRepeat

    upvar $arrayName words

    set len [ string length $line ]
    if { $Length == $len } then {
        return $line
    }

    # Special case:
    # for the last line, and if the justification is set to 'plain'
    # the real justification is 'left' if the length of the line
    # is less than 90% (rounded) of the max length allowed. This is
    # to avoid expansion of this line when it is too small: without
    # it, the added spaces will 'unbeautify' the result.
    #

    set justify $Justify
    if { ( "$index" == "end" ) && \
             ( "$Justify" == "plain" ) && \
             ( $len < round($Length * 0.90) ) } then {
        set justify left
    }

    # For a left justification, nothing to do, but to
    # add some spaces at the end of the line if requested
    #

    if { "$justify" == "left" } then {
        set jus ""
        if { $FullLine } then {
            set jus [ $StrRepeat " " [ expr { $Length - $len } ] ]
        }
        return "${line}${jus}"
    }

    # For a right justification, just add enough spaces
    # at the beginning of the line
    #

    if { "$justify" == "right" } then {
        set jus [ $StrRepeat " " [ expr { $Length - $len } ] ]
        return "${jus}${line}"
    }

    # For a center justification, add half of the needed spaces
    # at the beginning of the line, and the rest at the end
    # only if needed.

    if { "$justify" == "center" } then {
        set mr [ expr { ( $Length - $len ) / 2 } ]
        set ml [ expr { $Length - $len - $mr } ]
        set jusl [ $StrRepeat " " $ml ]
        set jusr [ $StrRepeat " " $mr ]
        if { $FullLine } then {
            return "${jusl}${line}${jusr}"
        } else {
            return "${jusl}${line}"
        }
    }

    # For a plain justiciation, it's a little bit complex:
    # if some spaces are missing, then
    # sort the list of words in the current line by
    # decreasing size
    # foreach word, add one space before it, except if
    # it's the first word, until enough spaces are added
    # then rebuild the line
    #

    if { "$justify" == "plain" } then {
        set miss [ expr { $Length - [ string length $line ] } ]
        if { $miss == 0 } then {
            return "${line}"
        }

        for { set i 1 } { $i < $words(0) } { incr i } {
            lappend list [ eval list $i $words($i) 1 ]
        }
        lappend list [ eval list $i $words($words(0)) 0 ]
        set list [ SortList $list decreasing 1 ]

        set i 0
        while { $miss > 0 } {
            set elem [ lindex $list $i ]
            set nb [ lindex $elem 3 ]
            incr nb
            set elem [ lreplace $elem 3 3 $nb ]
            set list [ lreplace $list $i $i $elem ]
            incr miss -1
            incr i
            if { $i == $words(0) } then {
                set i 0
            }
        }
        set list [ SortList $list increasing 0 ]
        set line ""
        foreach elem $list {
            set jus [ $StrRepeat " " [ lindex $elem 3 ] ]
            set word [ lindex $elem 2 ]
            if { [ lindex $elem 0 ] == $words(0) } then {
                append line "${jus}${word}"
            } else {
                append line "${word}${jus}"
            }
        }

        return "${line}"
    }

    error "Illegal justification key \"$justify\""
}

proc ::textutil::adjust::SortList { list dir index } {

    if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then {
        error "$sl"
    }

    return $sl
}

# Hyphenation utilities based on Knuth's algorithm
#
# Copyright (C) 2001-2002 by Dr.Johannes-Heinrich Vogeler
# These procedures may be used as part of the tcllib

# textutil::adjust::Hyphenation
#
#      Hyphenate a string using Knuth's algorithm
#
# Parameters:
#      str     string to be hyphenated
#
# Returns:
#      the hyphenated string

proc ::textutil::adjust::Hyphenation { str } {

  variable HyphPatterns;                       # hyphenation patterns (TeX)

  set w ".[string tolower $str].";             # transform to lower case
  set wLen [string length $w];                 # and add delimiters

  # Initialize hyphenation weights

  set s {}
  for {set i 0} {$i < $wLen} {incr i} {
    lappend s 0;
  }

  for {set i 0} {$i < $wLen} {incr i} {
    set kmax [expr $wLen-$i];
    for {set k 1} {$k < $kmax} {incr k} {
      set sw [string range $w $i [expr $i+$k]];
      if [info exists HyphPatterns($sw)] {
        set hw $HyphPatterns($sw);
        set hwLen [string length $hw];
        for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} {
          set c [string index $hw $l1];
          if [string is digit $c] {
            set sPos [expr $i+$l2];
            if {$c > [lindex $s $sPos]} {
              set s [lreplace $s $sPos $sPos $c];
            }
          } else {
            incr l2;
          }
        }
      }
    }
  }

  # Replace all even hyphenation weigths by zero

  for {set i 0} {$i < [llength $s]} {incr i} {
    set c [lindex $s $i];
    if ![expr $c%2] { set s [lreplace $s $i $i 0] }
  }

  # Don't start with a hyphen! Take also care of words enclosed in quotes
  # or that someone has forgotten to put a blank between a punctuation
  # character and the following word etc.

  for {set i 1} {$i < [expr $wLen-1]} {incr i} {
    set c [string range $w $i end]
    if [regexp {^[:alpha:][.]*} $c] {
      for {set k 1} {$k < [expr $i+1]} {incr k} {
        set s [lreplace $s $k $k 0];
      }
      break
    }
  }

  # Don't separate the last character of a word with a hyphen

  set max [expr [llength $s]-2];
  if {$max} {set s [lreplace $s $max end 0]}

  # return the syllabels of the hyphenated word as a list!

  set ret "";
  set w ".$str.";
  for {set i 1} {$i < [expr $wLen-1]} {incr i} {
    if [lindex $s $i] { append ret - }
    append ret [string index $w $i];
  }
  return [split $ret -];
}

# textutil::adjust::listPredefined
#
#      Return the names of the hyphenation files coming with the package.
#
# Parameters:
#      None.
#
# Result:
#	List of filenames (without directory)

proc ::textutil::adjust::listPredefined {} {
    variable here
    return [glob -type f -directory $here -tails *.tex]
}

# textutil::adjust::getPredefined
#
#      Retrieve the full path for a predefined hyphenation file
#	coming with the package.
#
# Parameters:
#      name	Name of the predefined file.
#
# Results:
#	Full path to the file, or an error if it doesn't
#	exist or is matching the pattern *.tex.

proc ::textutil::adjust::getPredefined {name} {
    variable here

    if {![string match *.tex $name]} {
	return -code error \
		"Illegal hyphenation file \"$name\""
    }
    set path [file join $here $name]
    if {![file exists $path]} {
	return -code error \
		"Unknown hyphenation file \"$path\""
    }
    return $path
}

# textutil::adjust::readPatterns
#
#      Read hyphenation patterns from a file and store them in an array
#
# Parameters:
#      filNam  name of the file containing the patterns

proc ::textutil::adjust::readPatterns { filNam } {

  variable HyphPatterns;                       # hyphenation patterns (TeX)

  # HyphPatterns(_LOADED_) is used as flag for having loaded
  # hyphenation patterns from the respective file (TeX format)

  if [info exists HyphPatterns(_LOADED_)] {
    unset HyphPatterns(_LOADED_);
  }

  # the array xlat provides translation from TeX encoded characters
  # to those of the ISO-8859-1 character set

  set xlat(\"s) \337;                          # 223 := sharp s
  set xlat(\`a) \340;                          # 224 := a, grave
  set xlat(\'a) \341;                          # 225 := a, acute
  set xlat(\^a) \342;                          # 226 := a, circumflex
  set xlat(\"a) \344;                          # 228 := a, diaeresis
  set xlat(\`e) \350;                          # 232 := e, grave
  set xlat(\'e) \351;                          # 233 := e, acute
  set xlat(\^e) \352;                          # 234 := e, circumflex
  set xlat(\`i) \354;                          # 236 := i, grave
  set xlat(\'i) \355;                          # 237 := i, acute
  set xlat(\^i) \356;                          # 238 := i, circumflex
  set xlat(\~n) \361;                          # 241 := n, tilde
  set xlat(\`o) \362;                          # 242 := o, grave
  set xlat(\'o) \363;                          # 243 := o, acute
  set xlat(\^o) \364;                          # 244 := o, circumflex
  set xlat(\"o) \366;                          # 246 := o, diaeresis
  set xlat(\`u) \371;                          # 249 := u, grave
  set xlat(\'u) \372;                          # 250 := u, acute
  set xlat(\^u) \373;                          # 251 := u, circumflex
  set xlat(\"u) \374;                          # 252 := u, diaeresis

  set fd [open $filNam RDONLY];
  set status 0;

  while {[gets $fd line] >= 0} {

    switch -exact $status {
      PATTERNS {
        if [regexp {^\}[.]*} $line] {
          # End of patterns encountered: set status
          # and ignore that line
          set status 0;
          continue;
        } else {
          # This seems to be pattern definition line; to process it
          # we have first to do some editing
          #
          # 1) eat comments in a pattern definition line
          # 2) eat braces and coded linefeeds

          set z [string first "%" $line];
          if {$z > 0} { set line [string range $line 0 [expr $z-1]] }

          regsub -all {(\\n|\{|\})} $line {} tmp;
          set line $tmp;

          # Now $line should consist only of hyphenation patterns
          # separated by white space

          # Translate TeX encoded characters to ISO-8859-1 characters
          # using the array xlat defined above

          foreach x [array names xlat] {
            regsub -all {$x} $line $xlat($x) tmp;
            set line $tmp;
          }

          # split the line and create a lookup array for
          # the repective hyphenation patterns

          foreach item [split $line] {
            if [string length $item] {
              if ![string match {\\} $item] {
                # create index for hyphenation patterns

                set var $item;
                regsub -all {[0-9]} $var {} idx;
                # store hyphenation patterns as elements of an array

                set HyphPatterns($idx) $item;
              }
            }
          }
        }
      }
      EXCEPTIONS {
        if [regexp {^\}[.]*} $line] {
          # End of patterns encountered: set status
          # and ignore that line
          set status 0;
          continue;
        } else {
          # to be done in the future
        }
      }
      default {
        if [regexp {^\\endinput[.]*} $line] {
          # end of data encountered, stop processing and
          # ignore all the following text ..
          break;
        } elseif [regexp {^\\patterns[.]*} $line] {
          # begin of patterns encountered: set status
          # and ignore that line
          set status PATTERNS;
          continue;
        } elseif [regexp {^\\hyphenation[.]*} $line] {
          # some particular cases to be treated separately
          set status EXCEPTIONS
          continue;
        } else {
          set status 0;
        }
      }
    }                  ;# switch
  }

  close $fd;
  set HyphPatterns(_LOADED_) 1;

  return;
}

#######################################################

# @c The specified <a text>block is indented
# @c by <a prefix>ing each line. The first
# @c <a hang> lines ares skipped.
#
# @a text:   The paragraph to indent.
# @a prefix: The string to use as prefix for each line
# @a prefix: of <a text> with.
# @a skip:   The number of lines at the beginning to leave untouched.
#
# @r Basically <a text>, but indented a certain amount.
#
# @i indent
# @n This procedure is not checked by the testsuite.

proc ::textutil::adjust::indent {text prefix {skip 0}} {
    set text [string trim $text]

    set res [list]
    foreach line [split $text \n] {
	if {[string compare "" [string trim $line]] == 0} {
	    lappend res {}
	} elseif {$skip <= 0} {
	    lappend res $prefix[string trimright $line]
	} else {
	    lappend res [string trimright $line]
	}
	if {$skip > 0} {incr skip -1}
    }
    return [join $res \n]
}

# Undent the block of text: Compute LCP (restricted to whitespace!)
# and remove that from each line. Note that this preverses the
# shaping of the paragraph (i.e. hanging indent are _not_ flattened)
# We ignore empty lines !!

proc ::textutil::adjust::undent {text} {

    if {$text == {}} {return {}}

    set lines [split $text \n]
    set ne [list]
    foreach l $lines {
	if {[string length [string trim $l]] == 0} continue
	lappend ne $l
    }
    set lcp [::textutil::longestCommonPrefixList $ne]

    if {[string length $lcp] == 0} {return $text}

    regexp {^([ 	]*)} $lcp -> lcp

    if {[string length $lcp] == 0} {return $text}

    set len [string length $lcp]

    set res [list]
    foreach l $lines {
	if {[string length [string trim $l]] == 0} {
	    lappend res {}
	} else {
	    lappend res [string range $l $len end]
	}
    }
    return [join $res \n]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/adjust.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then {
    source [file join [file dirname [info script]] textutil.tcl]
}

set string "        hello,        world        "

set text "Hello, world!        
    This is the end,    my    friend.

You're just    another   brick   in   the   wall.
   Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
tr�s bien ensembles.

   Smoke on the water, and fire in the sky.		
   Oh Lord, don't let me be misunderstood.

Cause tramp like us, baby we were born to run."

set text2 "Hello, world!        
    This is the end,    my    friend.

You're just    another   brick   in   the   wall.
   Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
tr�s bien ensembles.

ThisIsSimilarToTextOnlyThisStringHasOneReallyLongWordInIt

   Smoke on the water, and fire in the sky.		
   Oh Lord, don't let me be misunderstood.

Cause tramp like us, baby we were born to run."

###################################################

test adjust-0.1 {adjust string on left} {
    ::textutil::adjust $string
} \
"hello, world"

test adjust-0.2 {adjust string on rigth} {
    ::textutil::adjust $string -justify right
} \
"                                                            hello, world"

test adjust-0.3 {adjust string on center} {
    ::textutil::adjust $string -justify center
} \
"                              hello, world"

test adjust-0.4 {adjust string with plain justification} {
    ::textutil::adjust $string -justify plain -full no
} \
"hello, world"

test adjust-0.5 {adjust string on left with full line} {
    ::textutil::adjust $string -full yes
} \
"hello, world                                                            "

test adjust-0.6 {adjust string on right with full line} {
    ::textutil::adjust $string -justify right -full yes
} \
"                                                            hello, world"

test adjust-0.7 {adjust string on center with full line} {
    ::textutil::adjust $string -justify center -full 1
} \
"                              hello, world                              "

test adjust-0.8 {adjust string with plain justification and full line} {
    ::textutil::adjust $string -justify plain -full YES
} \
"hello, world                                                            "

##############################

test adjust-1.1 {adjust multi lines on left} {
    ::textutil::adjust $text -full no
} \
"Hello, world! This is the end, my friend. You're just another brick in
the wall. Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
tr�s bien ensembles. Smoke on the water, and fire in the sky. Oh Lord,
don't let me be misunderstood. Cause tramp like us, baby we were born to
run."

test adjust-1.2 {adjust multi lines on right} {
    ::textutil::adjust $text -justify right
} \
"  Hello, world! This is the end, my friend. You're just another brick in
the wall. Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
  tr�s bien ensembles. Smoke on the water, and fire in the sky. Oh Lord,
don't let me be misunderstood. Cause tramp like us, baby we were born to
                                                                    run."

test adjust-1.3 {adjust multi lines on center} {
    ::textutil::adjust $text -justify center -full yes
} \
" Hello, world! This is the end, my friend. You're just another brick in 
the wall. Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
 tr�s bien ensembles. Smoke on the water, and fire in the sky. Oh Lord, 
don't let me be misunderstood. Cause tramp like us, baby we were born to
                                  run.                                  "

test adjust-1.4 {adjust multi lines with plain justification} {
    ::textutil::adjust $text -justify plain -full yes
} \
"Hello, world! This is the end, my friend.  You're just another  brick in
the wall. Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
tr�s bien ensembles.  Smoke on the water,  and fire in the sky. Oh Lord,
don't let me be misunderstood. Cause tramp like us, baby we were born to
run.                                                                    "

test adjust-1.5 {adjust multi lines with plain justification} {
    ::textutil::adjust $text -justify plain
} \
"Hello, world! This is the end, my friend.  You're just another  brick in
the wall. Michele, ma belle, sont des mots qui vont tr�s bien ensembles,
tr�s bien ensembles.  Smoke on the water,  and fire in the sky. Oh Lord,
don't let me be misunderstood. Cause tramp like us, baby we were born to
run."

##############################

test adjust-2.1 {adjust multi lines on left with specified length} {
    ::textutil::adjust $text -justify left -length 62
} \
"Hello, world! This is the end, my friend. You're just another
brick in the wall. Michele, ma belle, sont des mots qui vont
tr�s bien ensembles, tr�s bien ensembles. Smoke on the water,
and fire in the sky. Oh Lord, don't let me be misunderstood.
Cause tramp like us, baby we were born to run."

test adjust-2.2 {adjust multi lines on right with specified length} {
    ::textutil::adjust $text -justify right -length 62
} \
" Hello, world! This is the end, my friend. You're just another
  brick in the wall. Michele, ma belle, sont des mots qui vont
 tr�s bien ensembles, tr�s bien ensembles. Smoke on the water,
  and fire in the sky. Oh Lord, don't let me be misunderstood.
                Cause tramp like us, baby we were born to run."

test adjust-2.3 {adjust multi lines on center with specified length} {
    ::textutil::adjust $text -justify center -length 62 -full yes
} \
" Hello, world! This is the end, my friend. You're just another
 brick in the wall. Michele, ma belle, sont des mots qui vont 
 tr�s bien ensembles, tr�s bien ensembles. Smoke on the water,
 and fire in the sky. Oh Lord, don't let me be misunderstood. 
        Cause tramp like us, baby we were born to run.        "

test adjust-2.4 {adjust multi lines with plain justification} {
    ::textutil::adjust $text -justify plain -length 62 -full yes
} \
"Hello, world! This is the end, my friend.  You're just another
brick in the wall. Michele,  ma belle,  sont des mots qui vont
tr�s bien ensembles,  tr�s bien ensembles. Smoke on the water,
and fire in the sky. Oh Lord,  don't let me be  misunderstood.
Cause tramp like us, baby we were born to run.                "

test adjust-2.5 {adjust multi lines with plain justification} {
    ::textutil::adjust $text -justify plain -length 62
} \
"Hello, world! This is the end, my friend.  You're just another
brick in the wall. Michele,  ma belle,  sont des mots qui vont
tr�s bien ensembles,  tr�s bien ensembles. Smoke on the water,
and fire in the sky. Oh Lord,  don't let me be  misunderstood.
Cause tramp like us, baby we were born to run."

test adjust-2.6 {adjust multi lines with plain justification and long word} {
    ::textutil::adjust $text2 -justify plain -length 31 -strictlength 1
} \
"Hello,  world! This is the end,
my friend.  You're just another
brick in the wall. Michele,  ma
belle,  sont  des mots qui vont
tr�s bien ensembles,  tr�s bien
                     ensembles.
ThisIsSimilarToTextOnlyThisStri
     ngHasOneReallyLongWordInIt
Smoke on the water, and fire in
the sky. Oh Lord,  don't let me
be misunderstood.  Cause  tramp
like  us, baby  we were born to
run."

test adjust-2.7 {adjust multi lines with plain justification and strictlength} {
    ::textutil::adjust $text2 -justify plain -length 31 -strictlength 1
} \
"Hello,  world! This is the end,
my friend.  You're just another
brick in the wall. Michele,  ma
belle,  sont  des mots qui vont
tr�s bien ensembles,  tr�s bien
                     ensembles.
ThisIsSimilarToTextOnlyThisStri
     ngHasOneReallyLongWordInIt
Smoke on the water, and fire in
the sky. Oh Lord,  don't let me
be misunderstood.  Cause  tramp
like  us, baby  we were born to
run."

test adjust-2.8 {adjust multi lines with left justification and strictlength} {
    ::textutil::adjust $text2 -justify left -length 31 -strictlength 1
} \
"Hello, world! This is the end,
my friend. You're just another
brick in the wall. Michele, ma
belle, sont des mots qui vont
tr�s bien ensembles, tr�s bien
ensembles.
ThisIsSimilarToTextOnlyThisStri
ngHasOneReallyLongWordInIt
Smoke on the water, and fire in
the sky. Oh Lord, don't let me
be misunderstood. Cause tramp
like us, baby we were born to
run."

###################################################

unset string
unset text
unset text2

###################################################
# Indentation

test indent-1.0 {indent spaces, no skip} {
    ::textutil::indent {foo
bar

bob} {    }
} {    foo
    bar

    bob}

test indent-1.1 {indent spaces, negative skip} {
    ::textutil::indent {foo
bar

bob} {    } -4
} {    foo
    bar

    bob}

test indent-1.2 {indent spaces, skip one} {
    ::textutil::indent {foo
bar

bob} {    } 1
} {foo
    bar

    bob}

test indent-1.3 {indent spaces, skip three} {
    ::textutil::indent {foo
bar

bob} {    } 3
} {foo
bar

    bob}

test indent-1.4 {indent spaces, skip all} {
    ::textutil::indent {foo
bar

bob} {    } 5
} {foo
bar

bob}

test indent-1.5 {indent spaces, skip all, on border} {
    ::textutil::indent {foo
bar

bob} {    } 4
} {foo
bar

bob}



test undent-1.0 {undent, empty line, completely empty} {
    ::textutil::undent {    foo
    bar

    bob}
} {foo
bar

bob}

test undent-1.1 {undent, empty line, whitespace} {
    ::textutil::undent {    foo
    bar
    	
    bob}
} {foo
bar

bob}

test undent-1.2 {undent, ignore common non-whitespace prefix} {
    ::textutil::undent {    foo
    foobar
    foobob}
} {foo
foobar
foobob}

test undent-1.3 {undent, ignore common non-whitespace part of prefix} {
    ::textutil::undent {    foo 
    foo bar
    foo bob}
} {foo 
foo bar
foo bob}


::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/adjust_hyph.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
# -*- tcl -*-
# adjust.test:  tests for the adjust sub-package of the textutil package.

##################################################################
# Main programme to test adjust/hyphenation: shows some examples #
# of hyphenated text                                             #
#                                                                #
# Note: the files dehypht.tex, eshyph_vo.tex and ithyph.tex must #
# reside in the same directory as adjust_hyph.tcl               #
##################################################################

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

source [file join $::tcltest::testsDirectory adjust.tcl];

##########
# German #
##########

test adjust-tex-1.0 {German hyphenation} {
    #puts "\nTest german hyphenation ...\n";

    set str "Kurz berichtet: Theodor Holzkopf (Name frei erfunden) promovierte \
zum Doktor der Rechte �ber das Thema 'Die B�llersch�sse im V�lkerrecht'"
    set wid 16

    # Setup hyphenation patterns, then perform adjustment
    textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "dehypht.tex"]
    textutil::adjust $str -hyphenate 1 -length $wid
} {Kurz berichtet:
Theodor Holzkopf
(Name frei er-
funden) promo-
vierte zum Dok-
tor der Rechte
�ber das Thema
'Die B�ller-
sch�sse im V�l-
kerrecht'}

###########
# italian #
###########

test adjust-tex-1.1 {Italian hyphenation} {
    #puts "\nTest italian hyphenation ...\n"

    set str "Non sappiamo con precisione quando a Roma furono \
        institutite le prime scuole regolari, cio� 'statali'. \
        Plutarcho dice che nacquero verso il 250 avanti Cristo, \
        cio� circa cinquecent'anni dopo la fondazione della citt�. \
        (Indro Montanelli)"
    set wid 20;
    textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "ithyph.tex"]
    textutil::adjust $str -hyphenate 1 -length $wid
} {Non sappiamo con
precisione quando a
Roma furono institu-
tite le prime scuole
regolari, cio� 'sta-
tali'. Plutarcho di-
ce che nacquero ver-
so il 250 avanti
Cristo, cio� circa
cinquecent'anni dopo
la fondazione della
citt�. (Indro Monta-
nelli)}

###########
# spanish #
###########

test adjust-tex-1.2 {Spanish hyphenation} {
    #puts "\nTest spanish hyphenation ...\n";

    set str "El panorama politico estar� convulsionado porque los emeneristas, \
        adem�s de no contar con el apoyo del NFR para gobernar en el periodo \
        2002-2007, se proponen junto con los ucesistas a aprobar los \
        cambios a la carta magna (Periodico La Razon, Bolivia)"
    set wid 20;
    textutil::adjust::readPatterns [file join $::tcltest::testsDirectory "eshyph_vo.tex"]
    textutil::adjust $str -hyphenate 1 -length $wid
} {El panorama politico
estar� convulsionado
porque los
emeneristas, adem�s
de no contar con el
apoyo del NFR para
gobernar en el peri-
odo 2002-2007, se
proponen junto con
los ucesistas a a-
probar los cambios a
la carta magna (Pe-
riodico La Razon,
Bolivia)}

##########

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































Deleted modules/textutil/dehypht.tex.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
% This is `dehypht.tex' as of 03 March 1999.
%
% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum
%               [german hyphen patterns]
% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V.
%               [macros, adaption for TeX 2]
%
% -----------------------------------------------------------------
% IMPORTANT NOTICE:
%
% This program can be redistributed and/or modified under the terms
% of the LaTeX Project Public License Distributed from CTAN
% archives in directory macros/latex/base/lppl.txt; either
% version 1 of the License, or any later version.
% -----------------------------------------------------------------
%
%
% This file contains german hyphen patterns following traditional
% hyphenation rules and includes umlauts and sharp s, but without
% `c-k' and triple consonants.  It is based on hyphen patterns
% containing 5719 german hyphen patterns with umlauts in the
% recommended version of September 27, 1990.
%
% For use with TeX generated by
%
%          Norbert Schwarz
%          Rechenzentrum Ruhr-Universitaet Bochum
%          Universitaetsstrasse 150
%          D-44721 Bochum, FRG
%
%
% Adaption of these patterns for TeX, Version 2.x and 3.x and
% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by
%
%          Bernd Raichle
%          Stettener Str. 73
%          D-73732 Esslingen, FRG
%   Email: [email protected]
%
%
% Error reports in case of UNCHANGED versions to
%
%          DANTE e.V., Koordinator `german.sty'
%          Postfach 10 18 40
%          D-69008 Heidelberg, FRG
%   Email: [email protected]
%
% or one of the addresses given above.
%
%
% Changes:
%  1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz)
%  1991-02-13 PC umlauts changed to ^^xx  (Norbert Schwarz)
%  1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro
%             definitions and additional logic to select correct
%             patterns/encoding  (Bernd Raichle)
%  1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle)
%  1999-03-03 Renamed file to `dehypht.tex' according to the
%             naming scheme using the ISO country code `de', the
%             common part `hyph' for all hyphenation patterns files,
%             and the additional postfix `t' for traditional,
%             removed wrong catcode change of ^^e (the comment
%             character %) and ^^f (the character &),
%             do _not_ change \catcode, \lccode, \uccode to avoid
%             problems with other hyphenation pattern files,
%             changed code to distinguish TeX 2.x/3.x,
%             changed license conditions to LPPL (Bernd Raichle)
%
%
% For more information see the additional documentation
% at the end of this file.
%
% -----------------------------------------------------------------
%
\message{German Traditional Hyphenation Patterns %
         `dehypht' Version 3.2a <1999/03/03>}
\message{(Formerly known under the name `ghyph31' and `ghyphen'.)}
%
%
% Next we define some commands which are used inside the patterns.
% To keep them local, we enclose the rest of the file in a group
% (The \patterns command globally changes the hyphenation trie!).
%
\begingroup
%
%
% Make sure that doublequote is not active:
\catcode`\"=12
%
%
% Because ^^e4 is used in the following macros which is read by
% TeX 2.x as ^^e or %, the comment character of TeX, some trick
% has to be found to avoid this problem.  The same is true for the
% character ^^f or & in the TeX 2.x code.
% Therefore in the code the exclamationmark ! is used instead of
% the circumflex ^ and its \catcode is set appropriately
% (normally \catcode`\!=12, in the code \catcode`\!=7).
%
% The following \catcode, \lccode assignments and macro definitions
% are defined in such a way that the following \pattern{...} list
% can be used for both, TeX 2.x and TeX 3.x.
%
% We first change the \lccode of ^^Y to make sure that we can
% include this character in the hyphenation patterns.
%
\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y
%
% Then we have to define some macros depending on the TeX version.
% Therefore we have to distinguish TeX version 2.x and 3.x:
%
\ifnum`\@=`\^^40 % true => TeX 3.x
  %
  % For TeX 3:
  % ----------
  %
  % Assign appropriate \catcode and \lccode values for all
  % accented characters used in the patterns (\uccode changes are
  % not used within \patterns{...} and thus not necessary):
  %
  \catcode"E4=11 \catcode"C4=11 % \"a \"A
  \catcode"F6=11 \catcode"D6=11 % \"o \"O
  \catcode"FC=11 \catcode"DC=11 % \"u \"U
  \catcode"FF=11 \catcode"DF=11 % \ss  SS
  %
  \lccode"C4="E4 \uccode"C4="C4  \lccode"E4="E4 \uccode"E4="C4
  \lccode"D6="F6 \uccode"D6="D6  \lccode"F6="F6 \uccode"F6="D6
  \lccode"DC="FC \uccode"DC="DC  \lccode"FC="FC \uccode"FC="DC
  \lccode"DF="FF \uccode"DF="DF  \lccode"FF="FF \uccode"FF="DF
  %
  % In the following definitions we use ??xy instead of ^^xy
  % to avoid errors when reading the following macro definitions
  % with TeX 2.x (remember ^^e(4) is the comment character):
  %
  \catcode`\?=7
  %
  % Define the accent macro " in such a way that it
  % expands to single letters in font encoding T1.
  \catcode`\"=13
  \def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else
      \errmessage{Hyphenation pattern file corrupted!}%
    \fi\fi\fi}
  %
  %   - patterns with umlauts are ok
  \def\n#1{#1}
  %
  % For \ss which exists in T1 _and_ OT1 encoded fonts but with
  % different glyph codes, duplicated patterns for both encodings
  % are included.  Thus you can use these hyphenation patterns for
  % T1 and OT1 encoded fonts:
  %   - define \3 to be code `\^^ff (\ss in font encoding T1)
  %   - define \9 to be code `\^^Y  (\ss in font encoding OT1)
  \def\3{??ff}
  \def\9{??Y}
  %   - duplicated patterns to support font encoding OT1 are ok
  \def\c#1{#1}
  %   >>>>>>  UNCOMMENT the next line, if you do not want
  %   >>>>>>  to use fonts in font encoding OT1
  %\def\c#1{}
  %
  \catcode`\?=12
  %
\else
  %
  % For TeX 2:
  % ----------
  %
  % Define the accent macro " to throw an error message.
  \catcode`\"=13
  \def"#1{\errmessage{Hyphenation pattern file corrupted!}}
  %
  %   - ignore all patterns with umlauts
  \def\n#1{}
  %
  % With TeX 2 fonts in encoding T1 can be used, but all glyphs
  % in positions > 127 can not be used in hyphenation patterns.
  % Thus only patterns with glyphs in OT1 positions are included:
  %   - define \3 to be code ^^Y (\ss in CM font encoding)
  %   - define \9 to throw an error message
  \def\3{^^Y}
  \def\9{\errmessage{Hyphenation pattern file corrupted!}}
  %   - ignore all duplicated patterns with \ss in T1 encoding
  \def\c#1{}
  %
\fi
%
%
\patterns{%
.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6
.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z
.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s
.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe
.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen
.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban
.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p
.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a
\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e
.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1
.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra}
.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top
.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re
.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be}
\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n
.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1
.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges
.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr
aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr
ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la
5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c
1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw
5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce.  a5chal ach5art ach5au a1che
a8chent ach6er.  a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu
ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad.  a6d5ac ad3ant
ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1
1adv \n{a6d"a} a1e2d ae1r a1er.  1aero 8afa a3fal af1an a5far a5fat
af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re
a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn
ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar
ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu
\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re.  a5isch.  ais8e a3ismu ais6n
aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm
al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb
a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar
alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur
alu3ta \n{a1l"a} a6mate 8ame.  5a6meise am6m5ei am6mum am2n ampf3a
am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy
an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis
an1e2k 4aner.  a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab
5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka
an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no
5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal
an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug
\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t
\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr
\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein
ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony
a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w
\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec
asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc
a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a
ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn
a1to a6t5ops ato6ra a6t5ort.  4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu
atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent
\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge.  au4kle aule8s 6aum
au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz
aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x
a2xia a6xio a1ya a1z azi5er.  8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na
ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d
1be be1a be8at.  be1ch 8becht 8becke.  be5el be1en bee8rei be5eta bef2
8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac
bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u}
be1o2 b8er.  be1ra be8rac ber8gab.  ber1r \n{be1r"u} bes8c bes5erh
bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2
bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na
bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la.
6b1lad 6blag 8blam 1blat b8latt 3blau.  b6lav 3ble.  b1leb b1led
8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind
8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc
\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo
bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8
bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh}
\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p
bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin
6b1v 2b1w 1by1 by6te.  8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u}
\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re
ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch.  1chae ch1ah ch3akt cha6mer
8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl
6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie
5cho.  8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha
cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k
2ck.  ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o
con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da.
8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce.
dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb
d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d
d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr
5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r
8denge.  8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers
der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul
de5us.  2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn
di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p
di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m
2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h
do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre.  4drech
d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres.  6d5rh 1dria
d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b}
\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha.  5dschik dse8e d8serg
8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti
d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie
8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s
du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r}
\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te}
\n{1d"u} ea4ben e1ac e1ah e1akt e1al.  e5alf e1alg e5a8lin e1alk e1all
e5alp e1alt e5alw e1am e1and ea6nim e1ar.  e5arf e1ark e5arm e3art
e5at.  e6ate e6a5t6l e8ats e5att e6au.  e1aus e1b e6b5am ebens5e
eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send
ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t
ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a}
ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha
e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec
e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a}
\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei
ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4
ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor
\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al
eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l
e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm
e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif
e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc
elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu
elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto
e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af
en5all en3alt en1am en3an.  en3ant en3anz en1a6p en1ar en1a6s 6e1nat
en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene.  en5eck
e8neff e6n5ehr e6n5eim en3eis 6enem.  6enen e4nent 4ener.  e8nerd
e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess
e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf
e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid
3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of}
\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on.  e3onf e5onk e5onl e5onr
e5opf e5ops e5or.  e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent
e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos.  ep4p3a e1pr \n{e1p"a} e1q
e1ra.  er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e
era5k6l er3all er3amt e3rand e3rane er3ans e5ranz.  e1rap er3arc
e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re.
er3eck er5egg er5e2h 2erei e3rei.  e8reine er5einr 6eren.  e4r3enm
4erer.  e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan.
5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind
e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.}
ermen6s er6nab 3ernst 6e1ro.  e1rod er1o2f e1rog 6e3roi ero8ide e3rol
e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein
er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa
er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa
esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill
es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs
e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta
et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr
et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw
\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2
e1um.  eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s
eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er.  e1z \n{e1"a2}
\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el.
fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art
fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim
8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd.  ferri8 fe8stof
fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la
ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi
fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in.  fi1na 8finf fi8scho fi6u
6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor
\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra
for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram
1f8ran f8ra\3 \c{f8ra\9} f8re.  frei1 5frei.  f3reic f3rest f1rib
8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str
\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad
ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end
\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug}
\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u}
\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la
6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm
ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c
6gd g1da 1ge ge1a2 ge6an ge8at.  ge1e2 ge6es gef2 8geff ge1g2l ge1im
4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf
\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz.
\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei
5ghel.  g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me.  gi1na
4g3ins gi3str g1j 2g1k 8gl.  1glad g5lag glan4z3 1glas 6glass 5glaub
g3lauf 1gle.  g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a
g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss
g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn.  1gna 8gnach 2gnah g1nas g8neu
g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist
go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic
g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3
\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc
gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te
g2t1h 1gu gu5as gu2e 2gue.  6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu
4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u}
\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el.  haf6tr 2hal.  ha1la
hal4b5a 6hale 8han.  ha1na han6dr han6ge.  2hani h5anth 6hanz 6harb
h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d
he2bl he3cho h3echt he5d6s 5heft h5e6he.  hei8ds h1eif 2hein he3ism
he5ist.  heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end
hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au
h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th
heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2
hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr
5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3
\c{h1la\9} hl1c h1led h3lein h5ler.  h2lif h2lim h8linf hl5int h2lip
h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n
hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1
1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn.  ho3sl hos1p
ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg
h8rei.  h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra
hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob
h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und
\n{h1s"u} h5ta.  h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub
h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf
hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess
h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so
h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr.  huld5a6 hu8lent
\n{hu8l"a} h5up.  h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s}
\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.}
\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t}
\n{h"utte8re} i5adn i1af i5ak.  i1al.  i1al1a i1alb i1ald i5alei i1alf
i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz
i1an.  ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo
i1ar.  ia6rab i5arr i1as.  i1asm i1ass i5ast.  i1at.  i5ats i1au i5azz
i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei
i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu
ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot
id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a}
ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei
ie4lek i3ell i1en.  i1end ien6e i3enf i5enn ien6ne.  i1enp i1enr
i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein
ie6r5eis ier8er i3ern.  ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the
ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie
i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot
ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s
ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans
i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e
i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a}
\n{i5m"o} ina5he i1nat in1au inau8s 8ind.  in4d3an 5index ind2r 3indus
i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er.  5inj
\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit
5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar}
\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di
ioi8 i1ol.  i1om.  i1on.  i5onb ion2s1 i1ont i5ops i5o8pt i1or.
i3oral io3rat i5orc i1os.  i1ot.  i1o8x 2ip i1pa i1pi i1p2l i1pr i1q
i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl
ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei
isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind
is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab.  i2t1a2m
i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl
itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru
i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5}
\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur
i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r}
\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la
je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s
\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl
ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb
kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein
6k5eis ke6lar ke8leis ke8lo 8kemp k5ente.  k3entf 8k5ents 6kentz ke1ra
k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th
\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc
4k3leit k3lek 6k5ler.  5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor
\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de.
ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou
3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig
2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat
k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re
k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5
kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9}
6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o}
\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la.
8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn
5laken 8lamb la6mer 5lampe.  2l1amt la1na 1land lan4d3a lan4d3r lan4gr
8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar.  la5ra lar4af
la8rag la8ran la6r5a6s l3arbe la8rei 6larm.  la8sa la1sc la8sta lat8i
6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo
lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei
ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br
le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en.  8lends
6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi
le6pip 8lepo 1ler l6er.  8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg
l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s
5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6
6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3
\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5
4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam
livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la
ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a
l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a}
\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch.
l5o4fen 5loge.  5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg
4lort lo1ru 1los.  lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn
lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh
l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein
l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o}
lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr
lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol
4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg
lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6
6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on}
\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v}
\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma
8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e
malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa
4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b
mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal
men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th
me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na
\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj
2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums
mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d
m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot
moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste
m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc
msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a}
mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my
2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3}
\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na.
n5ab.  8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el
n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama
na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and.  2n1ang 1nani
1nann n1ans 8nanw 5napf.  1n2ar.  na2ra 2n1arc n8ard 1nari n8ark
6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk
na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c
nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi
nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau
ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy
4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb
4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde.
nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers.  6n5ertra
2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l
nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip
ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl
\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik
ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int
n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh
\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh
\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h
nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt
noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony
4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st
8nost.  no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac
ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr
n6s5tat.  n5s6te.  n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art
n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie
n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f
ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s
nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu
nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr
2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar
n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai}
\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol}
\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}}
o5ab.  oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru
obe6ser 1obj o1bl o2bli ob5sk 3obst.  ob8sta obst5re ob5sz o1che
oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d
o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der.  oe8du o1ef o1e2l
o1e2p o1er.  o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g
og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm.  oh2ni o1ho
oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id.  o8idi oi8dr o5ids
o5isch.  oiset6 o1ism o3ist.  o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a}
1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1
ol8lak ol8lauf.  ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym
o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o}
o1na ona8m on1ax on8ent o6n5erb 8oni oni5er.  on1k on6n5a6b o1no ono1c
o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli
opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti
\n{o1p"a} \n{o5p"o} o1q o1ra.  o3rad o8radd 1oram o6rang o5ras o8rauf
or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re.  ore2h o8r5ein
ore5isc or6enn or8fla or8fli 1orga 5orgel.  or2gl o1ri 5o6rient or8nan
\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a}
\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr
osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze
o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a
ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu
ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer.  o1wi
owid6 o1wo o5wu o1xe oy5al.  oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is
\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak
pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n
par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b
8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea
per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s
p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph.
2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2
ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis
pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik
6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra
2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l
ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod
5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as}
\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu
pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py
py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h}
\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr
5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall
ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli
r3angr rans5pa 8ranw r8anz.  ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh
r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n
6raus.  r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n
r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd
r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re.
re1ak 3reakt re3als re6am.  re1as 4reben re6bl rech5a r8edi re3er
8reff 3refl 2reh 5reha r4ei.  reich6s5 8reier 6reign re5imp 4r3eina
6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf
2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz
ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl
4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec
\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie
8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8
r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en
ri3er.  ri5ers.  ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8}
ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst
\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u}
ri5sv r2it 6r5i6tal ri5tr ri6ve.  8r1j 6rk r1ke rkehrs5 r1ki r3klin
r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m
r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei
r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern
6robs ro1ch 3rock.  ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc
6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout
r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o}
r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u}
2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p
r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige
r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser
rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg
2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us
ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al
r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc}
\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or}
\n{r"o2sc} \n{3r"ump} 1sa.  1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw
3sack.  6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal
sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl
2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar.  2s1arb 3sarg
s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff
sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch.  3scha.  5schade
3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg
2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}}
6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig
8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o}
\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g
se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid.  2s1eig s8eil 5sein.
sei5n6e 6s5einh 3s8eit 3sel.  se4lar selb4 6s3e4lem se8lerl 2s1emp
sen3ac se5nec 6s5ents 4sentz s8er.  se8reim ser5inn \n{8serm"a}
8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h
s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en
si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la
sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j
s1k2 6sk.  2skau skel6c skelch5 s6kele 1s2ki.  3s4kin.  s6kiz s8kj
6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m
s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope
so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap
s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi
spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra
3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an}
\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st.  1sta 4stafe 2stag
sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te
6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese
8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el
4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll.  4st3ope
6stopf.  6stord 6stp 5stra.  4strai 3s4tral 6s5traum 3stra\3
\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev
5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum
\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun.  2stv 2stw s2tyl
6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.}
1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran
6surte 2s1v 2s1w 1sy 8syl.  sy5la syn1 sy2na syne4 s1z s4zend 5s6zene.
8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}}
\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3}
\n{\c{5s"u\9}} taats3 4tab.  taba6k ta8ban tab2l ta6bre 4tabs t3absc
8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei
tage4s tag6s5t tah8 tahl3 tai6ne.  ta5ir.  tak8ta tal3au 1tale ta8leng
tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e
6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe
1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem
ta8sto t5aufb 4taufn 8taus.  5tause 8tausf 6tausg t5ausl 2t1b2 2t1c
t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel
2t1ehr te5id.  teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen
8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p
ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar
t5erbe.  6terben 8terbs 4t3erbt t5erde.  ter5ebe ter5ein te8rers terf4
\n{8terh"o} \n{6terkl"a} ter8nor ter6re.  t8erscha t5e6sel te8stau
t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th.  th6a 5tha.  2thaa
6t1hab 6t5haf t5hah 8thak 3thal.  6thals 6t3hand 2t1hau 1the.  3t4hea
t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet
5thi.  2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof
4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u}
ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind
tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a
2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e
6t5o6fen to1in toi6r 5toll.  to8mene t2ons 2t1ony to4per 5topf.  6topt
to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha
tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st
3traue t4re.  2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif
8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink
tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man.  tro3ny 5tropf
6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh}
\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d
ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i
tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort.
t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf
t8sum.  t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser
tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums
8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re.  tu4r3er 2t1v 2t1w 1ty1
ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei.
t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an}
\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen}
\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.}
u3al.  u5alb u5alf u3alh u5alk u3alp u3an.  ua5na u3and u5ans u5ar.
ua6th u1au ua1y u2bab ubi5er.  u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc
u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w
uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o
u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re
\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn
ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o}
6ui ui5en u1ig u3ins uin8tes u5isch.  u1j 6uk u1ke u1ki u1kl u8klu
u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo
ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f
um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und.  5undein
un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal
\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro
unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os.  u1pa u1pi u1p2l u1pr
up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans
u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6
ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry
ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa
usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b
us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au
u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5
uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n
\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n
\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei
va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8
ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le.
8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li
v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z
waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru
war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r
weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk.
wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str
\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma
win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2
w1sk 6w5t 5wunde.  wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc}
1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe.  x3e4g 1xen xe1ro x1erz
1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d
8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya.
y5an.  y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j
y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d
yn1t y1on.  y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty
y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange.
8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein
zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a}
zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex
2z1f8 z1g 4z1h 1zi zi1en zi5es.  4z3imp zi1na 6z5inf 6z5inni zin6s5er
8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh
zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al
zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z
2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s
6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le}
\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi}
\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era}
\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h}
\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le}
\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu}
\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j}
\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e}
\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l}
\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq}
\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri}
\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o}
\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4}
\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl}
\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga}
\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z}
\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6}
\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu}
\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl}
\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l}
\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru}
\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w}
\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r}
\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck}
\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4}
\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh}
\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w}
\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c}
\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw}
\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng}
\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n}
\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti}
\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a.
\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d}
1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h}
2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h
\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m}
\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q
\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta}
\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to}
\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w
\c{\91w} \31z \c{\91z}
}%
\endgroup
\relax\endinput
%
% -----------------------------------------------------------------
%
% =============== Additional Documentation ===============
%
%
% Older Versions of German Hyphenation Patterns:
% ----------------------------------------------
%
% All older versions of `ghyphen.tex' distributed as
%
%       ghyphen.tex/germhyph.tex   as of 1986/11/01
%       ghyphen.min/ghyphen.max    as of 1988/10/10
%       ghyphen3.tex               as of 1990/09/27 & 1991/02/13
%       ghyph31.tex                as of 1994/02/13
%
% are out of date and it is recommended to replace them
% with the new version `dehypht.tex' as of 1999/03/03.
%
% If you are using `ghyphen.min' (a minor version of `ghyphen')
% because of limited trie memory space, try this version and if
% the space is exceeded get a newer TeX implementation with
% larger or configurable trie memory sizes.
%
%
%
% Trie Memory Requirements/Space for Hyphenation Patterns:
% --------------------------------------------------------
%
% To load this set of german hyphenation patterns the parameters
% of TeX has to have at least these values:
%
% TeX 3.x:
%    IniTeX:    trie_size >= 9733    trie_op_size >= 207
%    VirTeX:    trie_size >= 8375    trie_op_size >= 207
%
% TeX 2.x:
%    IniTeX:    trie_size >= 8675    trie_op_size >= 198
%    VirTeX:    trie_size >= 7560    trie_op_size >= 198
%
% If you want to load more than one set of hyphenation patterns
% (in TeX 3.x), the parameters have to be set to a value larger
% than or equal to the sum of all required values for each set.
%
%
% Setting Trie Memory Parameters:
% -------------------------------
%
% Some implementations allow the user to change the default value
% of a set of the internal TeX parameters including the trie memory
% size parameter specifying the used memory for the hyphenation
% patterns.
% 
% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32)
% and newer:
%   The used memory size of the true is usually set high enough.
%   If needed set the size of the trie using the keyword `trie_size'
%   in the configuration file `texmf/web2c/texmf.cnf'.  For details
%   see the included documentation.
%
% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT):
%   You can set the used memory size of the trie using the
%   `-mt<number>' option on the command line or in the
%   TEXOPTIONS environment variable.
%
% PasTeX (Amiga):
%   The values for the parameters can be set using the keywords
%   `triesize', `itriesize' and `trieopsize' in the configuration
%   file.
%
% others (binaries only):
%   See the documentation of the implementation if it is possible
%   and how to change these values without recompilation.
%
% others (with sources)
%   If the trie memory is too small, you have to recompile TeX
%   using larger values for `trie_size' and `trie_op_size'.
%   Modify the change file `tex.ch' and recompile TeX.
%   For details see the documentation included in the sources.
%
%
%
% Necessary Settings in TeX macro files:
% --------------------------------------
%
% \lefthyphenmin, \righthyphenmin:
%   You can set both parameters to 2.
%
% \lccode <char>:
%   To get correct hyphenation points within words containing
%   umlauts or \ss, it's necessary to assign values > 0 to the
%   appropriate \lccode <char> positions.
%
% These changes are _not_ done when reading this file and have to
% be included in the language switching mechanism as is done in,
% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1,
% \left-/\righthyphenmin settings).
%
%
%% \CharacterTable
%%  {Upper-case    \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
%%   Lower-case    \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
%%   Digits        \0\1\2\3\4\5\6\7\8\9
%%   Exclamation   \!     Double quote  \"     Hash (number) \#
%%   Dollar        \$     Percent       \%     Ampersand     \&
%%   Acute accent  \'     Left paren    \(     Right paren   \)
%%   Asterisk      \*     Plus          \+     Comma         \,
%%   Minus         \-     Point         \.     Solidus       \/
%%   Colon         \:     Semicolon     \;     Less than     \<
%%   Equals        \=     Greater than  \>     Question mark \?
%%   Commercial at \@     Left bracket  \[     Backslash     \\
%%   Right bracket \]     Circumflex    \^     Underscore    \_
%%   Grave accent  \`     Left brace    \{     Vertical bar  \|
%%   Right brace   \}     Tilde         \~}
%%
\endinput
%% 
%% End of file `dehypht.tex'.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/eshyph_vo.tex.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
.\'a2
.\'aa2
.\'ae2
.\'ai2
.\'ao2
.\'au2
.\'e2
.\'ea2
.\'ee2
.\'ei2
.\'eo2
.\'eu2
.\'i2
.\'ia2
.\'ie2
.\'ii2
.\'io2
.\'iu2
.\'o2
.\'oa2
.\'oe2
.\'oi2
.\'oo2
.\'ou2
.\'u2
.\'ua2
.\'ue2
.\'ui2
.\'uo2
.\'uu2
.a2
.a\'a2
.a\'e2
.a\'i2
.a\'o2
.a\'u2
.aa2
.ae2
.ai2
.ao2
.au2
.e2
.e\'a2
.e\'e2
.e\'i2
.e\'o2
.e\'u2
.ea2
.ee2
.ei2
.eo2
.eu2
.i2
.i\'a2
.i\'e2
.i\'i2
.i\'o2
.i\'u2
.ia2
.ie2
.ii2
.io2
.iu2
.o2
.o\'a2
.o\'e2
.o\'i2
.o\'o2
.o\'u2
.oa2
.oe2
.oi2
.oo2
.ou2
.u2
.u\'a2
.u\'e2
.u\'i2
.u\'o2
.u\'u2
.ua2
.ue2
.ui2
.uo2
.uu2
2\'a.
2\'aa.
2\'ae.
2\'ai.
2\'ao.
2\'au.
2\'e.
2\'ea.
2\'ee.
2\'ei.
2\'eo.
2\'eu.
2\'i.
2\'ia.
2\'ie.
2\'ii.
2\'io.
2\'iu.
2\'o.
2\'oa.
2\'oe.
2\'oi.
2\'oo.
2\'ou.
2\'u.
2\'ua.
2\'ue.
2\'ui.
2\'uo.
2\'uu.
2\~n1\~n
2\~n1b
2\~n1c
2\~n1d
2\~n1f
2\~n1g
2\~n1h
2\~n1j
2\~n1k
2\~n1m
2\~n1n
2\~n1p
2\~n1q
2\~n1s
2\~n1t
2\~n1v
2\~n1w
2\~n1x
2\~n1y
2\~n1z
2a.
2a\'a.
2a\'e.
2a\'i.
2a\'o.
2a\'u.
2aa.
2ae.
2ai.
2ao.
2au.
2b1\~n
2b1b
2b1c
2b1d
2b1f
2b1g
2b1h
2b1j
2b1k
2b1m
2b1n
2b1p
2b1q
2b1s
2b1t
2b1v
2b1w
2b1x
2b1y
2b1z
2c1\~n
2c1b
2c1c
2c1d
2c1f
2c1g
2c1j
2c1k
2c1m
2c1n
2c1p
2c1q
2c1s
2c1t
2c1v
2c1w
2c1x
2c1y
2c1z
2d1\~n
2d1b
2d1c
2d1d
2d1f
2d1g
2d1h
2d1j
2d1k
2d1m
2d1n
2d1p
2d1q
2d1s
2d1t
2d1v
2d1w
2d1x
2d1y
2d1z
2e.
2e\'a.
2e\'e.
2e\'i.
2e\'o.
2e\'u.
2ea.
2ee.
2ei.
2eo.
2eu.
2f1\~n
2f1b
2f1c
2f1d
2f1f
2f1g
2f1h
2f1j
2f1k
2f1m
2f1n
2f1p
2f1q
2f1s
2f1t
2f1v
2f1w
2f1x
2f1y
2f1z
2g1\~n
2g1b
2g1c
2g1d
2g1f
2g1g
2g1h
2g1j
2g1k
2g1m
2g1n
2g1p
2g1q
2g1s
2g1t
2g1v
2g1w
2g1x
2g1y
2g1z
2h1\~n
2h1b
2h1c
2h1d
2h1f
2h1g
2h1h
2h1j
2h1k
2h1m
2h1n
2h1p
2h1q
2h1s
2h1t
2h1v
2h1w
2h1x
2h1y
2h1z
2i.
2i\'a.
2i\'e.
2i\'i.
2i\'o.
2i\'u.
2ia.
2ie.
2ii.
2io.
2iu.
2j1\~n
2j1b
2j1c
2j1d
2j1f
2j1g
2j1h
2j1j
2j1k
2j1m
2j1n
2j1p
2j1q
2j1s
2j1t
2j1v
2j1w
2j1x
2j1y
2j1z
2k1\~n
2k1b
2k1c
2k1d
2k1f
2k1g
2k1h
2k1j
2k1k
2k1m
2k1n
2k1p
2k1q
2k1s
2k1t
2k1v
2k1w
2k1x
2k1y
2k1z
2l1\~n
2l1b
2l1c
2l1d
2l1f
2l1g
2l1h
2l1j
2l1k
2l1m
2l1n
2l1p
2l1q
2l1s
2l1t
2l1v
2l1w
2l1x
2l1y
2l1z
2m1\~n
2m1b
2m1c
2m1d
2m1f
2m1g
2m1h
2m1j
2m1k
2m1l
2m1m
2m1n
2m1p
2m1q
2m1r
2m1s
2m1t
2m1v
2m1w
2m1x
2m1y
2m1z
2n1\~n
2n1b
2n1c
2n1d
2n1f
2n1g
2n1h
2n1j
2n1k
2n1l
2n1m
2n1n
2n1p
2n1q
2n1r
2n1s
2n1t
2n1v
2n1w
2n1x
2n1y
2n1z
2o.
2o\'a.
2o\'e.
2o\'i.
2o\'o.
2o\'u.
2oa.
2oe.
2oi.
2oo.
2ou.
2p1\~n
2p1b
2p1c
2p1d
2p1f
2p1g
2p1h
2p1j
2p1k
2p1m
2p1n
2p1p
2p1q
2p1s
2p1t
2p1v
2p1w
2p1x
2p1y
2p1z
2q1\~n
2q1b
2q1c
2q1d
2q1f
2q1g
2q1h
2q1j
2q1k
2q1m
2q1n
2q1p
2q1q
2q1s
2q1t
2q1v
2q1w
2q1x
2q1y
2q1z
2r1\~n
2r1b
2r1c
2r1d
2r1f
2r1g
2r1h
2r1j
2r1k
2r1m
2r1n
2r1p
2r1q
2r1s
2r1t
2r1v
2r1w
2r1x
2r1y
2r1z
2s1\~n
2s1b
2s1c
2s1d
2s1f
2s1g
2s1h
2s1j
2s1k
2s1m
2s1n
2s1p
2s1q
2s1s
2s1t
2s1v
2s1w
2s1x
2s1y
2s1z
2t1\~n
2t1b
2t1c
2t1d
2t1f
2t1g
2t1h
2t1j
2t1k
2t1m
2t1n
2t1p
2t1q
2t1s
2t1t
2t1v
2t1w
2t1x
2t1y
2t1z
2u.
2u\'a.
2u\'e.
2u\'i.
2u\'o.
2u\'u.
2ua.
2ue.
2ui.
2uo.
2uu.
2v1\~n
2v1b
2v1c
2v1d
2v1f
2v1g
2v1h
2v1j
2v1k
2v1m
2v1n
2v1p
2v1q
2v1s
2v1t
2v1v
2v1w
2v1x
2v1y
2v1z
2w1\~n
2w1b
2w1c
2w1d
2w1f
2w1g
2w1h
2w1j
2w1k
2w1m
2w1n
2w1p
2w1q
2w1s
2w1t
2w1v
2w1w
2w1x
2w1y
2w1z
2x1\~n
2x1b
2x1c
2x1d
2x1f
2x1g
2x1h
2x1j
2x1k
2x1m
2x1n
2x1p
2x1q
2x1s
2x1t
2x1v
2x1w
2x1x
2x1y
2x1z
2y1\~n
2y1b
2y1c
2y1d
2y1f
2y1g
2y1h
2y1j
2y1k
2y1m
2y1n
2y1p
2y1q
2y1s
2y1t
2y1v
2y1w
2y1x
2y1y
2y1z
2z1\~n
2z1b
2z1c
2z1d
2z1f
2z1g
2z1h
2z1j
2z1k
2z1m
2z1n
2z1p
2z1q
2z1s
2z1t
2z1v
2z1w
2z1x
2z1y
2z1z
\'a1\'i
\'a1\'u
\'a1\~n
\'a1a
\'a1b
\'a1c
\'a1d
\'a1e
\'a1f
\'a1g
\'a1h
\'a1j
\'a1k
\'a1l
\'a1m
\'a1n
\'a1o
\'a1p
\'a1q
\'a1r
\'a1s
\'a1t
\'a1v
\'a1w
\'a1x
\'a1y
\'a1z
\'a2\~n.
\'a2b.
\'a2c.
\'a2d.
\'a2f.
\'a2g.
\'a2h.
\'a2j.
\'a2k.
\'a2l.
\'a2m.
\'a2n.
\'a2p.
\'a2q.
\'a2r.
\'a2s.
\'a2t.
\'a2v.
\'a2w.
\'a2x.
\'a2y.
\'a2z.
\'e1\'i
\'e1\'u
\'e1\~n
\'e1a
\'e1b
\'e1c
\'e1d
\'e1e
\'e1f
\'e1g
\'e1h
\'e1j
\'e1k
\'e1l
\'e1m
\'e1n
\'e1o
\'e1p
\'e1q
\'e1r
\'e1s
\'e1t
\'e1v
\'e1w
\'e1x
\'e1y
\'e1z
\'e2\~n.
\'e2b.
\'e2c.
\'e2d.
\'e2f.
\'e2g.
\'e2h.
\'e2j.
\'e2k.
\'e2l.
\'e2m.
\'e2n.
\'e2p.
\'e2q.
\'e2r.
\'e2s.
\'e2t.
\'e2v.
\'e2w.
\'e2x.
\'e2y.
\'e2z.
\'i1\'a
\'i1\'e
\'i1\'o
\'i1\~n
\'i1a
\'i1b
\'i1c
\'i1d
\'i1e
\'i1f
\'i1g
\'i1h
\'i1j
\'i1k
\'i1l
\'i1m
\'i1n
\'i1o
\'i1p
\'i1q
\'i1r
\'i1s
\'i1t
\'i1v
\'i1w
\'i1x
\'i1y
\'i1z
\'i2\~n.
\'i2b.
\'i2c.
\'i2d.
\'i2f.
\'i2g.
\'i2h.
\'i2j.
\'i2k.
\'i2l.
\'i2m.
\'i2n.
\'i2p.
\'i2q.
\'i2r.
\'i2s.
\'i2t.
\'i2v.
\'i2w.
\'i2x.
\'i2y.
\'i2z.
\'o1\'i
\'o1\'u
\'o1\~n
\'o1a
\'o1b
\'o1c
\'o1d
\'o1e
\'o1f
\'o1g
\'o1h
\'o1j
\'o1k
\'o1l
\'o1m
\'o1n
\'o1o
\'o1p
\'o1q
\'o1r
\'o1s
\'o1t
\'o1v
\'o1w
\'o1x
\'o1y
\'o1z
\'o2\~n.
\'o2b.
\'o2c.
\'o2d.
\'o2f.
\'o2g.
\'o2h.
\'o2j.
\'o2k.
\'o2l.
\'o2m.
\'o2n.
\'o2p.
\'o2q.
\'o2r.
\'o2s.
\'o2t.
\'o2v.
\'o2w.
\'o2x.
\'o2y.
\'o2z.
\'u1\'a
\'u1\'e
\'u1\'o
\'u1\~n
\'u1a
\'u1b
\'u1c
\'u1d
\'u1e
\'u1f
\'u1g
\'u1h
\'u1j
\'u1k
\'u1l
\'u1m
\'u1n
\'u1o
\'u1p
\'u1q
\'u1r
\'u1s
\'u1t
\'u1v
\'u1w
\'u1x
\'u1y
\'u1z
\'u2\~n.
\'u2b.
\'u2c.
\'u2d.
\'u2f.
\'u2g.
\'u2h.
\'u2j.
\'u2k.
\'u2l.
\'u2m.
\'u2n.
\'u2p.
\'u2q.
\'u2r.
\'u2s.
\'u2t.
\'u2v.
\'u2w.
\'u2x.
\'u2y.
\'u2z.
a1\'a
a1\'e
a1\'i
a1\'o
a1\'u
a1\~n
a1a
a1b
a1c
a1d
a1e
a1f
a1g
a1h
a1j
a1k
a1l
a1m
a1n
a1o
a1p
a1q
a1r
a1s
a1t
a1v
a1w
a1x
a1y
a1z
a2\~n.
a2b.
a2c.
a2d.
a2f.
a2g.
a2h.
a2j.
a2k.
a2l.
a2m.
a2n.
a2p.
a2q.
a2r.
a2s.
a2t.
a2v.
a2w.
a2x.
a2y.
a2z.
e1\'a
e1\'e
e1\'i
e1\'o
e1\'u
e1\~n
e1a
e1b
e1c
e1d
e1e
e1f
e1g
e1h
e1j
e1k
e1l
e1m
e1n
e1o
e1p
e1q
e1r
e1s
e1t
e1v
e1w
e1x
e1y
e1z
e2\~n.
e2b.
e2c.
e2d.
e2f.
e2g.
e2h.
e2j.
e2k.
e2l.
e2m.
e2n.
e2p.
e2q.
e2r.
e2s.
e2t.
e2v.
e2w.
e2x.
e2y.
e2z.
i1\~n
i1b
i1c
i1d
i1f
i1g
i1h
i1j
i1k
i1l
i1m
i1n
i1p
i1q
i1r
i1s
i1t
i1v
i1w
i1x
i1y
i1z
i2\~n.
i2b.
i2c.
i2d.
i2f.
i2g.
i2h.
i2j.
i2k.
i2l.
i2m.
i2n.
i2p.
i2q.
i2r.
i2s.
i2t.
i2v.
i2w.
i2x.
i2y.
i2z.
o1\'a
o1\'e
o1\'i
o1\'o
o1\'u
o1\~n
o1a
o1b
o1c
o1d
o1e
o1f
o1g
o1h
o1j
o1k
o1l
o1m
o1n
o1o
o1p
o1q
o1r
o1s
o1t
o1v
o1w
o1x
o1y
o1z
o2\~n.
o2b.
o2c.
o2d.
o2f.
o2g.
o2h.
o2j.
o2k.
o2l.
o2m.
o2n.
o2p.
o2q.
o2r.
o2s.
o2t.
o2v.
o2w.
o2x.
o2y.
o2z.
u1\~n
u1b
u1c
u1d
u1f
u1g
u1h
u1j
u1k
u1l
u1m
u1n
u1p
u1q
u1r
u1s
u1t
u1v
u1w
u1x
u1y
u1z
u2\~n.
u2b.
u2c.
u2d.
u2f.
u2g.
u2h.
u2j.
u2k.
u2l.
u2m.
u2n.
u2p.
u2q.
u2r.
u2s.
u2t.
u2v.
u2w.
u2x.
u2y.
u2z.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander.ehtml.

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

[section SYNOPSIS]

<pre>
    package require expander 1.0
</pre><p>

[section DESCRIPTION]

The Tcl "subst" command is often used to support a kind of template
processing.  Given a string with embedded variables or function calls,
"subst" will interpolate the variable and function values, returning
the new string:<p>

[listing]
[tclsh {set greeting "Howdy"}]
[tclsh {proc place {} {return "World"}}]
[tclsh {subst {$greeting, [place]!}}]
%
[/listing]

By defining a suitable set of Tcl commands, "subst" can be used to
implement a markup language similar to HTML.<p>

The "subst" command is efficient, but it has three drawbacks for this
kind of template processing:<p>

<ul>
  <li> There's no way to identify and process the plain text between two
       embedded Tcl commands; that makes it difficult to handle plain
       text in a context-sensitive way.<p>

  <li> Embedded commands are necessarily bracketed by "[lb]" and
       "[rb]"; it's convenient to be able to choose different brackets
       in special cases.  Someone producing web pages that include a
       large quantity of Tcl code examples might easily prefer to use
       "<<" and ">>" as the embedded code delimiters instead.<p>

  <li> There's no easy way to handle incremental input, as one might
       wish to do when reading data from a socket.<p>
</ul>

At present, expander solves the first two problems; eventually it will
solve the third problem as well.<p>

To begin, create an expander object:<p>

[listing]
[tclsh {package require textutil::expander}]
[tclsh {::textutil::expander myexp}]
%
[/listing]

The created "::myexp" object can be used to expand text strings containing
embedded Tcl commands.  By default, embedded commands are delimited by
square brackets.  Note that expander doesn't attempt to interpolate
variables, since variables can be referenced by embedded commands:<p>

[listing]
[tclsh {set greeting "Howdy"}]
[tclsh {proc place {} {return "World"}}]
[tclsh {::myexp expand {[set greeting], [place]!}}]
%
[/listing]

[subsection "Embedding Macros"]

An expander macro is simply a Tcl script embedded within a text
string.  Expander evaluates the script in the global context, and
replaces it with its result string.  For example,

[listing]
[tclsh {set greetings {Howdy Hi "What's up"}}]
[tclsh {::myexp expand {There are many ways to say "Hello, World!":
[set result {}
foreach greeting $greetings {
    append result "$greeting, World!\n"
}
set result]
And that's just a small sample!}}]
%
[/listing]

[subsection "Writing Macro Commands"]

More typically, "macro commands" are used to create a markup
language.  A macro command is just a Tcl command that returns an
output string.  For example, expand can be used to implement a generic
document markup language that can be retargeted to HTML or any other
output format:

[listing]
[tclsh {proc bold {} {return "<b>"}}]
[tclsh {proc /bold {} {return "</b>"}}]
[tclsh {::myexp expand {Some of this text is in [bold]boldface[/bold]}}]
%
[/listing]

The above definition of "bold" and "/bold" returns HTML, but such
commands can be as complicated as needed; they could, for example,
decide what to return based on the desired output format.<p>

[subsection "Changing the Expansion Brackets"]

By default, embedded macros are enclosed in square brackets,
"[lb]" and "[rb]".  If square brackets need to be included in the
output, the input can contain the [command lb] and [command rb]
commands.  Alternatively, or if square brackets are objectionable for
some other reason, the macro expansion brackets can be changed to any
pair of non-empty strings.<p>

The [command setbrackets] command changes the brackets permanently.
For example, you can write pseudo-html by change them to "<" and ">":<p>

[listing]
[tclsh {::myexp setbrackets < >}]
[tclsh {::myexp expand {<bold>This is boldface</bold>}}]
[/listing]

Alternatively, you can change the expansion brackets temporarily by
passing the desired brackets to the [command expand] command:<p>

[listing]
[tclsh {::myexp setbrackets "\[" "\]"}]
[tclsh {::myexp expand {<bold>This is boldface</bold>} {< >}}]
%
[/listing]

[subsection "Customized Macro Expansion"]

By default, macros are evaluated using the Tcl "uplevel #0" command, so
that the embedded code executes in the global context.  The
application can provide a different evaluation command using
[command evalcmd]; this allows the application to use a safe
interpreter, for example, or even to evaluated something other than
Tcl code.  There is one caveat: to be recognized as valid, a macro
must return 1 when passed to Tcl's "info complete" command.<p>

For example, the following code "evaluates" each macro by returning
the macro text itself.<p>

[listing]
proc identity {macro} {return $macro}
::myexp evalcmd identity
[/listing]

[subsection "Using the Context Stack"]

 Often it's desirable to define a pair of macros
which operate in some way on the plain text between them.  Consider a
set of macros for adding footnotes to a web page: one could
have implement something like this:<p>

[listing]
    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[lb]footnote "See Candide, by Voltaire"[rb]
[/listing]

The <code>footnote</code> macro would, presumably, assign a number to
this footnote and save the text to be formatted later on.  However,
this solution is ugly if the footnote text is long or should contain
additional markup.  Consider the following instead:<p>

[listing]
    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[lb]footnote[rb]See [lb]bookTitle "Candide"[rb], by
    [lb]authorsName "Voltaire"[rb], for more information.[lb]/footnote[rb]
[/listing]

Here the footnote text is contained between <code>footnote</code> and
<code>/footnote</code> macros, continues onto a second line, and
contains several macros of its own.  This is both clearer and more
flexible; however, with the features presented so far there's no easy
way to do it.  That's the purpose of the context stack.<p>

All macro expansion takes place in a particular context.
Here, the <code>footnote</code> macro pushes a new
context onto the context stack.  Then, all expanded text gets placed
in that new context.  <code>/footnote</code> retrieves it by popping
the context.  Here's a skeleton implementation of these two macros:<p>

[listing]
    proc footnote {} {
        ::myexp cpush footnote
    }

    proc /footnote {} {
        set footnoteText [lb]::myexp cpop footnote[rb]

        # Save the footnote text, and return an appropriate footnote
        # number and link.
    } 
[/listing]

The [command cpush] command pushes a new context onto the stack; the
argument is the context's name.  It can be any string, but would
typically be the name of the macro itself.  Then, [command cpop]
verifies that the current context has the expected name, pops it off
of the stack, and returns the accumulated text.<p>

Expand provides several other tools related to the context stack.
Suppose the first macro in a context pair takes arguments or computes
values which the second macro in the pair needs.  After calling
[command cpush], the first macro can define one or more context
variables; the second macro can retrieve their values any time before
calling [command cpop].  For example, suppose the document must
specify the footnote number explicitly:<p>

[listing]
    proc footnote {footnoteNumber} {
        ::myexp cpush footnote
        ::myexp csave num $footnoteNumber
        # Return an appropriate link
    }

    proc /footnote {} {
        set footnoteNumber [lb]::myexp cget num[rb]
        set footnoteText [lb]::myexp cpop footnote[rb]

        # Save the footnote text and its footnoteNumber for future
        # output.
    } 
[/listing]

At times, it might be desirable to define macros that are valid only
within a particular context pair; such macros should verify that they
are only called within the correct context using either
[command cis] or [command cname].<p>

[section "TCL COMMANDS"]

The package defines the following Tcl commands:<p>

<dl>
  <dt> [commanddef expander <i>name</i>]
  <dd> This command creates a new expander object;
       name is the name of the object, and becomes a new
       command.  By default, if the name isn't fully qualified, i.e.,
       if it doesn't completely specify the namespace in which to
       create the new command, the command is created in the caller's
       current namespace.<p>
</dl>

[section "EXPANDER OBJECT COMMANDS"]

Every expander object will accept the following
subcommands:<p>

<dl>
  <dt> [commanddef cappend <i>text</i>]
  <dd> Appends a string to the output in the current context.  This
       command should rarely be used by macros or application code.<p>
       
  <dt> [commanddef cget <i>varname</i>]
  <dd> Retrieves the value of variable <i>varname</i>, defined in the
       current context.<p>
       
  <dt> [commanddef cis <i>cname</i>]
  <dd> Determines whether or not the name of the current context
       is <i>cname</i>.<p>
       
  <dt> [commanddef cname]
  <dd> Returns the name of the current context.<p>
       
  <dt> [commanddef cpop <i>cname</i>]
  <dd> Pops a context from the context stack, returning all accumulated
       output in that context.  The context must be named <i>cname</i>, or
       an error results.<p>
       
  <dt> [commanddef cpush <i>cname</i>]
  <dd> Pushes a context named <i>cname</i> onto the context stack.
       The context must be popped by [command cpop] before expansion
       ends or an error results.<p>
       
  <dt> [commanddef cset <i>varname</i> <i>value</i>]
  <dd> Sets variable <i>varname</i> to <i>value</i> in the current context.<p>
       
  <dt> [commanddef cvar <i>varname</i>]
  <dd> Retrieves the internal variable name of context variable
       <i>varname</i>; this allows the variable to be passed to
       commands like <b>lappend</b>.<p>
       
  <dt> [commanddef errmode ?<i>newErrmode</i>?]
  <dd> Sets the macro expansion error mode to one of "nothing",
       "macro", "error", or "fail"; the default value is "fail".  The
       value determines what the expander does if an error is detected
       during expansion of a macro.<p>

       If the error mode is "fail", the error propagates normally and
       can be caught or ignored by the application.<p>

       If the error mode is "error", the macro expands into a detailed
       error message, and expansion continues.<p>

       If the error mode is "macro", the macro expands to itself; that
       is, it is passed along to the output unchanged.<p>

       If the error mode is "nothing", the macro expands to the empty
       string, and is effectively ignored.<p>

  <dt> [commanddef evalcmd ?<i>newEvalCmd</i>?]
  <dd> Returns the current evaluation command, which defaults to
       "uplevel #0".  If specified, <i>newEvalCmd</i> will be saved
       for future use and then returned; it must be a Tcl
       command expecting one additional argument: the macro to evaluate.<p>
       
  <dt> [commanddef expand <i>inputString</i> ?<i>brackets</i>?]
  <dd> Expands the input string, replacing embedded macros with their
       expanded values, and returns the expanded string.<p>

       If <i>brackets</i> is given, it must be a list of two strings;
       the items will be used as the left and right macro expansion
       bracket sequences for this expansion only.<p>
       
  <dt> [commanddef lb ?<i>newbracket</i>?]
  <dd> 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 <i>newbracket</i> is
       specified, it becomes the new bracket, and is returned.<p>
       
  <dt> [commanddef rb ?<i>newbracket</i>?]
  <dd> 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 <i>newbracket</i> is
       specified, it becomes the new bracket, and is returned.<p>
       
  <dt> [commanddef reset]
  <dd> Resets all expander settings to their initial values.  Unusual
       results are likely if this command is called from within a call
       to [command expand].<p>
       
  <dt> [commanddef setbrackets <i>lbrack</i> <i>rbrack</i>]
  <dd> Sets the left and right macro expansion brackets.  This command
       is for use as or within a macro, or to permanently change the
       bracket definitions.  By default, the brackets are "[lb]" and
       "[rb]", but any non-empty string can be used; for example,
       "<" and ">" or "(*" and "*)" or even "Hello," and "World!".<p>

  <dt> [commanddef textcmd ?<i>newTextCmd</i>?]
  <dd> Returns the current command for processing polain text, which
       defaults to the empty string, meaning <i>identity</i>. If
       specified, <i>newTextCmd</i> will be saved for future use and
       then returned; it must be a Tcl command expecting one
       additional argument: the text to process. The expander object
       will this command for all plain text it encounters, giving the
       user of the object the ability to process all plain text in
       some standard way before writing it to the output. The object
       expects that the command returns the processed plain text.<p>
       <b>Note</b> that the combination of <i>textcmd plaintext</i> is
       run through the <i>evalcmd</i> for the actual evaluation. In
       other words, the <i>textcmd</i> is treated as a special macro
       implicitly surrounding all plain text in the template.<p>
</dl>

[section "HISTORY"]

expander was written by William H. Duquette; it is a repackaging of
the central algorithm of the
[link http://www.wjduquette.com/expand "expand"] macro processing tool.<p>

[copyright 2001 "William H. Duquette"]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander.html.

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

<BODY>

<h1>expander</h1>

<h2><a name="synopsis">SYNOPSIS</a></h2>

<pre>
    package require expander 1.0
</pre><p>

<h2><a name="description">DESCRIPTION</a></h2>

The Tcl "subst" command is often used to support a kind of template
processing.  Given a string with embedded variables or function calls,
"subst" will interpolate the variable and function values, returning
the new string:<p>

<pre>% set greeting "Howdy"
Howdy
% proc place {} {return "World"}
% subst {$greeting, [place]!}
Howdy, World!
%</pre>

By defining a suitable set of Tcl commands, "subst" can be used to
implement a markup language similar to HTML.<p>

The "subst" command is efficient, but it has three drawbacks for this
kind of template processing:<p>

<ul>
  <li> There's no way to identify and process the plain text between two
       embedded Tcl commands; that makes it difficult to handle plain
       text in a context-sensitive way.<p>

  <li> Embedded commands are necessarily bracketed by "[" and
       "]"; it's convenient to be able to choose different brackets
       in special cases.  Someone producing web pages that include a
       large quantity of Tcl code examples might easily prefer to use
       "<<" and ">>" as the embedded code delimiters instead.<p>

  <li> There's no easy way to handle incremental input, as one might
       wish to do when reading data from a socket.<p>
</ul>

At present, expander solves the first two problems; eventually it will
solve the third problem as well.<p>

To begin, create an expander object:<p>

<pre>% package require textutil::expander
1.0
% ::textutil::expander myexp
::myexp
%</pre>

The created "::myexp" object can be used to expand text strings containing
embedded Tcl commands.  By default, embedded commands are delimited by
square brackets.  Note that expander doesn't attempt to interpolate
variables, since variables can be referenced by embedded commands:<p>

<pre>% set greeting "Howdy"
Howdy
% proc place {} {return "World"}
% ::myexp expand {[set greeting], [place]!}
Howdy, World!
%</pre>

<h3><a name="embedding_macros">Embedding Macros</a></h3>

An expander macro is simply a Tcl script embedded within a text
string.  Expander evaluates the script in the global context, and
replaces it with its result string.  For example,

<pre>% set greetings {Howdy Hi "What's up"}
Howdy Hi "What's up"
% ::myexp expand {There are many ways to say "Hello, World!":
[set result {}
foreach greeting $greetings {
    append result "$greeting, World!\n"
}
set result]
And that's just a small sample!}
There are many ways to say "Hello, World!":
Howdy, World!
Hi, World!
What's up, World!

And that's just a small sample!
%</pre>

<h3><a name="writing_macro_commands">Writing Macro Commands</a></h3>

More typically, "macro commands" are used to create a markup
language.  A macro command is just a Tcl command that returns an
output string.  For example, expand can be used to implement a generic
document markup language that can be retargeted to HTML or any other
output format:

<pre>% proc bold {} {return "&lt;b&gt;"}
% proc /bold {} {return "&lt;/b&gt;"}
% ::myexp expand {Some of this text is in [bold]boldface[/bold]}
Some of this text is in &lt;b&gt;boldface&lt;/b&gt;
%</pre>

The above definition of "bold" and "/bold" returns HTML, but such
commands can be as complicated as needed; they could, for example,
decide what to return based on the desired output format.<p>

<h3><a name="changing_the_expansion_brackets">Changing the Expansion Brackets</a></h3>

By default, embedded macros are enclosed in square brackets,
"[" and "]".  If square brackets need to be included in the
output, the input can contain the <code><a href="#lb">lb</a></code> and <code><a href="#rb">rb</a></code>
commands.  Alternatively, or if square brackets are objectionable for
some other reason, the macro expansion brackets can be changed to any
pair of non-empty strings.<p>

The <code><a href="#setbrackets">setbrackets</a></code> command changes the brackets permanently.
For example, you can write pseudo-html by change them to "<" and ">":<p>

<pre>% ::myexp setbrackets &lt; &gt;
% ::myexp expand {&lt;bold&gt;This is boldface&lt;/bold&gt;}
&lt;b&gt;This is boldface&lt;/b&gt;</pre>

Alternatively, you can change the expansion brackets temporarily by
passing the desired brackets to the <code><a href="#expand">expand</a></code> command:<p>

<pre>% ::myexp setbrackets "\[" "\]"
% ::myexp expand {&lt;bold&gt;This is boldface&lt;/bold&gt;} {&lt; &gt;}
&lt;b&gt;This is boldface&lt;/b&gt;
%</pre>

<h3><a name="customized_macro_expansion">Customized Macro Expansion</a></h3>

By default, macros are evaluated using the Tcl "uplevel #0" command, so
that the embedded code executes in the global context.  The
application can provide a different evaluation command using
<code><a href="#evalcmd">evalcmd</a></code>; this allows the application to use a safe
interpreter, for example, or even to evaluated something other than
Tcl code.  There is one caveat: to be recognized as valid, a macro
must return 1 when passed to Tcl's "info complete" command.<p>

For example, the following code "evaluates" each macro by returning
the macro text itself.<p>

<pre>proc identity {macro} {return $macro}
::myexp evalcmd identity</pre>

<h3><a name="using_the_context_stack">Using the Context Stack</a></h3>

 Often it's desirable to define a pair of macros
which operate in some way on the plain text between them.  Consider a
set of macros for adding footnotes to a web page: one could
have implement something like this:<p>

<pre>    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[footnote "See Candide, by Voltaire"]</pre>

The <code>footnote</code> macro would, presumably, assign a number to
this footnote and save the text to be formatted later on.  However,
this solution is ugly if the footnote text is long or should contain
additional markup.  Consider the following instead:<p>

<pre>    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[footnote]See [bookTitle "Candide"], by
    [authorsName "Voltaire"], for more information.[/footnote]</pre>

Here the footnote text is contained between <code>footnote</code> and
<code>/footnote</code> macros, continues onto a second line, and
contains several macros of its own.  This is both clearer and more
flexible; however, with the features presented so far there's no easy
way to do it.  That's the purpose of the context stack.<p>

All macro expansion takes place in a particular context.
Here, the <code>footnote</code> macro pushes a new
context onto the context stack.  Then, all expanded text gets placed
in that new context.  <code>/footnote</code> retrieves it by popping
the context.  Here's a skeleton implementation of these two macros:<p>

<pre>    proc footnote {} {
        ::myexp cpush footnote
    }

    proc /footnote {} {
        set footnoteText [::myexp cpop footnote]

        # Save the footnote text, and return an appropriate footnote
        # number and link.
    } </pre>

The <code><a href="#cpush">cpush</a></code> command pushes a new context onto the stack; the
argument is the context's name.  It can be any string, but would
typically be the name of the macro itself.  Then, <code><a href="#cpop">cpop</a></code>
verifies that the current context has the expected name, pops it off
of the stack, and returns the accumulated text.<p>

Expand provides several other tools related to the context stack.
Suppose the first macro in a context pair takes arguments or computes
values which the second macro in the pair needs.  After calling
<code><a href="#cpush">cpush</a></code>, the first macro can define one or more context
variables; the second macro can retrieve their values any time before
calling <code><a href="#cpop">cpop</a></code>.  For example, suppose the document must
specify the footnote number explicitly:<p>

<pre>    proc footnote {footnoteNumber} {
        ::myexp cpush footnote
        ::myexp csave num $footnoteNumber
        # Return an appropriate link
    }

    proc /footnote {} {
        set footnoteNumber [::myexp cget num]
        set footnoteText [::myexp cpop footnote]

        # Save the footnote text and its footnoteNumber for future
        # output.
    } </pre>

At times, it might be desirable to define macros that are valid only
within a particular context pair; such macros should verify that they
are only called within the correct context using either
<code><a href="#cis">cis</a></code> or <code><a href="#cname">cname</a></code>.<p>

<h2><a name="tcl_commands">TCL COMMANDS</a></h2>

The package defines the following Tcl commands:<p>

<dl>
  <dt> <code><a name="expander">expander <i>name</i></a></code>
  <dd> This command creates a new expander object;
       name is the name of the object, and becomes a new
       command.  By default, if the name isn't fully qualified, i.e.,
       if it doesn't completely specify the namespace in which to
       create the new command, the command is created in the caller's
       current namespace.<p>
</dl>

<h2><a name="expander_object_commands">EXPANDER OBJECT COMMANDS</a></h2>

Every expander object will accept the following
subcommands:<p>

<dl>
  <dt> <code><a name="cappend">cappend <i>text</i></a></code>
  <dd> Appends a string to the output in the current context.  This
       command should rarely be used by macros or application code.<p>
       
  <dt> <code><a name="cget">cget <i>varname</i></a></code>
  <dd> Retrieves the value of variable <i>varname</i>, defined in the
       current context.<p>
       
  <dt> <code><a name="cis">cis <i>cname</i></a></code>
  <dd> Determines whether or not the name of the current context
       is <i>cname</i>.<p>
       
  <dt> <code><a name="cname">cname</a></code>
  <dd> Returns the name of the current context.<p>
       
  <dt> <code><a name="cpop">cpop <i>cname</i></a></code>
  <dd> Pops a context from the context stack, returning all accumulated
       output in that context.  The context must be named <i>cname</i>, or
       an error results.<p>
       
  <dt> <code><a name="cpush">cpush <i>cname</i></a></code>
  <dd> Pushes a context named <i>cname</i> onto the context stack.
       The context must be popped by <code><a href="#cpop">cpop</a></code> before expansion
       ends or an error results.<p>
       
  <dt> <code><a name="cset">cset <i>varname</i> <i>value</i></a></code>
  <dd> Sets variable <i>varname</i> to <i>value</i> in the current context.<p>
       
  <dt> <code><a name="cvar">cvar <i>varname</i></a></code>
  <dd> Retrieves the internal variable name of context variable
       <i>varname</i>; this allows the variable to be passed to
       commands like <b>lappend</b>.<p>
       
  <dt> <code><a name="errmode">errmode ?<i>newErrmode</i>?</a></code>
  <dd> Sets the macro expansion error mode to one of "nothing",
       "macro", "error", or "fail"; the default value is "fail".  The
       value determines what the expander does if an error is detected
       during expansion of a macro.<p>

       If the error mode is "fail", the error propagates normally and
       can be caught or ignored by the application.<p>

       If the error mode is "error", the macro expands into a detailed
       error message, and expansion continues.<p>

       If the error mode is "macro", the macro expands to itself; that
       is, it is passed along to the output unchanged.<p>

       If the error mode is "nothing", the macro expands to the empty
       string, and is effectively ignored.<p>

  <dt> <code><a name="evalcmd">evalcmd ?<i>newEvalCmd</i>?</a></code>
  <dd> Returns the current evaluation command, which defaults to
       "uplevel #0".  If specified, <i>newEvalCmd</i> will be saved
       for future use and then returned; it must be a Tcl
       command expecting one additional argument: the macro to evaluate.<p>
       
  <dt> <code><a name="expand">expand <i>inputString</i> ?<i>brackets</i>?</a></code>
  <dd> Expands the input string, replacing embedded macros with their
       expanded values, and returns the expanded string.<p>

       If <i>brackets</i> is given, it must be a list of two strings;
       the items will be used as the left and right macro expansion
       bracket sequences for this expansion only.<p>
       
  <dt> <code><a name="lb">lb ?<i>newbracket</i>?</a></code>
  <dd> 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 <i>newbracket</i> is
       specified, it becomes the new bracket, and is returned.<p>
       
  <dt> <code><a name="rb">rb ?<i>newbracket</i>?</a></code>
  <dd> 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 <i>newbracket</i> is
       specified, it becomes the new bracket, and is returned.<p>
       
  <dt> <code><a name="reset">reset</a></code>
  <dd> Resets all expander settings to their initial values.  Unusual
       results are likely if this command is called from within a call
       to <code><a href="#expand">expand</a></code>.<p>
       
  <dt> <code><a name="setbrackets">setbrackets <i>lbrack</i> <i>rbrack</i></a></code>
  <dd> Sets the left and right macro expansion brackets.  This command
       is for use as or within a macro, or to permanently change the
       bracket definitions.  By default, the brackets are "[" and
       "]", but any non-empty string can be used; for example,
       "<" and ">" or "(*" and "*)" or even "Hello," and "World!".<p>

  <dt> <code><a name="textcmd">textcmd ?<i>newTextCmd</i>?]</a></code>
  <dd> Returns the current command for processing polain text, which
       defaults to the empty string, meaning <i>identity</i>. If
       specified, <i>newTextCmd</i> will be saved for future use and
       then returned; it must be a Tcl command expecting one
       additional argument: the text to process. The expander object
       will this command for all plain text it encounters, giving the
       user of the object the ability to process all plain text in
       some standard way before writing it to the output. The object
       expects that the command returns the processed plain text.<p>
       <b>Note</b> that the combination of <i>textcmd plaintext</i> is
       run through the <i>evalcmd</i> for the actual evaluation. In
       other words, the <i>textcmd</i> is treated as a special macro
       implicitly surrounding all plain text in the template.<p>
</dl>


<h2><a name="history">HISTORY</a></h2>

expander was written by William H. Duquette; it is a repackaging of
the central algorithm of the
<a href="http://www.wjduquette.com/expand">expand</a> macro processing tool.<p>


<p><hr><p>
Copyright &copy; 2001, by William H. Duquette.  All rights reserved.<p>


</body>
</html>
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander.man.

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


[para]

The Tcl [cmd subst] command is often used to support a kind of
template processing. Given a string with embedded variables or
function calls, [cmd subst] will interpolate the variable and function
values, returning the new string:

[para]

[example {
 % set greeting "Howdy"
 Howdy
 % proc place {} {return "World"}
 % subst {$greeting, [place]!}
 Howdy, World!
 %
}]

[para]

By defining a suitable set of Tcl commands, [cmd subst] can be used to
implement a markup language similar to HTML.

[para]

The [cmd subst] command is efficient, but it has three drawbacks for
this kind of template processing:

[list_begin bullet]

[bullet]

There's no way to identify and process the plain text between two
embedded Tcl commands; that makes it difficult to handle plain text in
a context-sensitive way.

[bullet]

Embedded commands are necessarily bracketed by [const [lb]] and
[const [rb]]; it's convenient to be able to choose different brackets
in special cases.  Someone producing web pages that include a large
quantity of Tcl code examples might easily prefer to use [const <<]
and [const >>] as the embedded code delimiters instead.

[bullet]

There's no easy way to handle incremental input, as one might wish to
do when reading data from a socket.

[list_end]

[para]

At present, expander solves the first two problems; eventually it will
solve the third problem as well.

[para]

The following section describes the command API to the expander; this
is followed by the tutorial sections, beginning at
[sectref {TUTORIAL: Basics}].

[section {EXPANDER API}]
[para]

The [package textutil::expander] package provides only one command,
described below. The rest of the section is taken by a description of
the methods for the expander objects created by this command.

[list_begin definitions]

[call [cmd ::textutil::expander] [arg expanderName]]

The command creates a new expander object with an associated Tcl
command whose name is [arg expanderName]. This command may be used to
invoke various operations on the graph. If the [arg expanderName] is
not fully qualified it is interpreted as relative to the current
namespace.  The command has the following general form:

[example_begin]
 [arg expanderName] option [opt [arg {arg arg ...}]]
[example_end]

[arg Option] and the [arg arg]s determine the exact behavior of the
command.

[list_end]

[para]

The following commands are possible for expander objects:

[list_begin definitions]


[call [arg expanderName] [method 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 [arg expanderName] [method cget] [arg varname]]

Retrieves the value of variable [arg varname], defined in the current
context.


[call [arg expanderName] [method cis] [arg cname]]

Determines whether or not the name of the current context is

[arg cname].


[call [arg expanderName] [method cname]]

Returns the name of the current context.


[call [arg expanderName] [method 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 [arg expanderName] [method ctopandclear]]

Returns the output currently captured in the topmost context and
clears that buffer. This is similar to a combination of [method cpop]
followed by [method cpush], except that internal state (brackets) is
preserved here.

[call [arg expanderName] [method 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 [arg expanderName] [method cset] [arg varname] [arg value]]

Sets variable [arg varname] to [arg value] in the current context.


[call [arg expanderName] [method cvar] [arg varname]]

Retrieves the internal variable name of context variable

[arg varname]; this allows the variable to be passed to commands like
[cmd lappend].


[call [arg expanderName] [method errmode] [arg newErrmode]]

Sets the macro expansion error mode to one of [const nothing],
[const macro], [const error], or [const fail]; the default value is
[const fail].  The value determines what the expander does if an
error is detected during expansion of a macro.

[list_begin bullet]
[bullet]

If the error mode is [const fail], the error propagates normally and
can be caught or ignored by the application.

[bullet]

If the error mode is [const error], the macro expands into a detailed
error message, and expansion continues.

[bullet]

If the error mode is [const macro], the macro expands to itself; that
is, it is passed along to the output unchanged.

[bullet]

If the error mode is [const nothing], the macro expands to the empty
string, and is effectively ignored.

[list_end]


[call [arg expanderName] [method evalcmd] [opt [arg newEvalCmd]]]

Returns the current evaluation command, which defaults to

[cmd {uplevel #0}].  If specified, [arg newEvalCmd] will be saved for
future use and then returned; it must be a Tcl command expecting one
additional argument: the macro to evaluate.


[call [arg expanderName] [method expand] [arg string] [opt [arg brackets]]]

Expands the input string, replacing embedded macros with their
expanded values, and returns the expanded string.

[nl]

If [arg brackets] is given, it must be a list of two strings; the
items will be used as the left and right macro expansion bracket
sequences for this expansion only.


[call [arg expanderName] [method 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 [arg expanderName] [method 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.


[call [arg expanderName] [method reset]]

Resets all expander settings to their initial values.  Unusual results
are likely if this command is called from within a call to

[method expand].


[call [arg expanderName] [method setbrackets] [arg {lbrack rbrack}]]

Sets the left and right macro expansion brackets.  This command is for
use as or within a macro, or to permanently change the bracket
definitions.  By default, the brackets are [const [lb]] and

[const [rb]], but any non-empty string can be used; for example,
[const <] and [const >] or [const (*] and [const *)] or even
[const Hello,] and [const World!].


[call [arg expanderName] [method textcmd] [opt [arg newTextCmd]]]

Returns the current command for processing plain text, which defaults
to the empty string, meaning [emph identity]. If specified,

[arg newTextCmd] will be saved for future use and then returned; it
must be a Tcl command expecting one additional argument: the text to
process. The expander object will this command for all plain text it
encounters, giving the user of the object the ability to process all
plain text in some standard way before writing it to the output. The
object expects that the command returns the processed plain text.

[nl]

[emph Note] that the combination of "[cmd textcmd] [arg plaintext]"
is run through the [arg evalcmd] for the actual evaluation. In other
words, the [arg textcmd] is treated as a special macro implicitly
surrounding all plain text in the template.

[list_end]

[section {TUTORIAL: Basics}]

[para]

To begin, create an expander object:

[para]

[example {
 % package require expander
 1.2
 % ::expander::expander myexp
 ::myexp
 %
}]

[para]

The created [cmd ::myexp] object can be used to expand text strings
containing embedded Tcl commands.  By default, embedded commands are
delimited by square brackets.  Note that expander doesn't attempt to
interpolate variables, since variables can be referenced by embedded
commands:

[para]

[example {
 % set greeting "Howdy"
 Howdy
 % proc place {} {return "World"}
 % ::myexp expand {[set greeting], [place]!}
 Howdy, World!
 %
}]

[para]

[section {TUTORIAL: Embedding Macros}]

[para]

An expander macro is simply a Tcl script embedded within a text
string.  Expander evaluates the script in the global context, and
replaces it with its result string.  For example,

[para]

[example {
 % set greetings {Howdy Hi "What's up"}
 Howdy Hi "What's up"
 % ::myexp expand {There are many ways to say "Hello, World!":
 [set result {}
 foreach greeting $greetings {
    append result "$greeting, World!\\n"
 }
 set result]
 And that's just a small sample!}
 There are many ways to say "Hello, World!":
 Howdy, World!
 Hi, World!
 What's up, World!

 And that's just a small sample!
 %
}]

[para]

[section {TUTORIAL: Writing Macro Commands}]

[para]

More typically, [emph {macro commands}] are used to create a markup
language.  A macro command is just a Tcl command that returns an
output string.  For example, expand can be used to implement a generic
document markup language that can be retargeted to HTML or any other
output format:

[para]

[example {
 % proc bold {} {return "<b>"}
 % proc /bold {} {return "</b>"}
 % ::myexp expand {Some of this text is in [bold]boldface[/bold]}
 Some of this text is in <b>boldface</b>
 %
}]

[para]

The above definitions of [cmd bold] and [cmd /bold] returns HTML, but
such commands can be as complicated as needed; they could, for
example, decide what to return based on the desired output format.

[para]

[section {TUTORIAL: Changing the Expansion Brackets}]

[para]

By default, embedded macros are enclosed in square brackets,

[const [lb]] and [const [rb]].  If square brackets need to be
included in the output, the input can contain the [cmd lb] and

[cmd rb] commands.  Alternatively, or if square brackets are
objectionable for some other reason, the macro expansion brackets can
be changed to any pair of non-empty strings.

[para]

The [method setbrackets] command changes the brackets permanently.
For example, you can write pseudo-html by change them to [const <]
and [const >]:

[para]

[example {
 % ::myexp setbrackets < >
 % ::myexp expand {<bold>This is boldface</bold>}
 <b>This is boldface</b>
}]

[para]

Alternatively, you can change the expansion brackets temporarily by
passing the desired brackets to the [method expand] command:

[para]

[example {
 % ::myexp setbrackets "\\[" "\\]"
 % ::myexp expand {<bold>This is boldface</bold>} {< >}
 <b>This is boldface</b>
 %
}]

[para]

[section {TUTORIAL: Customized Macro Expansion}]

[para]

By default, macros are evaluated using the Tcl [cmd {uplevel #0}]
command, so that the embedded code executes in the global context.
The application can provide a different evaluation command using
[method evalcmd]; this allows the application to use a safe
interpreter, for example, or even to evaluated something other than
Tcl code.  There is one caveat: to be recognized as valid, a macro
must return 1 when passed to Tcl's "info complete" command.

[para]

For example, the following code "evaluates" each macro by returning
the macro text itself.

[para]

[example {
    proc identity {macro} {return $macro}
    ::myexp evalcmd identity
}]

[para]

[section {TUTORIAL: Using the Context Stack}]

[para]

Often it's desirable to define a pair of macros which operate in some
way on the plain text between them.  Consider a set of macros for
adding footnotes to a web page: one could have implement something
like this:

[para]

[example {
    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[footnote "See Candide, by Voltaire"]
}]

[para]

The [cmd footnote] macro would, presumably, assign a number to this
footnote and save the text to be formatted later on.  However, this
solution is ugly if the footnote text is long or should contain
additional markup.  Consider the following instead:

[para]

[example {
    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[footnote]See [bookTitle "Candide"], by
    [authorsName "Voltaire"], for more information.[/footnote]
}]

[para]

Here the footnote text is contained between [cmd footnote] and
[cmd /footnote] macros, continues onto a second line, and contains
several macros of its own.  This is both clearer and more flexible;
however, with the features presented so far there's no easy way to do
it.  That's the purpose of the context stack.

[para]

All macro expansion takes place in a particular context.  Here, the
[cmd footnote] macro pushes a new context onto the context stack.
Then, all expanded text gets placed in that new context.

[cmd /footnote] retrieves it by popping the context.  Here's a
skeleton implementation of these two macros:

[para]

[example {
    proc footnote {} {
        ::myexp cpush footnote
    }

    proc /footnote {} {
        set footnoteText [::myexp cpop footnote]

        # Save the footnote text, and return an appropriate footnote
        # number and link.
    }
}]

[para]

The [method cpush] command pushes a new context onto the stack; the
argument is the context's name.  It can be any string, but would
typically be the name of the macro itself.  Then, [method cpop]
verifies that the current context has the expected name, pops it off
of the stack, and returns the accumulated text.

[para]

Expand provides several other tools related to the context stack.
Suppose the first macro in a context pair takes arguments or computes
values which the second macro in the pair needs.  After calling
[method cpush], the first macro can define one or more context
variables; the second macro can retrieve their values any time before
calling [method cpop].  For example, suppose the document must specify
the footnote number explicitly:

[para]

[example {
    proc footnote {footnoteNumber} {
        ::myexp cpush footnote
        ::myexp csave num $footnoteNumber
        # Return an appropriate link
    }

    proc /footnote {} {
        set footnoteNumber [::myexp cget num]
        set footnoteText [::myexp cpop footnote]

        # Save the footnote text and its footnoteNumber for future
        # output.
    }
}]

[para]

At times, it might be desirable to define macros that are valid only
within a particular context pair; such macros should verify that they
are only called within the correct context using either [method cis]
or [method cname].

[section HISTORY]

[cmd expander] was written by William H. Duquette; it is a repackaging
of the central algorithm of the expand macro processing tool.

[see_also regexp split string [uri http://www.wjduquette.com/expand]]
[keywords string {template processing} {text expansion}]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
'\"
'\" Copyright (c) 1998-2000 by nobody :-)
'\" All rights not reserved.
'\" 
'\" RCS: @(#) $Id: expander.n,v 1.5 2002/02/15 05:35:30 andreas_kupries Exp $
'\" 
.so man.macros
.TH expander n 1.0.1 Textutil "Text expansion and template processing"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
textutil::expander \- Procedures to process templates and expand text.
.SH SYNOPSIS
.nf
\fBpackage require Tcl 8.2\fR
\fBpackage require textutil::expander ?1.0.1?\fR
.sp
\fB::textutil::expander\fR \fIexpanderName\fR
.fi
.BE
.SH DESCRIPTION
.PP
The Tcl \fBsubst\fR command is often used to support a kind of
template processing. Given a string with embedded variables or
function calls, \fBsubst\fR will interpolate the variable and function
values, returning the new string:
.PP
.CS
 % set greeting "Howdy"
 Howdy
 % proc place {} {return "World"}
 % subst {$greeting, [place]!}
 Howdy, World!
 %
.CE
.PP
By defining a suitable set of Tcl commands, \fBsubst\fR can be used to
implement a markup language similar to HTML.
.sp
The \fBsubst\fR command is efficient, but it has three drawbacks for
this kind of template processing:
.IP \(bu
There's no way to identify and process the plain text between two
embedded Tcl commands; that makes it difficult to handle plain text in
a context-sensitive way.
.IP \(bu
Embedded commands are necessarily bracketed by \fB[\fR and \fB]\fR;
it's convenient to be able to choose different brackets in special
cases.  Someone producing web pages that include a large quantity of
Tcl code examples might easily prefer to use \fB<<\fR and \fB>>\fR as
the embedded code delimiters instead.
.IP \(bu
There's no easy way to handle incremental input, as one might wish to
do when reading data from a socket.

.PP
At present, expander solves the first two problems; eventually it will
solve the third problem as well.

The following section describes the command API to the expander; this
is followed by tutorial section.

.SH "EXPANDER API"
.PP
The \fBtextutil::expander\fR package provides only one command,
described below. The rest of the section is taken by a description of
the methods for the exapnder objects created by this command.
.TP
\fB::textutil::expander\fR \fIexpanderName\fR
The \fB::textutil::expander\fR command creates a new expander object
with an associated Tcl command whose name is \fIexpanderName\fR. This
command may be used to invoke various operations on the graph. If the
\fIexpanderName\fR is not fully qualified it is interpreted as
relative to the current namespace.  The command has the following
general form:
.CS
\fIexpanderName option \fR?\fIarg arg ...\fR?
.CE
\fIOption\fR and the \fIarg\fRs determine the exact behavior of the
command.
.PP
The following commands are possible for expander objects:
.TP
\fIexpanderName\fR \fBcappend\fR \fItext\fR
Appends a string to the output in the current context.  This command
should rarely be used by macros or application code.
.TP
\fIexpanderName\fR \fBcget\fR \fIvarname\fR
Retrieves the value of variable \fIvarname\fR, defined in the current
context.
.TP
\fIexpanderName\fR \fBcis\fR \fIcname\fR
Determines whether or not the name of the current context is
\fIcname\fR.
.TP
\fIexpanderName\fR \fBcname\fR
Returns the name of the current context.
.TP
\fIexpanderName\fR \fBcpop\fR \fIcname\fR
Pops a context from the context stack, returning all accumulated
output in that context.  The context must be named \fIcname\fR, or an
error results.
.TP
\fIexpanderName\fR \fBcpush\fR \fIcname\fR
Pushes a context named \fIcname\fR onto the context stack.  The
context must be popped by \fBcpop\fR before expansion ends or an error
results.
.TP
\fIexpanderName\fR \fBcset\fR \fIvarname\fR
Sets variable \fIvarname\fR to \fIvalue\fR in the current context.
.TP
\fIexpanderName\fR \fBcvar\fR \fIvarname\fR
Retrieves the internal variable name of context variable
\fIvarname\fR; this allows the variable to be passed to commands like
\fBlappend\fR.
.TP
\fIexpanderName\fR \fBerrmode\fR \fInewErrmode\fR
Sets the macro expansion error mode to one of \fBnothing\fR,
\fBmacro\fR, \fBerror\fR, or \fBfail\fR; the default value is
\fBfail\fR.  The value determines what the expander does if an error
is detected during expansion of a macro.
.RS
.IP \(bu
If the error mode is \fBfail\fR, the error propagates normally and can
be caught or ignored by the application.
.IP \(bu
If the error mode is \fBerror\fR, the macro expands into a detailed
error message, and expansion continues.
.IP \(bu
If the error mode is \fBmacro\fR, the macro expands to itself; that
is, it is passed along to the output unchanged.
.IP \(bu
If the error mode is \fBnothing\fR, the macro expands to the empty
string, and is effectively ignored.
.RE
.TP
\fIexpanderName\fR \fBevalcmd\fR ?\fInewEvalCmd\fR?
Returns the current evaluation command, which defaults to "uplevel
#0".  If specified, \fInewEvalCmd\fR will be saved for future use and
then returned; it must be a Tcl command expecting one additional
argument: the macro to evaluate.
.TP
\fIexpanderName\fR \fBexpand\fR \fIstring\fR ?\fIbrackets\fR?
Expands the input string, replacing embedded macros with their
expanded values, and returns the expanded string.
.sp
If \fIbrackets\fR is given, it must be a list of two strings; the
items will be used as the left and right macro expansion bracket
sequences for this expansion only.
.TP
\fIexpanderName\fR \fBlb\fR ?\fInewbracket\fR?
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 \fInewbracket\fR is specified, it becomes the
new bracket, and is returned.
.TP
\fIexpanderName\fR \fBrb\fR ?\fInewbracket\fR?
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 \fInewbracket\fR is specified, it becomes the
new bracket, and is returned.
.TP
\fIexpanderName\fR \fBreset\fR
Resets all expander settings to their initial values.  Unusual results
are likely if this command is called from within a call to
\fBexpand\fR.
.TP
\fIexpanderName\fR \fBsetbrackets\fR \fIlbrack rbrack\fR
Sets the left and right macro expansion brackets.  This command is for
use as or within a macro, or to permanently change the bracket
definitions.  By default, the brackets are \fB[\fR and \fB]\fR, but
any non-empty string can be used; for example, \fB<\fR and \fB>\fR or
\fB(*\fR and \fB*)\fR or even \fBHello,\fR and \fBWorld!\fR.
.TP
\fIexpanderName\fR \fBtextcmd\fR ?\fInewTxtCmd\fR?
Returns the current command for processing polain text, which defaults
to the empty string, meaning \fIidentity\fR. If specified,
\fInewTextCmd\fR will be saved for future use and then returned; it
must be a Tcl command expecting one additional argument: the text to
process. The expander object will this command for all plain text it
encounters, giving the user of the object the ability to process all
plain text in some standard way before writing it to the output. The
object expects that the command returns the processed plain text.
.sp
\fBNote\fR that the combination of \fItextcmd plaintext\fR is run through
the \fIevalcmd\fR for the actual evaluation. In other words, the
\fItextcmd\fR is treated as a special macro implicitly surrounding all
plain text in the template.
.SH TUTORIAL
.PP
To begin, create an expander object:
.PP
.CS
 % package require expander
 1.0
 % ::expander::expander myexp
 ::myexp
 %
.CE
.PP
The created \fB::myexp\fR object can be used to expand text strings
containing embedded Tcl commands.  By default, embedded commands are
delimited by square brackets.  Note that expander doesn't attempt to
interpolate variables, since variables can be referenced by embedded
commands:
.PP
.CS
 % set greeting "Howdy"
 Howdy
 % proc place {} {return "World"}
 % ::myexp expand {[set greeting], [place]!}
 Howdy, World!
 %
.CE
.PP
\fBEmbedding Macros\fR
.PP
An expander macro is simply a Tcl script embedded within a text
string.  Expander evaluates the script in the global context, and
replaces it with its result string.  For example,
.PP
.CS
 % set greetings {Howdy Hi "What's up"}
 Howdy Hi "What's up"
 % ::myexp expand {There are many ways to say "Hello, World!":
 [set result {}
 foreach greeting $greetings {
    append result "$greeting, World!\\n"
 }
 set result]
 And that's just a small sample!}
 There are many ways to say "Hello, World!":
 Howdy, World!
 Hi, World!
 What's up, World!

 And that's just a small sample!
 %
.CE
.PP
\fBWriting Macro Commands\fR
.PP
More typically, \fImacro commands\fR are used to create a markup
language.  A macro command is just a Tcl command that returns an
output string.  For example, expand can be used to implement a generic
document markup language that can be retargeted to HTML or any other
output format:
.PP
.CS
 % proc bold {} {return "<b>"}
 % proc /bold {} {return "</b>"}
 % ::myexp expand {Some of this text is in [bold]boldface[/bold]}
 Some of this text is in <b&>boldface</b>
 %
.CE
.PP
The above definitions of \fBbold\fR and \fB/bold\fR returns HTML, but
such commands can be as complicated as needed; they could, for
example, decide what to return based on the desired output format.
.PP
\fBChanging the Expansion Brackets\fR
.PP
By default, embedded macros are enclosed in square brackets, \fB[\fR
and \fB]\fR.  If square brackets need to be included in the output,
the input can contain the \fBlb\fR and \fBrb\fR commands.
Alternatively, or if square brackets are objectionable for some other
reason, the macro expansion brackets can be changed to any pair of
non-empty strings.
.PP
The \fBsetbrackets\fR command changes the brackets permanently.  For
example, you can write pseudo-html by change them to \fB<\fR and
\fB>\fR:
.PP
.CS
 % ::myexp setbrackets < >
 % ::myexp expand {<bold>This is boldface</bold>}
 <b>This is boldface</b>
.CE
.PP
Alternatively, you can change the expansion brackets temporarily by
passing the desired brackets to the \fBexpand\fR command:
.PP
.CS
 % ::myexp setbrackets "\\[" "\\]"
 % ::myexp expand {<bold>This is boldface</bold>} {< >}
 <b>This is boldface</b>
 %
.CE
.PP
\fBCustomized Macro Expansion\fR
.PP
By default, macros are evaluated using the Tcl "uplevel #0" command,
so that the embedded code executes in the global context.  The
application can provide a different evaluation command using
\fBevalcmd\fR; this allows the application to use a safe interpreter,
for example, or even to evaluated something other than Tcl code.
There is one caveat: to be recognized as valid, a macro must return 1
when passed to Tcl's "info complete" command.
.PP
For example, the following code "evaluates" each macro by returning
the macro text itself.
.PP
.CS
    proc identity {macro} {return $macro}
    ::myexp evalcmd identity
.CE
.PP
\fBUsing the Context Stack\fR
.PP
Often it's desirable to define a pair of macros which operate in some
way on the plain text between them.  Consider a set of macros for
adding footnotes to a web page: one could have implement something
like this:
.PP
.CS
    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[footnote "See Candide, by Voltaire"]
.CE
.PP
The \fBfootnote\fR macro would, presumably, assign a number to this
footnote and save the text to be formatted later on.  However, this
solution is ugly if the footnote text is long or should contain
additional markup.  Consider the following instead:
.PP
.CS
    Dr. Pangloss, however, thinks that this is the best of all
    possible worlds.[footnote]See [bookTitle "Candide"], by
    [authorsName "Voltaire"], for more information.[/footnote]
.CE
.PP
Here the footnote text is contained between \fBfootnote\fR and
\fB/footnote\fR macros, continues onto a second line, and contains
several macros of its own.  This is both clearer and more flexible;
however, with the features presented so far there's no easy way to do
it.  That's the purpose of the context stack.
.PP
All macro expansion takes place in a particular context.  Here, the
\fBfootnote\fR macro pushes a new context onto the context stack.
Then, all expanded text gets placed in that new context.
\fB/footnote\fR retrieves it by popping the context.  Here's a
skeleton implementation of these two macros:
.PP
.CS
    proc footnote {} {
        ::myexp cpush footnote
    }

    proc /footnote {} {
        set footnoteText [::myexp cpop footnote]

        # Save the footnote text, and return an appropriate footnote
        # number and link.
    }
.CE
.PP
The \fBcpush\fR command pushes a new context onto the stack; the
argument is the context's name.  It can be any string, but would
typically be the name of the macro itself.  Then, \fBcpop\fR verifies
that the current context has the expected name, pops it off of the
stack, and returns the accumulated text.
.PP
Expand provides several other tools related to the context stack.
Suppose the first macro in a context pair takes arguments or computes
values which the second macro in the pair needs.  After calling
\fBcpush\fR, the first macro can define one or more context variables;
the second macro can retrieve their values any time before calling
\fBcpop\fR.  For example, suppose the document must specify the
footnote number explicitly:
.PP
.CS
    proc footnote {footnoteNumber} {
        ::myexp cpush footnote
        ::myexp csave num $footnoteNumber
        # Return an appropriate link
    }

    proc /footnote {} {
        set footnoteNumber [::myexp cget num]
        set footnoteText [::myexp cpop footnote]

        # Save the footnote text and its footnoteNumber for future
        # output.
    }
.CE
.PP
At times, it might be desirable to define macros that are valid only
within a particular context pair; such macros should verify that they
are only called within the correct context using either \fBcis\fR or
\fBcname\fR.

.SH HISTORY
.PP
\fBexpander\fR was written by William H. Duquette; it is a repackaging
of the central algorithm of the expand macro processing tool.

.SH "SEE ALSO"
regexp, split, string, http://www.wjduquette.com/expand

.SH KEYWORDS
string, template processing, text expansion
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
#---------------------------------------------------------------------
# TITLE:
#	expander.tcl
#
# AUTHOR:
#	Will Duquette
#
# DESCRIPTION:
#
# An expander is an object that takes as input text with embedded
# Tcl code and returns text with the embedded code expanded.  The
# text can be provided all at once or incrementally.
#
# See  expander.[e]html for usage info.
# Also expander.n
#
# LICENSE:
#       Copyright (C) 2001 by William H. Duquette.  See expander_license.txt,
#       distributed with this file, for license information.
#
# CHANGE LOG:
#
#       10/31/01: V0.9 code is complete.
#       11/23/01: Added "evalcmd"; V1.0 code is complete.

# Provide the package.

# Create the package's namespace.

namespace eval ::textutil {
    namespace eval expander {
	# All indices are prefixed by "$exp-".
	#
	# lb		    The left bracket sequence
	# rb		    The right bracket sequence
	# errmode	    How to handle macro errors: 
	#		    nothing, macro, error, fail.
        # evalcmd           The evaluation command.
	# textcmd           The plain text processing command.
	# level		    The context level
	# output-$level     The accumulated text at this context level.
	# name-$level       The tag name of this context level
	# data-$level-$var  A variable of this context level     
	
	variable Info
    
	# In methods, the current object:
	variable This ""
	
	# Export public commands
	namespace export expander
    }

    #namespace import expander::*
    namespace export expander

    proc expander {name} {uplevel ::textutil::expander::expander [list $name]}
}

#---------------------------------------------------------------------
# FUNCTION:
# 	expander name
#
# INPUTS:
#	name		A proc name for the new object.  If not
#                       fully-qualified, it is assumed to be relative
#                       to the caller's namespace.
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#	Creates a new expander object.

proc ::textutil::expander::expander {name} {
    variable Info

    # FIRST, qualify the name.
    if {![string match "::*" $name]} {
        # Get caller's namespace; append :: if not global namespace.
        set ns [uplevel 1 namespace current]
        if {"::" != $ns} {
            append ns "::"
        }
        
        set name "$ns$name"
    }

    # NEXT, Check the name
    if {"" != [info command $name]} {
        return -code error "command name \"$name\" already exists"
    }

    # NEXT, Create the object.
    proc $name {method args} [format {
        if {[catch {::textutil::expander::Methods %s $method $args} result]} {
            return -code error $result
        } else {
            return $result
        }
    } $name]

    # NEXT, Initialize the object
    Op_reset $name
    
    return $name
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Methods name method argList
#
# INPUTS:
#	name		The object's fully qualified procedure name.
#			This argument is provided by the object command
#			itself.
#	method		The method to call.
#	argList		Arguments for the specific method.
#
# RETURNS:
#	Depends on the method
#
# DESCRIPTION:
#	Handles all method dispatch for a expander object.
#       The expander's object command merely passes its arguments to
#	this function, which dispatches the arguments to the
#	appropriate method procedure.  If the method raises an error,
#	the method procedure's name in the error message is replaced
#	by the object and method names.

proc ::textutil::expander::Methods {name method argList} {
    variable Info
    variable This

    switch -exact -- $method {
        expand -
        lb -
        rb -
        setbrackets -
        errmode -
        evalcmd -
	textcmd -
        cpush -
	ctopandclear -
        cis -
        cname -
        cset -
        cget -
        cvar -
        cpop -
        cappend -
        reset {
            # FIRST, execute the method, first setting This to the object
            # name; then, after the method has been called, restore the
            # old object name.
            set oldThis $This
            set This $name

            set retval [catch "Op_$method $name $argList" result]

            set This $oldThis

            # NEXT, handle the result based on the retval.
            if {$retval} {
                regsub -- "Op_$method" $result "$name $method" result
                return -code error $result
            } else {
                return $result
            }
        }
        default {
            return -code error "\"$name $method\" is not defined"
        }
    }
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Get key
#
# INPUTS:
#	key		A key into the Info array, excluding the
#	                object name.  E.g., "lb"
#
# RETURNS:
#	The value from the array
#
# DESCRIPTION:
#	Gets the value of an entry from Info for This.

proc ::textutil::expander::Get {key} {
    variable Info
    variable This

    return $Info($This-$key)
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Set key value
#
# INPUTS:
#	key		A key into the Info array, excluding the
#	                object name.  E.g., "lb"
#
#	value		A Tcl value
#
# RETURNS:
#	The value
#
# DESCRIPTION:
#	Sets the value of an entry in Info for This.

proc ::textutil::expander::Set {key value} {
    variable Info
    variable This

    return [set Info($This-$key) $value]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Var key
#
# INPUTS:
#	key		A key into the Info array, excluding the
#	                object name.  E.g., "lb"
#
# RETURNS:
#	The full variable name, suitable for setting or lappending

proc ::textutil::expander::Var {key} {
    variable Info
    variable This

    return ::textutil::expander::Info($This-$key)
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Contains list value
#
# INPUTS:
#       list		any list
#	value		any value
#
# RETURNS:
#	TRUE if the list contains the value, and false otherwise.

proc ::textutil::expander::Contains {list value} {
    if {[lsearch -exact $list $value] == -1} {
        return 0
    } else {
        return 1
    }
}


#---------------------------------------------------------------------
# FUNCTION:
# 	Op_lb ?newbracket?
#
# INPUTS:
#	newbracket		If given, the new bracket token.
#
# RETURNS:
#	The current left bracket
#
# DESCRIPTION:
#	Returns the current left bracket token.

proc ::textutil::expander::Op_lb {name {newbracket ""}} {
    if {[string length $newbracket] != 0} {
        Set lb $newbracket
    }
    return [Get lb]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_rb ?newbracket?
#
# INPUTS:
#	newbracket		If given, the new bracket token.
#
# RETURNS:
#	The current left bracket
#
# DESCRIPTION:
#	Returns the current left bracket token.

proc ::textutil::expander::Op_rb {name {newbracket ""}} {
    if {[string length $newbracket] != 0} {
        Set rb $newbracket
    }
    return [Get rb]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_setbrackets lbrack rbrack
#
# INPUTS:
#	lbrack		The new left bracket
#	rbrack		The new right bracket
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#	Sets the brackets as a pair.

proc ::textutil::expander::Op_setbrackets {name lbrack rbrack} {
    Set lb $lbrack
    Set rb $rbrack
    return
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_errmode ?newErrmode?
#
# INPUTS:
#	newErrmode		If given, the new error mode.
#
# RETURNS:
#	The current error mode
#
# DESCRIPTION:
#	Returns the current error mode.

proc ::textutil::expander::Op_errmode {name {newErrmode ""}} {
    if {[string length $newErrmode] != 0} {
        if {![Contains "macro nothing error fail" $newErrmode]} {
            error "$name errmode: Invalid error mode: $newErrmode"
        }

        Set errmode $newErrmode
    }
    return [Get errmode]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_evalcmd ?newEvalCmd?
#
# INPUTS:
#	newEvalCmd		If given, the new eval command.
#
# RETURNS:
#	The current eval command
#
# DESCRIPTION:
#	Returns the current eval command.  This is the command used to
#	evaluate macros; it defaults to "uplevel #0".

proc ::textutil::expander::Op_evalcmd {name {newEvalCmd ""}} {
    if {[string length $newEvalCmd] != 0} {
        Set evalcmd $newEvalCmd
    }
    return [Get evalcmd]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_textcmd ?newTextCmd?
#
# INPUTS:
#	newTextCmd		If given, the new text command.
#
# RETURNS:
#	The current text command
#
# DESCRIPTION:
#	Returns the current text command.  This is the command used to
#	process plain text. It defaults to {}, meaning identity.

proc ::textutil::expander::Op_textcmd {name args} {
    switch -exact [llength $args] {
	0 {}
	1 {Set textcmd [lindex $args 0]}
	default {
	    return -code error "wrong#args for textcmd: name ?newTextcmd?"
	}
    }
    return [Get textcmd]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_reset
#
# INPUTS:
#	none
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#	Resets all object values, as though it were brand new.

proc ::textutil::expander::Op_reset {name} {
    variable Info 

    if {[info exists Info($name-lb)]} {
        array unset Info "$name-*"
    }

    set Info($name-lb) "\["
    set Info($name-rb) "\]"
    set Info($name-errmode) "fail"
    set Info($name-evalcmd) "uplevel #0"
    set Info($name-textcmd) ""
    set Info($name-level) 0
    set Info($name-output-0) ""
    set Info($name-name-0) ":0"

    return
}

#-------------------------------------------------------------------------
# Context: Every expansion takes place in its own context; however, 
# a macro can push a new context, causing the text it returns and all
# subsequent text to be saved separately.  Later, a matching macro can
# pop the context, acquiring all text saved since the first command,
# and use that in its own output.

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cpush cname
#
# INPUTS:
#	cname		The context name
#
# RETURNS:
#	nothing
#
# DESCRIPTION:
#       Pushes an empty macro context onto the stack.  All expanded text
#       will be added to this context until it is popped.

proc ::textutil::expander::Op_cpush {name cname} {
    # FRINK: nocheck
    incr [Var level]
    # FRINK: nocheck
    set [Var output-[Get level]] {}
    # FRINK: nocheck
    set [Var name-[Get level]] $cname
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cis cname
#
# INPUTS:
#	cname		A context name
#
# RETURNS:
#	true or false
#
# DESCRIPTION:
#       Returns true if the current context has the specified name, and
#	false otherwise.

proc ::textutil::expander::Op_cis {name cname} {
    return [expr {[string compare $cname [Op_cname $name]] == 0}]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cname
#
# INPUTS:
#	none
#
# RETURNS:
#	The context name
#
# DESCRIPTION:
#       Returns the name of the current context.

proc ::textutil::expander::Op_cname {name} {
    return [Get name-[Get level]]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cset varname value
#
# INPUTS:
#	varname		The name of a context variable
#	value		The new value for the context variable
#
# RETURNS:
#	The value
#
# DESCRIPTION:
#       Sets a variable in the current context.

proc ::textutil::expander::Op_cset {name varname value} {
    Set data-[Get level]-$varname $value
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cget varname
#
# INPUTS:
#	varname		The name of a context variable
#
# RETURNS:
#	The value
#
# DESCRIPTION:
#       Returns the value of a context variable.  It's an error if
#	the variable doesn't exist.

proc ::textutil::expander::Op_cget {name varname} {
    if {![info exists [Var data-[Get level]-$varname]]} {
        error "$name cget: $varname doesn't exist in this context ([Get level])"
    }
    return [Get data-[Get level]-$varname]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cvar varname
#
# INPUTS:
#	varname		The name of a context variable
#
# RETURNS:
#	The index to the variable
#
# DESCRIPTION:
#       Returns the index to a context variable, for use with set, 
#	lappend, etc.

proc ::textutil::expander::Op_cvar {name varname} {
    if {![info exists [Var data-[Get level]-$varname]]} {
        error "$name cvar: $varname doesn't exist in this context"
    }

    return [Var data-[Get level]-$varname]
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cpop cname
#
# INPUTS:
#	cname		The expected context name.
#
# RETURNS:
#	The accumulated output in this context
#
# DESCRIPTION:
#       Returns the accumulated output for the current context, first
#	popping the context from the stack.  The expected context name
#	must match the real name, or an error occurs.

proc ::textutil::expander::Op_cpop {name cname} {
    variable Info

    if {[Get level] == 0} {
        error "$name cpop underflow on '$cname'"
    }

    if {[string compare [Op_cname $name] $cname] != 0} {
        error "$name cpop context mismatch: expected [Op_cname $name], got $cname"
    }

    set result [Get output-[Get level]]
    # FRINK: nocheck
    set [Var output-[Get level]] ""
    # FRINK: nocheck
    set [Var name-[Get level]] ""

    array unset "Info data-[Get level]-*"

    # FRINK: nocheck
    incr [Var level] -1
    return $result
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_ctopandclear
#
# INPUTS:
#	None.
#
# RETURNS:
#	The accumulated output in the topmost context, clears the context,
#	but does not pop it.
#
# DESCRIPTION:
#       Returns the accumulated output for the current context, first
#	popping the context from the stack.  The expected context name
#	must match the real name, or an error occurs.

proc ::textutil::expander::Op_ctopandclear {name} {
    variable Info

    if {[Get level] == 0} {
        error "$name cpop underflow on '[Op_cname $name]'"
    }

    set result [Get output-[Get level]]
    Set output-[Get level] ""
    return $result
}

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_cappend text
#
# INPUTS:
#	text		Text to add to the output
#
# RETURNS:
#	The accumulated output
#
# DESCRIPTION:
#       Appends the text to the accumulated output in the current context.

proc ::textutil::expander::Op_cappend {name text} {
    # FRINK: nocheck
    append [Var output-[Get level]] $text
}

#-------------------------------------------------------------------------
# Macro-expansion:  The following code is the heart of the module.
# Given a text string, and the current variable settings, this code
# returns an expanded string, with all macros replaced.

#---------------------------------------------------------------------
# FUNCTION:
# 	Op_expand inputString ?brackets?
#
# INPUTS:
#	inputString		The text to expand.
#	brackets		A list of two bracket tokens.
#
# RETURNS:
#	The expanded text.
#
# DESCRIPTION:
#	Finds all embedded macros in the input string, and expands them.
#	If ?brackets? is given, it must be list of length 2, containing
#	replacement left and right macro brackets; otherwise the default
#	brackets are used.

proc ::textutil::expander::Op_expand {name inputString {brackets ""}} {

    # FIRST, push a new context onto the stack, and save the current
    # brackets.

    Op_cpush $name expand
    Op_cset $name lb [Get lb]
    Op_cset $name rb [Get rb]

    # SF Tcllib Bug #530056.
    set start_level [Get level] ; # remember this for check at end

    # NEXT, use the user's brackets, if given.
    if {[llength $brackets] == 2} {
        Set lb [lindex $brackets 0]
        Set rb [lindex $brackets 1]
    }

    # NEXT, loop over the string, finding and expanding macros.
    while {[string length $inputString] > 0} {
        set plainText [ExtractToToken inputString [Get lb] exclude]

        # FIRST, If there was plain text, append it to the output, and 
        # continue.
        if {$plainText != ""} {
	    set tc [Get textcmd]
	    if {[string length $tc] > 0} {
		lappend tc $plainText

		if {![catch "[Get evalcmd] [list $tc]" result]} {
		    set plainText $result
		} else {
		    HandleError $name {plain text} $tc $result
		}
	    }
            Op_cappend $name $plainText
            if {[string length $inputString] == 0} {
                break
            }
        }

        # NEXT, A macro is the next thing; process it.
        if {[catch "GetMacro inputString" macro]} {
            error "Error reading macro: $macro"
        }

        # Expand the macro, and output the result, or
        # handle an error.
        if {![catch "[Get evalcmd] [list $macro]" result]} {
            Op_cappend $name $result 
            continue
        } 

	HandleError $name macro $macro $result
    }

    # SF Tcllib Bug #530056.
    if {[Get level] > $start_level} {
	# The user macros pushed additional contexts, but forgot to
	# pop them all. The main work here is to place all the still
	# open contexts into the error message, and to produce
	# syntactically correct english.

	set c [list]
	set n [expr {[Get level] - $start_level}]
	if {$n == 1} {
	    set ctx  context
	    set verb was
	} else {
	    set ctx  contexts
	    set verb were
	}
	for {incr n -1} {$n >= 0} {incr n -1} {
	    lappend c [Get name-[expr {[Get level]-$n}]]
	}
	return -code error \
		"The following $ctx pushed by the macros $verb not popped: [join $c ,]."
    } elseif {[Get level] < $start_level} {
	set n [expr {$start_level - [Get level]}]
	if {$n == 1} {
	    set ctx  context
	} else {
	    set ctx  contexts
	}
	return -code error \
		"The macros popped $n more $ctx than they had pushed."
    }

    Op_lb $name [Op_cget $name lb]
    Op_rb $name [Op_cget $name rb]

    return [Op_cpop $name expand]
}

#---------------------------------------------------------------------
# FUNCTION
#	HandleError name title command errmsg
#
# INPUTS:
#	name		The name of the expander object in question.
#	title		A title text
#	command		The command which caused the error.
#	errmsg		The error message to report
#
# RETURNS:
#	Nothing
#
# DESCRIPTIONS
#	Is executed when an error in a macro or the plain text handler
#	occurs. Generates an error message according to the current
#	error mode.

proc ::textutil::expander::HandleError {name title command errmsg} {
    switch [Get errmode] {
	nothing { }
	macro { 
	    Op_cappend $name "[Get lb]$command[Get rb]" 
	}
	error {
	    Op_cappend $name "\n=================================\n"
	    Op_cappend $name "*** Error in $title:\n"
	    Op_cappend $name "*** [Get lb]$command[Get rb]\n--> $errmsg\n"
	    Op_cappend $name "=================================\n"
	}
	fail   { 
	    return -code error "Error in $title:\n[Get lb]$command[Get rb]\n--> $errmsg"
	}
	default {
	    return -code error "Unknown error mode: [Get errmode]"
	}
    }
}

#---------------------------------------------------------------------
# FUNCTION:
# 	ExtractToToken string token mode
#
# INPUTS:
#	string		The text to process.
#	token		The token to look for
#	mode		include or exclude
#
# RETURNS:
#	The extracted text
#
# DESCRIPTION:
# 	Extract text from a string, up to or including a particular
# 	token.  Remove the extracted text from the string.
# 	mode determines whether the found token is removed;
# 	it should be "include" or "exclude".  The string is
# 	modified in place, and the extracted text is returned.

proc ::textutil::expander::ExtractToToken {string token mode} {
    upvar $string theString

    # First, determine the offset
    switch $mode {
        include { set offset [expr {[string length $token] - 1}] }
        exclude { set offset -1 }
        default { error "::expander::ExtractToToken: unknown mode $mode" }
    }

    # Next, find the first occurrence of the token.
    set tokenPos [string first $token $theString]

    # Next, return the entire string if it wasn't found, or just
    # the part upto or including the character.
    if {$tokenPos == -1} {
        set theText $theString
        set theString ""
    } else {
        set newEnd    [expr {$tokenPos + $offset}]
        set newBegin  [expr {$newEnd + 1}]
        set theText   [string range $theString 0 $newEnd]
        set theString [string range $theString $newBegin end]
    }

    return $theText
}

#---------------------------------------------------------------------
# FUNCTION:
# 	GetMacro string
#
# INPUTS:
#	string		The text to process.
#
# RETURNS:
#	The macro, stripped of its brackets.
#
# DESCRIPTION:

proc ::textutil::expander::GetMacro {string} {
    upvar $string theString

    # FIRST, it's an error if the string doesn't begin with a
    # bracket.
    if {[string first [Get lb] $theString] != 0} {
        error "::expander::GetMacro: assertion failure, next text isn't a command! '$theString'"
    }

    # NEXT, extract a full macro
    set macro [ExtractToToken theString [Get lb] include]
    while {[string length $theString] > 0} {
        append macro [ExtractToToken theString [Get rb] include]

        # Verify that the command really ends with the [rb] characters,
        # whatever they are.  If not, break because of unexpected
        # end of file.
        if {![IsBracketed $macro]} {
            break;
        }

        set strippedMacro [StripBrackets $macro]

        if {[info complete "puts \[$strippedMacro\]"]} {
            return $strippedMacro
        }
    }

    if {[string length $macro] > 40} {
        set macro "[string range $macro 0 39]...\n"
    }
    error "Unexpected EOF in macro:\n$macro"
}

# Strip left and right bracket tokens from the ends of a macro,
# provided that it's properly bracketed.
proc ::textutil::expander::StripBrackets {macro} {
    set llen [string length [Get lb]]
    set rlen [string length [Get rb]]
    set tlen [string length $macro]

    return [string range $macro $llen [expr {$tlen - $rlen - 1}]]
}

# Return 1 if the macro is properly bracketed, and 0 otherwise.
proc ::textutil::expander::IsBracketed {macro} {
    set llen [string length [Get lb]]
    set rlen [string length [Get rb]]
    set tlen [string length $macro]

    set leftEnd  [string range $macro 0       [expr {$llen - 1}]]
    set rightEnd [string range $macro [expr {$tlen - $rlen}] end]

    if {$leftEnd != [Get lb]} {
        return 0
    } elseif {$rightEnd != [Get rb]} {
        return 0
    } else {
        return 1
    }
}

# Provide the package only if the code above was read and executed
# without error.

package provide textutil::expander 1.2
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander.test.

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


#---------------------------------------------------------------------
# Load the tcltest package

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

#---------------------------------------------------------------------
# Load the expander package

if { [ lsearch [ namespace children ] "::textutil::expander" ] == -1 } then {
    source [file join [file dirname [info script]] expander.tcl]
}

#---------------------------------------------------------------------
# Test cases 1.x: Expander Accessors

test expander-1.1 {initial expander settings} {} {
    catch {::textutil::expander exp}
    set result "[exp lb] [exp rb] [exp errmode]"
} {[ ] fail}

test expander-1.2 {setting/retrieving lbrack} {} {
    catch {::textutil::expander exp}
    set result "[exp lb FOO] [exp lb] [exp lb {[}]"
} {FOO FOO [}

test expander-1.3 {setting/retrieving rbrack} {} {
    catch {::textutil::expander exp}
    set result "[exp rb FOO] [exp rb] [exp rb {]}]"
} {FOO FOO ]}

test expander-1.4 {setting/retrieving errmode fail} {} {
    catch {::textutil::expander exp}
    list [exp errmode fail] [exp errmode]
} {fail fail}

test expander-1.5 {setting/retrieving errmode nothing} {} {
    catch {::textutil::expander exp}
    list [exp errmode nothing] [exp errmode]
} {nothing nothing}

test expander-1.6 {setting/retrieving errmode macro} {} {
    catch {::textutil::expander exp}
    list [exp errmode macro] [exp errmode]
} {macro macro}

test expander-1.7 {setting/retrieving errmode error} {} {
    catch {::textutil::expander exp}
    list [exp errmode error] [exp errmode]
} {error error}

test expander-1.8 {setting/retrieving errmode incorrectly} {} {
    catch {::textutil::expander exp}
    exp errmode nothing
    catch {exp errmode FOO} result
    list $result [exp errmode]
} {{::exp errmode: Invalid error mode: FOO} nothing}

test expander-1.9 {resetting the object} {} {
    catch {::textutil::expander exp}
    exp errmode macro
    exp lb FOO
    exp rb BAR
    exp reset
    set result "[exp lb] [exp rb] [exp errmode]"
} {[ ] fail}

#---------------------------------------------------------------------
# Test cases 2.x: The Context Stack

test expander-2.1 {initial context stack settings} {} {
    catch {::textutil::expander exp}
    exp reset
    list [exp cname] [exp cis [exp cname]]
} {:0 1}

test expander-2.2 {context stack underflow} {} {
    catch {::textutil::expander exp}
    exp reset
    catch {exp cpop FOO} result
    set result
} {::exp cpop underflow on 'FOO'}

test expander-2.3 {context push} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    list [exp cname] [exp cis [exp cname]]
} {FOO 1}

test expander-2.4 {cvar error} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    catch {exp cvar BAR} result
    set result
} {::exp cvar: BAR doesn't exist in this context}

test expander-2.5 {cget error} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    catch {exp cget BAR} result
    set result
} {::exp cget: BAR doesn't exist in this context (1)}

test expander-2.6 {cpop mismatch} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    catch {exp cpop BAR} result
    set result
} {::exp cpop context mismatch: expected FOO, got BAR}

test expander-2.7 {cpush, cappend, cpop} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    exp cappend "Hello, "
    exp cappend "World!"
    set result [exp cpop FOO]
    list $result [exp cname]
} {{Hello, World!} :0}

test expander-2.8 {two-stage cpush, cappend, cpop} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    exp cappend "Goodbye "
    exp cpush BAR
    exp cappend "Cruel "
    exp cappend [exp cpop BAR]
    exp cappend "World!"
    set result [exp cpop FOO]
    list $result [exp cname]
} {{Goodbye Cruel World!} :0}

test expander-2.9 {cset, cvar, cget} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush FOO
    exp cset BAR QUUX
    list [exp cget BAR] [set [exp cvar BAR]]
} {QUUX QUUX}

test expander-2.10 {two-stage cset, cvar, cget} {} {
    catch {::textutil::expander exp}
    exp reset
    exp cpush ONE
    exp cset FOO BAR
    exp cpush TWO
    exp cset FOO QUUX
    set v2 [exp cget FOO]
    exp cpop TWO
    set v1 [exp cget FOO]
    list $v1 $v2
} {BAR QUUX}

#---------------------------------------------------------------------
# Test cases 3.x: Successful Macro Expansion

proc howdy {} {return "Howdy"}

test expander-3.1 {expand the empty string} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand ""
} {}

test expander-3.2 {expand a string with no macros} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {Hello, world!}
} {Hello, world!}

test expander-3.3 {expand a string consisting of a macro} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {[howdy]}
} {Howdy}

test expander-3.3 {expand a string beginning with a macro} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {[howdy], world!}
} {Howdy, world!}

test expander-3.4 {expand a string ending with a macro} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {Well, [howdy]}
} {Well, Howdy}

test expander-3.5 {expand a string with macro in middle} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {Well, [howdy]!}
} {Well, Howdy!}

test expander-3.6 {expand macro with changed default brackets} {} {
    catch {::textutil::expander exp}
    exp reset
    exp lb "<<<"
    exp rb ">>>"
    exp expand {Well, <<<howdy>>>!}
} {Well, Howdy!}

test expander-3.7 {expand macro with changed user brackets} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {Well, <<<howdy>>>!} {<<< >>>}
} {Well, Howdy!}

test expander-3.8 {expand macro with changed user brackets} {} {
    catch {::textutil::expander exp}
    exp reset
    set a [exp expand {[howdy]}]
    set b [exp expand {Well, <<<howdy>>>!} {<<< >>>}]
    list $a $b
} {Howdy {Well, Howdy!}}

test expander-3.9 {macros change brackets} {} {
    catch {::textutil::expander exp}
    exp reset
    string trim [exp expand {
        Well, [howdy]!
        [exp setbrackets <<< >>>]
        Well, <<<howdy>>>!
        <<<exp setbrackets "\[" "\]">>>
        Well, [howdy]!
    }]
} {Well, Howdy!
        
        Well, Howdy!
        
        Well, Howdy!}

test expander-3.10 {brackets are restored correctly} {} {
    catch {::textutil::expander exp}
    exp reset
    list [exp expand {<howdy>} "< >"] [exp expand {[howdy]}]
} {Howdy Howdy}

test expander-3.11 {nested expansion: one expander} {} {
    catch {::textutil::expander exp}
    exp reset
    exp expand {[howdy] [exp expand {*[howdy]*}] [howdy]}
} {Howdy *Howdy* Howdy}

test expander-3.12 {nested expansion: two expanders} {} {
    catch {::textutil::expander exp}
    catch {::textutil::expander exp2}
    exp reset
    exp2 reset
    exp expand {[howdy] [exp2 expand {*[howdy]*}] [howdy]}
} {Howdy *Howdy* Howdy}

#---------------------------------------------------------------------
# Test cases 4.x: Failed Macro Expansion

test expander-4.1 {error mode fail} {} {
    catch {::textutil::expander exp}
    exp reset
    exp errmode fail
    catch {exp expand {+++[nop]+++}} result
    set result
} {Error in macro:
[nop]
--> invalid command name "nop"}

test expander-4.2 {error mode error} {} {
    catch {::textutil::expander exp}
    exp reset
    exp errmode error
    catch {exp expand {+++[nop]+++}} result
    set result
} {+++
=================================
*** Error in macro:
*** [nop]
--> invalid command name "nop"
=================================
+++}

test expander-4.3 {error mode macro} {} {
    catch {::textutil::expander exp}
    exp reset
    exp errmode macro
    catch {exp expand {+++[nop]+++}} result
    set result
} {+++[nop]+++}

test expander-4.4 {error mode nothing} {} {
    catch {::textutil::expander exp}
    exp reset
    exp errmode nothing
    catch {exp expand {+++[nop]+++}} result
    set result
} {++++++}

#---------------------------------------------------------------------
# Test cases 5.x: Replacing the evalcmd.

proc identity {macro} {
    return $macro
}

test expander-5.1 {new evalcmd} {} {
    catch {::textutil::expander exp}
    exp reset
    set oldcmd [exp evalcmd]
    exp evalcmd identity
    list $oldcmd [exp evalcmd] [exp expand {+++[Bogus Macro]+++}]
} {{uplevel #0} identity {+++Bogus Macro+++}}

#---------------------------------------------------------------------
# Test cases 5.x: Replacing the textcmd.

proc count {text} {
    return [string length $text]
}

test expander-6.1 {new evalcmd} {} {
    catch {::textutil::expander exp}
    exp reset
    set oldcmd [exp textcmd]
    exp textcmd count
    list $oldcmd [exp textcmd] [exp expand {++++++}]
} {{} count 6}

#---------------------------------------------------------------------
# Clean up

::tcltest::cleanupTests
return

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/expander_license.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
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. 
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































Deleted modules/textutil/expander_notes.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
expander notes:
o   expander.tcl is an objectified version of the expansion algorithm
    used in expand and Spinster.  Goals
    -   Multiple expanders can be used at one time
    -   Handling of batch or incremental input
    -   Support for user-settable brackets
    -   Support for context stack.
o   Next: add and test incremental expansion.

Things done: 11/23/2001
x   Added the evalcmd command; this allows the application to specify
    a different means of evaluating macros than the default "uplevel
    #0".

Things done: 11/3/2001
x   Added a couple of more tests for the nested expander problem I
    fixed the other day.
x   Finished the man page for the current version.
x   Time to zip it up and send it off to Andreas.

Things done: 10/31/2001
x   Updated the list of possible error modes to match the list in
    Expand 2.1
x   Added tests for each of the error modes to expander.test.
x   Created a modified version of Expand 2.1 that uses expander; it
    was able to process the Ex Libris website without error.
x   Found an error: if an expander is used to expand text which
    contains a call to another expander, the two get confused--because
    of the "::expander::This" variable.
    -   It works for the recordkeeper, because a recordkeeper method
        can never execute a method for a different recordkeeper.
    -   What if Methods saved the old This, and restored it at the
        end?
    -   Tried it; it works!  All existing tests pass.

Things done: 10/30/2001
x   Wrote more tests; found and fixed bracket restoration bug in expander.

Things done: 10/25/2001
x   Wrote tests for the lb, rb, and errmode commands.
x   Added the reset command.
x   Wrote tests for the reset command.
x   Added the context stack commands, and wrote tests for them.
    
Things done: 10/24/2001
x   Copied recordkeeper code and docs as a template.
x   Implemented the lb, rb, and errmode accessor methods.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































Deleted modules/textutil/ithyph.tex.

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

%%%%%%%%%%%%%%%%%%%% file ithyph.tex

%%%%%%%%%%%%%%%%%%%%%%%%%%%  file ithyph.tex  %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Prepared by Claudio Beccari   e-mail  [email protected]
%
%                                       Dipartimento di Elettronica
%                                       Politecnico di Torino
%                                       Corso Duca degli Abruzzi, 24
%                                       10129 TORINO
%
% Copyright  1998, 2001 Claudio Beccari
%
% This program can be redistributed and/or modified under the terms
% of the LaTeX Project Public License Distributed from CTAN
% archives in directory macros/latex/base/lppl.txt; either
% version 1 of the License, or any later version.
%
% \versionnumber{4.8d}   \versiondate{2001/11/21}
%
% These hyphenation patterns for the Italian language are supposed to comply
% with the Reccomendation UNI 6461 on hyphenation issued by the Italian
% Standards Institution (Ente Nazionale di Unificazione UNI).  No guarantee
% or declaration of fitness to any particular purpose is given and any
% liability is disclaimed.
%
% See comments and loading instructions at the end of the file after the
% \endinput line
%
{\lccode`\'=`\'      % Apostrophe has its own lccode so that it is treated
                     % as a letter
                     %>> 1998/04/14 inserted grouping
                     %
%\lccode23=23        % Compound word mark is a letter in encoding T1
%\def\W{^^W}         % ^^W =\char23 = \char"17 =\char'27
%
\patterns{
.a3p2n               % After the Garzanti dictionary: a-pnea, a-pnoi-co,...
.anti1  .anti3m2n
.bio1
.ca4p3s
.circu2m1
.di2s3cine
%.e2x
.fran2k3
.free3
.narco1
.opto1
.orto3p2
.para1
.poli3p2
.pre1
.p2s
%.ri1a2   .ri1e2    .re1i2  .ri1o2  .ri1u2
.sha2re3
.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t
.su2b3lu   .su2b3r
.wa2g3n
.wel2t1
a1ia a1ie  a1io  a1iu a1uo a1ya 2at.
e1iu e2w
o1ia o1ie  o1io  o1iu
%u1u
%
%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2
'2
1b   2bb   2bc   2bd  2bf  2bm  2bn  2bp  2bs  2bt  2bv
     b2l   b2r   2b.  2b'. 2b''
1c   2cb   2cc   2cd  2cf  2ck  2cm  2cn  2cq  2cs  2ct  2cz
     2chh  c2h   2chb ch2r 2chn c2l  c2r  2c.  2c'. 2c'' .c2
1d   2db   2dd   2dg  2dl  2dm  2dn  2dp  d2r  2ds  2dt  2dv  2dw
     2d.   2d'.  2d'' .d2
1f   2fb   2fg   2ff  2fn  f2l  f2r  2fs  2ft  2f.  2f'. 2f''
1g   2gb   2gd   2gf  2gg  g2h  g2l  2gm  g2n  2gp  g2r  2gs  2gt
     2gv   2gw   2gz  2gh2t     2g.  2g'. 2g''
1h   2hb   2hd   2hh  hi3p2n    h2l  2hm  2hn  2hr  2hv  2h.  2h'.  2h''
1j   2j.   2j'.  2j''
1k   2kg   2kf   k2h  2kk  k2l  2km  k2r  2ks  2kt  2k.  2k'. 2k''
1l   2lb   2lc   2ld  2l3f2     2lg  l2h  2lk  2ll  2lm  2ln  2lp
     2lq   2lr   2ls  2lt  2lv  2lw  2lz  2l.  2l'. 2l''
1m   2mb   2mc   2mf  2ml  2mm  2mn  2mp  2mq  2mr  2ms  2mt  2mv  2mw
     2m.   2m'.  2m''
1n   2nb   2nc   2nd  2nf  2ng  2nk  2nl  2nm  2nn  2np  2nq  2nr
     2ns   2nt   2nv  2nz  n2g3n     2nheit.   2n.  2n'  2n''
1p   2pd   p2h   p2l  2pn  3p2ne 2pp p2r  2ps  3p2sic 2pt  2pz  2p.  2p'. 2p''
1q   2qq   2q.   2q'. 2q''
1r   2rb   2rc   2rd  2rf  r2h  2rg  2rk  2rl  2rm  2rn  2rp
     2rq   2rr   2rs  2rt  rt2s3 2rv 2rx  2rw  2rz  2r.  2r'. 2r''
1s2  2shm  2s3s  s4s3m 2s3p2n   2stb 2stc 2std 2stf 2stg 2stm 2stn
     2stp  2sts  2stt 2stv 2sz  4s.  4s'. 4s''
1t   2tb   2tc   2td  2tf  2tg  t2h  t2l  2tm  2tn  2tp  t2r  2ts
     3t2sch      2tt  2tv  2tw  t2z  2tzk 2tzs 2t.  2t'. 2t''
1v   2vc   v2l   v2r  2vv  2v.  2v'. 2v''
1w   w2h   wa2r  2w1y 2w.  2w'. 2w''
1x   2xt   2xw   2x.   2x'. 2x''
y1ou y1i
1z   2zb   2zd   2zl  2zn  2zp  2zt  2zs  2zv  2zz  2z.  2z'. 2z''  .z2
}}                          % Pattern end

\endinput

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


                           LOADING THESE PATTERNS

These patterns, as well  as  those  for  any  other  language, do not become
effective until they are loaded in a special form into a format  file;  this
task  is  performed  by  the  TeX  initializer;  any  TeX system has its own
initializer with its special way  of  being activated.  Before loading these
patterns, then, it is necessary to read very carefully the instructions that
come with your TeX system.

Here I describe how to load the  patterns with the freeware TeX system named
MiKTeX version 2.x for Windows 9x, NT, 2000,  XP;  with  minor  changes  the
whole  procedure  is applicable with other TeX systems, but the details must
be deduced from your TeX system documentation at the section/chapter "How to
build or to rebuild a format file".

With MikTeX:

a) copy this file and replace  the existing file ithyph.tex in the directory
   \texmf\tex\generic\hyphen if the existing one has an older  version  date
   and number.
b) select Start|Programs|MiKTeX|MiKTeX options.
c) in  the  Language tab add a check mark to the line concerning the Italian
   language.
d) in the Geneal tab click "Update format files".
e) That's all!  

For the activation of these  patterns  with the specific Italian typesetting
features, use the babel package as this:

\documentclass{article} % Or whatever other class
\usepackage[italian]{babel}
...
\begin{document}
...
\end{document}


                           ON ITALIAN HYPHENATION

I have been working on patterns for the Italian language since 1987; in 1992
I published

C. Beccari, "Computer aided hyphenation for Italian and Modern
      Latin", TUG vol. 13, n. 1, pp. 23-33 (1992)

which contained a set of patterns that allowed hyphenation for both  Italian
and  Latin;  a  slightly  modified  version of the patterns published in the
above paper is contained in LAHYPH.TEX available on the CTAN archives.

From  the  above  patterns  I  extracted  the  minimum  set  necessary   for
hyphenating  Italian  that  was made available on the CTAN archives with the
name ITHYPH.tex the version number  3.5  on  the  16th of August 1994.  

The  original  pattern  set  required  37  ops;  being interested in a local
version of TeX/LaTeX  capable  of  dealing  with  half  a dozen languages, I
wanted to reduce memory occupation and therefore the number of ops.

Th new version (4.0 released  in  1996)  of  ITHYPH.TEX is much simpler than
version 3.5 and requires just 29 ops while  it  retains  all  the  power  of
version  3.5;  it  contains  many  more new patterns that allow to hyphenate
unusual words that generally have  a  root borrowed from a foreign language.
Updated versions 4.x contain minor  additions  and  the  number  of  ops  is
increased to 30 (version 4.7 of 1998/06/01).

This new pattern set has been tested  with the same set of difficult Italian
words that was used to test version 3.5 and it yields the  same  results  (a
part  a  minor  change  that was deliberately introduced so as to reduce the
typographical hyphenation  with  hyathi,  since  hyphenated  hyathi  are not
appreciated by Italian readers).   A  new  enlarged  word  set  for  testing
purposes  gets correct hyphen points that were missed or wrongly placed with
version 3.5, although no error had  been reported, because such words are of
very specialized nature and are seldom used.

As the previous version, this new set  of  patterns  does  not  contain  any
accented  character  so  that  the hyphenation algorithm behaves properly in
both cases, that is with cm  and  with dc/ec fonts.  With LaTeXe terminology
the difference is between OT1 and T1 encodings;  with  the  former  encoding
fonts  do  not  contain  accented characters, while with the latter accented
characters are present and sequences  such  as  \`a map directly to slot "E0
that contains "agrave".

Of course if you use dc/ec fonts (or any other real or virtual font with  T1
encoding)  you get the full power of the hyphenation algorithm, while if you
use cm fonts (or any other real or virtual font with OT1 encoding) you  miss
some  possible  break  points;  this  is  not a big inconvenience in Italian
because:

1) The Regulation UNI 6015 on  accents  specifies  that  compulsory  accents
   appear  only  on the ending vowel of oxitone words; this means that it is
   almost indifferent to have or  to  miss  the dc/ec fonts because the only
   difference consists in how TeX evaluates the end of the word; in practice
   if you have these special facilities you get "qua-li-t\`a", while if  you
   miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1).

2)  Optional  accents are so rare in Italian, that if you absolutely want to
   use  them  in  those  rare  instances,  and  you  miss  the  T1  encoding
   facilities, you should also provide  explicit discretionary hyphens as in
   "s\'e\-gui\-to".

There is no explicit  hyphenation  exception  list  because  these  patterns
proved  to  hyphenate correctly a very large set of words suitably chosen in
order to test them in the most heavy circumstances; these patterns were used
in the preparation of a number of books and no errors were discovered.

Nevertheless if you frequently use  technical terms that you want hyphenated
differently  from  what  is  normally  done  (for  example  if  you   prefer
etymological  hyphenation  of  prefixed  and/or  suffixed  words) you should
insert a specific hyphenation  list  in  the  preamble of your document, for
example:

\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri}

Should you find any word that gets hyphenated in a wrong way, please, AFTER
CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably
by e-mail.


                       Happy multilingual typesetting !
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































Deleted modules/textutil/pkgIndex.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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]} {
    # FRINK: nocheck
    return
}
package ifneeded textutil           0.6 [list source [file join $dir textutil.tcl]]
package ifneeded textutil::expander 1.2 [list source [file join $dir expander.tcl]]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































Deleted modules/textutil/repeat.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
# -*- tcl -*-
# trim.test:  tests for the textutil 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.
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then {
    source [file join [file dirname [info script]] textutil.tcl]
}

###################################################

test rep-0.1 {repeat < 0} {
    set str [::textutil::strRepeat . -1]
    set str
} ""

test rep-0.2 {repeat 0} {
    set str [::textutil::strRepeat . 0]
    set str 
} ""

test rep-0.3 {repeat 1} {
    set str [::textutil::strRepeat . 1]
    set str 
} "."

test rep-0.4 {repeat 2} {
    set str [::textutil::strRepeat . 2]
    set str 
} ".."

test rep-0.5 {repeat 3} {
    set str [::textutil::strRepeat . 3]
    set str 
} "..."

test rep-0.6 {repeat 5} {
    set str [::textutil::strRepeat . 5]
    set str 
} "....."

test rep-0.7 {repeat 10} {
    set str [::textutil::strRepeat . 10]
    set str 
} ".........."

test rep-0.8 {repeat 100} {
    set str [::textutil::strRepeat . 100]
    set str 
} "...................................................................................................."
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































Deleted modules/textutil/split.tcl.

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

    namespace eval split {

	namespace export splitx

	# This will be redefined later. We need it just to let
	# a chance for the next import subcommand to work
	#
	proc splitx [list str [list regexp "\[\t \r\n\]+"]] {}
    }

    namespace import -force split::splitx
    namespace export splitx

}

########################################################################
# This one was written by Bob Techentin (RWT in Tcl'ers Wiki):
# http://www.techentin.net
# mailto:[email protected]
#
# Later, he send me an email stated that I can use it anywhere, because
# no copyright was added, so the code is defacto in the public domain.
#
# You can found it in the Tcl'ers Wiki here:
# http://mini.net/cgi-bin/wikit/460.html
#
# Bob wrote:
# If you need to split string into list using some more complicated rule
# than builtin split command allows, use following function. It mimics
# Perl split operator which allows regexp as element separator, but,
# like builtin split, it expects string to split as first arg and regexp
# as second (optional) By default, it splits by any amount of whitespace. 
# Note that if you add parenthesis into regexp, parenthesed part of separator
# would be added into list as additional element. Just like in Perl. -- cary 
#
# Speed improvement by Reinhard Max:
# Instead of repeatedly copying around the not yet matched part of the
# string, I use [regexp]'s -start option to restrict the match to that
# part. This reduces the complexity from something like O(n^1.5) to
# O(n). My test case for that was:
# 
# foreach i {1 10 100 1000 10000} {
#     set s [string repeat x $i]
#     puts [time {splitx $s .}]
# }
#
proc ::textutil::split::splitx {str {regexp {[\t \r\n]+}}} {
    # Bugfix 476988
    if {[string length $str] == 0} {
	return {}
    }
    if {[string length $regexp] == 0} {
	return [::split $str ""]
    }
    set list  {}
    set start 0
    while {[regexp -start $start -indices -- $regexp $str match submatch]} {
        foreach {subStart subEnd} $submatch break
        foreach {matchStart matchEnd} $match break
        incr matchStart -1
        incr matchEnd
        lappend list [string range $str $start $matchStart]
        if {$subStart >= $start} {
            lappend list [string range $str $subStart $subEnd]
        }
        set start $matchEnd
    }
    lappend list [string range $str $start end]
    return $list
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































Deleted modules/textutil/split.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then {
    source [file join [file dirname [info script]] textutil.tcl]
}

###################################################

test splitx-0.1 {split simple string} {
    ::textutil::splitx "Hello, Word"
} [ list Hello, Word ]

test splitx-0.2 {split simple string with spaces} {
    ::textutil::splitx "Hello,     Word"
} [ list Hello, Word ]

test splitx-0.3 {split simple string with tabs} {
    ::textutil::splitx "Hello,\tWord"
} [ list Hello, Word ]

test splitx-0.4 {split simple string with tabs and spaces ...} {
    ::textutil::splitx "Hello,\t  \r   \n\n\n  \r \r \t\t  Word"
} [ list Hello, Word ]

test splitx-0.5 {split simple string with beginning and ending tabs} {
    ::textutil::splitx "\t  \r   \n\Hello, \t   Word \t  \r   \n\n"
} [ list {} Hello, Word {} ]

test splitx-1.1 {split simple string with regexp} {
    ::textutil::splitx "Hello,\t,\n, Word" "\[ ,\t\r\n\]+"
} [ list Hello Word ]

test splitx-1.2 {split simple string with buggy regexp} {
    ::textutil::splitx "Hello, Word,\t,\n" "\[ ,\t\r\n\]"
} [ list Hello {} Word {} {} {} {} ]

test splitx-2.1 {split text} {
    ::textutil::splitx "
Determines whether the regular expression exp matches part or all of
string and returns 1 if it does, 0 if it doesn't, unless -inline is
specified (see below). (Regular expression matching is described in the
re_syntax reference page.) If additional arguments are specified after
string then they are treated as the names of variables in which to
return information about which part(s) of string matched exp. MatchVar
will be set to the range of string that matched all of exp. The first
subMatchVar will contain the characters in string that matched the
leftmost parenthesized subexpression within exp, the next subMatchVar
will contain the characters that matched the next parenthesized
subexpression to the right in exp , and so on.
"
} [ list {} Determines whether the regular expression exp matches part or all of string and returns 1 if it does, 0 if it doesn't, unless -inline is specified (see below). (Regular expression matching is described in the re_syntax reference page.) If additional arguments are specified after string then they are treated as the names of variables in which to return information about which part(s) of string matched exp. MatchVar will be set to the range of string that matched all of exp. The first subMatchVar will contain the characters in string that matched the leftmost parenthesized subexpression within exp, the next subMatchVar will contain the characters that matched the next parenthesized subexpression to the right in exp , and so on. {} ]

test splitx-2.2 {split text with regexp} {
    ::textutil::splitx "
Determines whether the regular expression exp matches part or all of
string and returns 1 if it does, 0 if it doesn't, unless -inline is
specified (see below). (Regular expression matching is described in the
re_syntax reference page.) If additional arguments are specified after
string then they are treated as the names of variables in which to
return information about which part(s) of string matched exp. MatchVar
will be set to the range of string that matched all of exp. The first
subMatchVar will contain the characters in string that matched the
leftmost parenthesized subexpression within exp, the next subMatchVar
will contain the characters that matched the next parenthesized
subexpression to the right in exp , and so on.
" "\[ ,()\.\t\r\n\]+"
} [ list {} Determines whether the regular expression exp matches part or all of string and returns 1 if it does 0 if it doesn't unless -inline is specified see below Regular expression matching is described in the re_syntax reference page If additional arguments are specified after string then they are treated as the names of variables in which to return information about which part s of string matched exp MatchVar will be set to the range of string that matched all of exp The first subMatchVar will contain the characters in string that matched the leftmost parenthesized subexpression within exp the next subMatchVar will contain the characters that matched the next parenthesized subexpression to the right in exp and so on {} ]

# these tests show the effect inducted by the usage of parenthesed in
# the regexp Basically, the parenthesed operator is returned with the
# splitted list The 3.5 and 3.6 show complex cases. Try to understand.

test splitx-3.1 {split string with simple regexp} {
    ::textutil::splitx "Nobody is perfect" "\[oe\]+"
} [ list N b [ list dy is p ] rf  ct ]

test splitx-3.2 {split string with the same simple regexp but parenthesed} {
    ::textutil::splitx "Nobody is perfect" "(\[oe\]+)"
} [ list N o b o [ list dy is p ] e rf e ct ]

test splitx-3.3 {split string with a not so simple parenthesed regexp} {
    ::textutil::splitx "Nobody is perfect" "o+|(rf)"
} [ list N b [ list dy is pe ] rf  ect ]

test splitx-3.4 {split string with a more complexe parenthesed regexp} {
    ::textutil::splitx "Nobody is perfect" "\[oe\]+|(rf)"
} [ list N b [ list dy is p ] {} rf {} ct ]

test splitx-3.5 {split string with an even more complexe parenthesed regexp} {
    ::textutil::splitx "Nobody is perfect" "(\[oe\]+)|(rf)"
} [ list N o b o [ list dy is p ] e {} {} e ct ]

test splitx-3.6 {split string with a totally parenthesed regexp} {
    ::textutil::splitx "Nobody is perfect" "(\[oe\]+|rf)"
} [ list N o b o [ list dy is p ] e {} rf {} e ct ]


test splitx-4.0 {splitting of empty strings} {
    ::textutil::splitx "" "f"
} {}

test splitx-4.1 {splitting of empty strings} {
    ::textutil::splitx ""
} {}

test splitx-4.2 {splitting of empty strings} {
    ::textutil::splitx "" ""
} {}

test splitx-5.0 {splitting using an empty regexp} {
    ::textutil::splitx "fooo bar bas" ""
} {f o o o { } b a r { } b a s}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































Deleted modules/textutil/tabify.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
#
# As the author of the procs 'tabify2' and 'untabify2' I suggest that the
# comments explaining their behaviour be kept in this file.
# 1) Beginners in any programming language (I am new to Tcl so I know what I
#    am talking about) can profit enormously from studying 'correct' code.
#    Of course comments will help a lot in this regard.
# 2) Many problems newbies face can be solved by directing them towards
#    available libraries - after all, libraries have been written to solve
#    recurring problems. Then they can just use them, or have a closer look
#    to see and to discover how things are done the 'Tcl way'.
# 3) And if ever a proc from a library should be less than perfect, having
#    comments explaining the behaviour of the code will surely help.
#
# This said, I will welcome any error reports or suggestions for improvements
# (especially on the 'doing things the Tcl way' aspect).
#
# Use of these sources is licensed under the same conditions as is Tcl.
#
# June 2001, Helmut Giese ([email protected])
#
# ----------------------------------------------------------------------------
#
# The original procs 'tabify' and 'untabify' each work with complete blocks
# of $num spaces ('num' holding the tab size). While this is certainly useful
# in some circumstances, it does not reflect the way an editor works:
# 	Counting columns from 1, assuming a tab size of 8 and entering '12345'
#   followed by a tab, you expect to advance to column 9. Your editor might
#   put a tab into the file or 3 spaces, depending on its configuration.
#	Now, on 'tabifying' you will expect to see those 3 spaces converted to a
#	tab (and on the other hand expect the tab *at this position* to be
#	converted to 3 spaces).
#
#	This behaviour is mimicked by the new procs 'tabify2' and 'untabify2'.
#   Both have one feature in common: They accept multi-line strings (a whole
#   file if you want to) but in order to make life simpler for the programmer,
#   they split the incoming string into individual lines and hand each line to
#   a proc that does the real work.
#
#   One design decision worth mentioning here:
#      A single space is never converted to a tab even if its position would
#      allow to do so.
#   Single spaces occur very often, say in arithmetic expressions like
#   [expr (($a + $b) * $c) < $d]. If we didn't follow the above rule we might
#   need to replace one or more of them to tabs. However if the tab size gets
#   changed, this expression would be formatted quite differently - which is
#   probably not a good idea.
#
#   'untabifying' on the other hand might need to replace a tab with a single
#   space: If the current position requires it, what else to do?
#   As a consequence those two procs are unsymmetric in this aspect, but I
#   couldn't think of a better solution. Could you?
#
# ----------------------------------------------------------------------------
#

namespace eval ::textutil {

    namespace eval tabify {
	variable StrRepeat [ namespace parent ]::strRepeat
	variable TabLen  8
	variable TabStr  [ $StrRepeat " " $TabLen ]

	namespace export tabify untabify tabify2 untabify2

	# This will be redefined later. We need it just to let
	# a chance for the next import subcommand to work
	#
	proc tabify    { string { num 8 } } { }
	proc untabify  { string { num 8 } } { }
	proc tabify2   { string { num 8 } } { }
	proc untabify2 { string { num 8 } } { }

	# The proc 'untabify2' uses the following variables for efficiency.
	# Since a tab can be replaced by one up to 'tab size' spaces, it is handy
	# to have the appropriate 'space strings' available. This is the use of
	# the array 'Spaces', where 'Spaces(n)' contains just 'n' spaces.
	# The variable 'TabLen2' remembers the biggest tab size used.

	variable  TabLen2 0
	variable  Spaces
	array set Spaces {0 ""}
    }

    namespace import -force tabify::tabify tabify::untabify \
	    tabify::tabify2 tabify::untabify2
    namespace export tabify untabify tabify2 untabify2
}

########################################################################

proc ::textutil::tabify::tabify { string { num 8 } } {
    return [string map [list [MakeTabStr $num] \t] $string]
}

proc ::textutil::tabify::untabify { string { num 8 } } {
    return [string map [list \t [MakeTabStr $num]] $string]
}

proc ::textutil::tabify::MakeTabStr { num } {
    variable StrRepeat
    variable TabStr
    variable TabLen

    if { $TabLen != $num } then {
	set TabLen $num
	set TabStr [ $StrRepeat " " $num ]
    }

    return $TabStr
}

# ----------------------------------------------------------------------------
#
# tabifyLine: Works on a single line of text, replacing 'spaces at correct
# 		positions' with tabs. $num is the requested tab size.
#		Returns the (possibly modified) line.
#
# 'spaces at correct positions': Only spaces which 'fill the space' between
# an arbitrary position and the next tab stop can be replaced. 
# Example: With tab size 8, spaces at positions 11 - 13 will *not* be replaced,
#          because an expansion of a tab at position 11 will jump up to 16.
# See also the comment at the beginning of this file why single spaces are
# *never* replaced by a tab.
#
# The proc works backwards, from the end of the string up to the beginning:
#	- Set the position to start the search from ('lastPos') to 'end'.
#	- Find the last occurrence of ' ' in 'line' with respect to 'lastPos'
#         ('currPos' below). This is a candidate for replacement.
#       - Find to 'currPos' the following tab stop using the expression
#           set nextTab [expr ($currPos + $num) - ($currPos % $num)]
#         and get the previous tab stop as well (this will be the starting 
#         point for the next iteration).
#	- The ' ' at 'currPos' is only a candidate for replacement if
#	  1) it is just one position before a tab stop *and*
#	  2) there is at least one space at its left (see comment above on not
#	     touching an isolated space).
#	  Continue, if any of these conditions is not met.
#	- Determine where to put the tab (that is: how many spaces to replace?)
#	  by stepping up to the beginning until
#		-- you hit a non-space or
#		-- you are at the previous tab position
#	- Do the replacement and continue.
#
# This algorithm only works, if $line does not contain tabs. Otherwise our 
# interpretation of any position beyond the tab will be wrong. (Imagine you 
# find a ' ' at position 4 in $line. If you got 3 leading tabs, your *real*
# position might be 25 (tab size of 8). Since in real life some strings might 
# already contain tabs, we test for it (and eventually call untabifyLine).
#

proc ::textutil::tabify::tabifyLine { line num } {
    if { [string first \t $line] != -1 } { 		
	# assure array 'Spaces' is set up 'comme il faut'
	checkArr $num
	# remove existing tabs
	set line [untabifyLine $line $num]
    }

    set lastPos end

    while { $lastPos > 0 } {
	set currPos [string last " " $line $lastPos]
	if { $currPos == -1 } {
	    # no more spaces
	    break;
	}

	set nextTab [expr {($currPos + $num) - ($currPos % $num)}]
	set prevTab [expr {$nextTab - $num}]

	# prepare for next round: continue at 'previous tab stop - 1'
	set lastPos [expr {$prevTab - 1}]

	if { ($currPos + 1) != $nextTab } {
	    continue			;# crit. (1)
	}

	if { [string index $line [expr {$currPos - 1}]] != " " } {
	    continue			;# crit. (2)
	}

	# now step backwards while there are spaces
	for {set pos [expr {$currPos - 2}]} {$pos >= $prevTab} {incr pos -1} {
	    if { [string index $line $pos] != " " } {
		break;
	    }
	}

	# ... and replace them
	set line [string replace $line [expr {$pos + 1}] $currPos \t]
    }
    return $line
}

#
# Helper proc for 'untabifyLine': Checks if all needed elements of array
# 'Spaces' exist and creates the missing ones if needed.
#

proc ::textutil::tabify::checkArr { num } {
    variable TabLen2
    variable Spaces
    variable StrRepeat

    if { $num > $TabLen2 } {
	for { set i [expr {$TabLen2 + 1}] } { $i <= $num } { incr i } {
	    set Spaces($i) [$StrRepeat " " $i]
	}
	set TabLen2 $num
    }
}


# untabifyLine: Works on a single line of text, replacing tabs with enough
#		spaces to get to the next tab position.
#		Returns the (possibly modified) line.
#
# The procedure is straight forward:
#	- Find the next tab.
#	- Calculate the next tab position following it.
#	- Delete the tab and insert as many spaces as needed to get there.
#

proc ::textutil::tabify::untabifyLine { line num } {
    variable Spaces

    set currPos 0
    while { 1 } {
	set currPos [string first \t $line $currPos]
	if { $currPos == -1 } {
	    # no more tabs
	    break
	}

	# how far is the next tab position ?
	set dist [expr {$num - ($currPos % $num)}]
	# replace '\t' at $currPos with $dist spaces
	set line [string replace $line $currPos $currPos $Spaces($dist)]

	# set up for next round (not absolutely necessary but maybe a trifle
	# more efficient)
	incr currPos $dist
    }
    return $line
}

# tabify2: Replace all 'appropriate' spaces as discussed above with tabs.
#	'string' might hold any number of lines, 'num' is the requested tab size.
#	Returns (possibly modified) 'string'.
#
proc ::textutil::tabify::tabify2 { string { num 8 } } {

    # split string into individual lines
    set inLst [split $string \n]

    # now work on each line
    set outLst [list]
    foreach line $inLst {
	lappend outLst [tabifyLine $line $num]
    }

    # return all as one string
    return [join $outLst \n]
}


# untabify2: Replace all tabs with the appropriate number of spaces.
#	'string' might hold any number of lines, 'num' is the requested tab size.
#	Returns (possibly modified) 'string'.
#
proc ::textutil::tabify::untabify2 { string { num 8 } } {

    # assure array 'Spaces' is set up 'comme il faut'
    checkArr $num

    set inLst [split $string \n]

    set outLst [list]
    foreach line $inLst {
	lappend outLst [untabifyLine $line $num]
    }

    return [join $outLst \n]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































Deleted modules/textutil/tabify.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then {
    source [file join [file dirname [info script]] textutil.tcl]
}

###################################################

test tabify-0.1 {tabify string} {
    ::textutil::tabify "        hello,        world        "
} "\thello,\tworld\t"

test tabify-0.2 {tabify string with 4 chars} {
    ::textutil::tabify "        hello,        world        " 4
} "\t\thello,\t\tworld\t\t"

test tabify-0.3 {tabify string with 5 chars} {
    ::textutil::tabify "        hello,        world        " 5
} "\t   hello,\t   world\t   "

test tabify-1.1 {untabify string} {
    ::textutil::untabify "\thello,\tworld\t"
} "        hello,        world        "

test tabify-1.2 {untabify string with 4 chars} {
    ::textutil::untabify "\t\thello,\t\tworld\t\t" 4
} "        hello,        world        "

test tabify-1.3 {untabify string with 5 chars} {
    ::textutil::untabify "\t   hello,\t   world\t   " 5
} "        hello,        world        "

#
# Tests for version 2 of (un)tabify
#

#
# tests 2.1 - 2.3: see how a single space (after 'hello') is not converted
# to a tab
#
test tabify-2.1 {version 2: tabify, tab size 3} {
    ::textutil::tabify2 "hello    world" 3
    #                    ---|||---|||--
} "hello \tworld"

test tabify-2.2 {version 2: tabify, tab size 3, more spaces than needed} {
    ::textutil::tabify2 "hello      world" 3
} "hello \t  world"

test tabify-2.3 {version 2: tabify, tab size 3, less spaces than needed} {
    ::textutil::tabify2 "hello   world" 3
} "hello   world"

test tabify-2.4 {version 2: tabify, tab size 8} {
    ::textutil::tabify2 "hello   world"
} "hello\tworld"

test tabify-2.5 {version 2: tabify, tab size 8, more spaces than needed} {
    ::textutil::tabify2 "hello     world"
} "hello\t  world"

test tabify-2.6 {version 2: tabify, tab size 8, less spaces than needed} {
    ::textutil::tabify2 "hello  world"
} "hello  world"

#
# tests 2.7 & 2.8: 'end of line' (\n or not) of last line is preserved
#
test tabify-2.7 {version 2: tabify, tab size 8, multi line} {
    ::textutil::tabify2 "line 1  \n        line 2\nline 3  \n        line 4"
} "line 1\t\n\tline 2\nline 3\t\n\tline 4"

test tabify-2.8 {version 2: tabify, tab size 8, multi line} {
    ::textutil::tabify2 "line 1  \n        line 2\nline 3  \n        line 4\n"
} "line 1\t\n\tline 2\nline 3\t\n\tline 4\n"

# Test handling of existing tabs ... 2.9 as test and 2.10 the
# discrimator to check that it is correct if I use spaces
# instead of a tab, to see that my understanding is basically correct.

test tabify-2.9 {version 2: handling of existing tabs} {
    ::textutil::tabify2 "hello\tworld   bye"
    #                    hello...world   bye
    #                    --------||||||||---
} "hello\tworld\tbye"

test tabify-2.10 {version 2: handling of existing tabs} {
    ::textutil::tabify2 "hello   world   bye"
} "hello\tworld\tbye"


#
# untabify
#
test tabify-3.1 {version 2: untabify, tab size 3} {
    ::textutil::untabify2 "hello \tworld" 3
} "hello    world"

test tabify-3.2 {version 2: untabify, tab size 3, tab to single space} {
    ::textutil::untabify2 "hello\t\tworld" 3
} "hello    world"

#
# The change in tab size from 3 to 8 (silently) results in building the
# appropriate 'Spaces' strings (in 3.5 'Spaces(6)' is needed)
#
test tabify-3.3 {version 2: untabify, tab size 8} {
    ::textutil::untabify2 "hello\tworld"
} "hello   world"

test tabify-3.4 {version 2: untabify, tab size 8, mix of tab and spaces} {
    ::textutil::untabify2 "hello  \tworld"
} "hello   world"

test tabify-3.5 {version 2: untabify, tab size 8, requires 'long' space string} {
    ::textutil::untabify2 "hello\tmy\tworld"
} "hello   my      world"


#
# tests 3.6 & 3.7: 'end of line' (\n or not) of last line is preserved
#
test tabify-3.6 {version 2: untabify, tab size 8, multi line} {
    ::textutil::untabify2 "line 1\t\n\tline 2\nline 3\t\n\tline 4"
} "line 1  \n        line 2\nline 3  \n        line 4"

test tabify-3.7 {version 2: untabify, tab size 8, multi line} {
    ::textutil::untabify2 "line 1\t\n\tline 2\nline 3\t\n\tline 4\n"
} "line 1  \n        line 2\nline 3  \n        line 4\n"

#
# Edge cases: test for empty string
#
test tabify-4.1 {tabify empty string}   	{ textutil::tabify "" } ""
test tabify-4.2 {untabify empty string}  	{ textutil::untabify ""} ""
test tabify-4.3 {tabify2 empty string}   	{ textutil::tabify2 "" } ""
test tabify-4.4 {untabify2 empty string}	{ textutil::untabify2 ""} ""

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































Deleted modules/textutil/textutil.man.

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

The [package textutil] package provides commands that manipulate
strings or texts (a.k.a. long strings or string with embedded newlines
or paragraphs).

[para]

The complete set of procedures is described below.

[list_begin definitions]

[call [cmd ::textutil::adjust] [arg "string args"]]

Do a justification on the [arg string] according to [arg args].  The
string is taken as one big paragraph, ignoring any newlines.  Then the
line is formatted according to the options used, and the command
return a new string with enough lines to contain all the printable
chars in the input string. A line is a set of chars between the
beginning of the string and a newline, or between 2 newlines, or
between a newline and the end of the string. If the input string is
small enough, the returned string won't contain any newlines.

[nl]

Together with [cmd ::textutil::indent] it is possible to create
properly wrapped paragraphs with arbitrary indentations.

[nl]

By default, any occurrence of spaces characters or tabulation are
replaced by a single space so each word in a line is separated from
the next one by exactly one space char, and this forms a [emph real]
line. Each [emph real] line is placed in a [emph logical] line, which
have exactly a given length (see [option -length] option below). The
[emph real] line may have a lesser length. Again by default, any
trailing spaces are ignored before returning the string (see

[option -full] option below). The following options may be used after the
[arg string] parameter, and change the way the command place a

[emph real] line in a [emph logical] line.


[list_begin definitions]

[lst_item "-full [arg boolean]"]

If set to [const false], any trailing space chars are deleted before
returning the string. If set to [const true], any trailing space
chars are left in the string. Default to [const false].

[lst_item "[option -hyphenate] [arg boolean]"]

if set to [const false], no hyphenation will be done. If set to
[const true], the last word of a line is tried to be hyphenated.
Defaults to [const false]. Note: hyphenation patterns must be loaded
prior, using the command [cmd ::textutil::adjust::readPatterns].


[lst_item "[option -justify] [const center|left|plain|right]"]

Set the justification of the returned string to [const center],

[const left], [const plain] or [const right]. By default, it is set to
[const left].  The justification means that any line in the returned
string but the last one is build according to the value. If the
justification is set to [const plain] and the number of printable
chars in the last line is less than 90% of the length of a line (see
[option -length]), then this line is justified with the [const left]
value, avoiding the expansion of this line when it is too small. The
meaning of each value is:

[list_begin definitions]

[lst_item [const center]]

The real line is centered in the logical line. If needed, a set of
space characters are added at the beginning (half of the needed set)
and at the end (half of the needed set) of the line if required (see
the option [option -full]).

[lst_item [const left]]

The real line is set on the left of the logical line. It means that
there are no space chars at the beginning of this line. If required,
all needed space chars are added at the end of the line (see the
option [option -full]).

[lst_item [const plain]]

The real line is exactly set in the logical line. It means that there
are no leading or trailing space chars. All the needed space chars are
added in the [emph real] line, between 2 (or more) words.

[lst_item [const right]]

The real line is set on the right of the logical line. It means that
there are no space chars at the end of this line, and there may be
some space chars at the beginning, despite of the [option -full] option.

[list_end]

[lst_item "[option -length] [arg integer]"]

Set the length of the [emph logical] line in the string to
[arg integer].  [arg integer] must be a positive integer
value. Defaults to [const 72].


[lst_item "[option -strictlength] [arg boolean]"]

If set to [const false], a line can exceed the specified

[option -length] if a single word is longer than [option -length]. If
set to [const true], words that are longer than [option -length] are
split so that no line exceeds the specified [option -length]. Defaults
to [const false].

[list_end]


[call [cmd ::textutil::adjust::readPatterns] [arg filename]]

Loads the internal storage for hyphenation patterns with the contents
of the file [arg filename]. This has to be done prior to calling
command [cmd ::textutil::adjust] with

"[option -hyphenate] [const true]", or the hyphenation process will
not work correctly.

[nl]

The package comes with a number of predefined pattern files, and the
command [cmd ::textutil::adjust::listPredefined] can be used to find
out their names.

[call [cmd ::textutil::adjust::listPredefined]]

This command returns a list containing the names of the hyphenation
files coming with this package.

[call [cmd ::textutil::adjust::getPredefined] [arg filename]]

Use this command to query the package for the full path name of the
hyphenation file [arg filename] coming with the package. Only the
filenames found in the list returned by

[cmd ::textutil::adjust::listPredefined] are legal arguments for this
command.


[call [cmd ::textutil::indent] [arg string] [arg prefix] [opt [arg skip]]]

Each line in the [arg string] indented by adding the string
[arg prefix] at its beginning. The modified string is returned
as the result of the command.

[nl]

If [arg skip] is specified the first [arg skip] lines are left
untouched. The default for [arg skip] is [const 0], causing the
modification of all lines. Negative values for [arg skip] are treated
like [const 0]. In other words, [arg skip] > [const 0] creates a
hanging indentation.

[nl]

Together with [cmd ::textutil::adjust] it is possible to create
properly wrapped paragraphs with arbitrary indentations.


[call [cmd ::textutil::undent] [arg string]]

The command computes the common prefix for all
lines in [arg string] consisting solely out of whitespace,
removes this from each line and returns the modified string.

[nl]

Lines containing only whitespace are always reduced to completely
empty lines. They and empty lines are also ignored when computing the
prefix to remove.

[nl]

Together with [cmd ::textutil::adjust] it is possible to create
properly wrapped paragraphs with arbitrary indentations.


[call [cmd ::textutil::splitx] [arg string] [opt [arg regexp]]]

Split the [arg string] and return a list. The string is split
according to the regular expression [arg regexp] instead of a simple
list of chars. Note that if you add parenthesis into the [arg regexp],
the parentheses part of separator would be added into list as
additional element. If the [arg string] is empty the result is the
empty list, like for [cmd split]. If [arg regexp] is empty the

[arg string] is split at every character, like [cmd split] does.

The regular expression [arg regexp] defaults to "[lb]\\t \\r\\n[rb]+".


[call [cmd ::textutil::tabify] [arg string] [opt [arg num]]]

Tabify the [arg string] by replacing any substring of [arg num] space
chars by a tabulation and return the result as a new string. [arg num]
defaults to 8.


[call [cmd ::textutil::tabify2] [arg string] [opt [arg num]]]

Similar to [cmd ::textutil::tabify] this command tabifies the

[arg string] and returns the result as a new string. A different
algorithm is used however. Instead of replacing any substring of

[arg num] spaces this command works more like an editor. [arg num]
defaults to 8.

[nl]

Each line of the text in [arg string] is treated as if there are
tabstops every [arg num] columns. Only sequences of space characters
containing more than one space character and found immediately before
a tabstop are replaced with tabs.


[call [cmd ::textutil::trim] [arg string] [opt [arg regexp]]]

Remove in [arg string] any leading and trailing substring according to
the regular expression [arg regexp] and return the result as a new
string.  This apply on any [emph line] in the string, that is any
substring between 2 newline chars, or between the beginning of the
string and a newline, or between a newline and the end of the string,
or, if the string contain no newline, between the beginning and the
end of the string.

The regular expression [arg regexp] defaults to "[lb] \\t[rb]+".


[call [cmd ::textutil::trimleft] [arg string] [opt [arg regexp]]]

Remove in [arg string] any leading substring according to the regular
expression [arg regexp] and return the result as a new string. This
apply on any [emph line] in the string, that is any substring between
2 newline chars, or between the beginning of the string and a newline,
or between a newline and the end of the string, or, if the string
contain no newline, between the beginning and the end of the string.

The regular expression [arg regexp] defaults to "[lb] \\t[rb]+".

[call [cmd ::textutil::trimright] [arg string] [opt [arg regexp]]]

Remove in [arg string] any trailing substring according to the regular
expression [arg regexp] and return the result as a new string. This
apply on any [emph line] in the string, that is any substring between
2 newline chars, or between the beginning of the string and a newline,
or between a newline and the end of the string, or, if the string
contain no newline, between the beginning and the end of the string.

The regular expression [arg regexp] defaults to "[lb] \\t[rb]+".


[call [cmd ::textutil::trimPrefix] [arg string] [arg prefix]]

Removes the [arg prefix] from the beginning of [arg string] and
returns the result. The [arg string] is left unchanged if it doesn't
have [arg prefix] at its beginning.


[call [cmd ::textutil::trimEmptyHeading] [arg string]]

Looks for empty lines (including lines consisting of only whitespace)
at the beginning of the [arg string] and removes it. The modified
string is returned as the result of the command.


[call [cmd ::textutil::untabify] [arg string] [opt [arg num]]]

Untabify the [arg string] by replacing any tabulation char by a
substring of [arg num] space chars and return the result as a new
string. [arg num] defaults to 8.


[call [cmd ::textutil::untabify2] [arg string] [opt [arg num]]]

Untabify the [arg string] by replacing any tabulation char by a
substring of at most [arg num] space chars and return the result as a
new string. Unlike [cmd textutil::untabify] each tab is not replaced
by a fixed number of space characters.  The command overlays each line
in the [arg string] with tabstops every [arg num] columns instead and
replaces tabs with just enough space characters to reach the next
tabstop. This is the complement of the actions taken by

[cmd ::textutil::tabify2]. [arg num] defaults to 8.

[nl]

There is one asymmetry though: A tab can be replaced with a single
space, but not the other way around.


[call [cmd ::textutil::strRepeat] [arg "text num"]]

The implementation depends on the core executing the package. Used
[cmd "string repeat"] if it is present, or a fast tcl implementation
if it is not. Returns a string containing the [arg text] repeated

[arg num] times. The repetitions are joined without characters between
them. A value of [arg num] <= 0 causes the command to return an empty
string.


[call [cmd ::textutil::blank] [arg num]]

A convenience command. Returns a string of [arg num] spaces.

[call [cmd ::textutil::chop] [arg string]]

A convenience command. Removes the last character of [arg string] and
returns the shortened string.

[call [cmd ::textutil::tail] [arg string]]

A convenience command. Removes the first character of [arg string] and
returns the shortened string.

[call [cmd ::textutil::cap] [arg string]]

Capitalizes the first character of [arg string] and returns the modified string.

[call [cmd ::textutil::uncap] [arg string]]

The complementary operation to [cmd ::textutil::cap]. Forces the first
character of [arg string] to lower case and returns the modified
string.


[call [cmd ::textutil::longestCommonPrefixList] [arg list]]
[call [cmd ::textutil::longestCommonPrefix] [opt [arg string]...]]

Computes the longest common prefix for either the [arg string]s given
to the command, or the strings specified in the single [arg list], and
returns it as the result of the command.

[nl]

If no strings were specified the result is the empty string.  If only
one string was specified, the string itself is returned, as it is its
own longest common prefix.

[list_end]


[see_also regexp(n) split(n) string(n)]
[keywords string {regular expression} formatting TeX hyphenation]
[keywords indenting trimming paragraph]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































Deleted modules/textutil/textutil.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
'\"
'\" Copyright (c) 1998-2000 by nobody :-)
'\" All rights not reserved.
'\" 
'\" RCS: @(#) $Id: textutil.n,v 1.12 2002/02/15 05:35:30 andreas_kupries Exp $
'\" 
.so man.macros
.TH textutil n 0.5 Textutil "Texts and strings utils"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
::textutil \- Procedures to manipulate texts and strings..
.SH SYNOPSIS
.nf
\fBpackage require Tcl 8.2\fR
\fBpackage require textutil ?0.5?\fR
.sp
\fBtextutil::adjust\fR \fIstring args\fR
\fBtextutil::splitx\fR \fIstring {regexp [\\t \\r\\n]+}\fR
\fBtextutil::tabify\fR \fIstring {num 8}\fR
\fBtextutil::tabify2\fR \fIstring {num 8}\fR
\fBtextutil::trim\fR \fIstring {regexp [ \\t]+}\fR
\fBtextutil::trimleft\fR \fIstring {regexp [ \\t]+}\fR
\fBtextutil::trimright\fR \fIstring {regexp [ \\t]+}\fR
\fBtextutil::untabify\fR \fIstring {num 8}\fR
\fBtextutil::untabify2\fR \fIstring {num 8}\fR
\fBtextutil::strRepeat\fR \fIstring num\fR
.fi
.BE
.SH DESCRIPTION
.PP
The \fB::textutil\fR package provides commands that manipulate
strings or texts (a.k.a. long strings or string with embedded
newlines or paragraphs).

.PP
The complete set of procedures is described below.

.TP
\fBtextutil::adjust\fR \fIstring args\fR
Do a justification on the \fIstring\fP according to \fIargs\fP.
The string is taken as one big paragraph, ignoring any newlines.
Then the line is formatted according to the options used, and the
command return a new string with enough lines to contain all the
printable chars in the input string. A line is a set of chars
between the beginning of the string and a newline, or between 2
newlines, or between a newline and the end of the string. If the
input string is small enough, the returned string won't contain
any newlines.
.sp
By default, any occurrence of spaces characters or tabulation are
replaced by a single space so each word in a line is separated from
the next one by exactly one space char, and this forms a \fIreal\fR
line. Each \fIreal\fR line is placed in a \fIlogical\fR line, which
have exactly a given length (see \fI-length\fR option below). The
\fIreal\fR line may have a lesser length. Again by default, any trailing
spaces are ignored before returning the string (see \fI-full\fR option
below). The following options may be used after the \fIstring\fP
parameter, and change the way the command place a \fIreal\fR line in
a \fIlogical\fR line. 
.TP
\fI-full boolean\fR
if set to \fIfalse\fR, any trailing space chars are deleted before
returning the string. If set to \fItrue\fR, any trailing space chars are
left in the string. Default to \fIfalse\fR.
.TP
\fI-justify (center|left|plain|right)\fR
set the justification of the returned string to \fIcenter\fR, \fIleft\fR,
\fIplain\fR or \fIright\fR. By default, it is set to \fIleft\fR.
The justification means that any line in the returned string but the last
one is build according to the value. If the justification is set to
\fIplain\fR and the number of printable chars in the last line is less
than 90% of the length of a line (see \fI-length\fR), then this
line is justified with the \fIleft\fR value, avoiding the expansion of
this line when it is too small. The meaning of each value is:
.RS
.TP
\fIcenter\fR
the real line is centered in the logical line. If needed, a set of space
char are added at the beginning (half of the needed set) and at the end
(half of the needed set) of the line if required (see \fI-full\fR option).
.TP
\fIleft\fR
the real line is set on the left of the logical line. It means that
there are no space chars at the beginning of this line. If required, all
needed space chars are added at the end of the line (see \fI-full\fR
option).
.TP
\fIplain\fR
the real line is exactly set in the logical line. It means that there
are no leading or trailing space chars. All the needed space chars are
added in the \fIreal\fR line, between 2 (or more) words.
.TP
\fIright\fR
the real line is set on the right of the logical line. It means that
there are no space chars at the end of this line, and there may be some
space chars at the beginning, despite of the \fI-full\fR option.
.RE
.TP
\fI-length integer\fR
set the length of the \fIlogical\fR line in the string to \fIinteger\fR.
\fIinteger\fR must be a positive integer value. Default to \fI72\fR.
.TP
\fI-strictlength boolean\fR
if set to \fIfalse\fR, a line can exceed the specified '-length' if a
single word is longer than '-length'. If set to \fItrue\fR, words that
are longer than '-length' are split so that no line exceeds the
specified '-length'. Default to \fIfalse\fR.
.TP
\fBtextutil::splitx\fR \fIstring {regexp [\\t \\r\\n]+}\fR
Split the \fIstring\fP and return a list. The string is split
according to the regular expression \fIregexp\fR instead of a simple
list of chars. Note that if you add parenthesis into the \fIregexp\fR,
the parentheses part of separator would be added into list as
additional element. If the \fIstring\fR is empty the result is the
empty list, like for \fBsplit\fR. If \fIregexp\fR is empty the
\fIstring\fR is split at every character, like \fBsplit\fR does.
.TP
\fBtextutil::tabify\fR \fIstring {num 8}\fR
Tabify the \fIstring\fP by replacing any substring of \fInum\fP space
chars by a tabulation and return the result as a new string.

.TP
\fBtextutil::tabify2\fR \fIstring {num 8}\fR
Similar to \fBtextutil::tabify\fR this command tabifies the
\fIstring\fR and returns the result as a new string. A different
algorithm is used however. Instead of replacing any substring of
\fInum\fP spaces this comand works more like an editor.
.sp
Each line of the text in \fIstring\fR is treated as if there are
tabstops every \fInum\fR columns. Only sequences of space characters
containing more than one space character and found immediately before
a tabstop are replaced with tabs.

.TP
\fBtextutil::trim\fR \fIstring {regexp [ \\t]+}\fR
Remove in \fIstring\fP any leading and trailing substring according to
the regular expression \fIregexp\fR and return the result as a new string.
This apply on any \fIline\fR in the string, that is any substring between
2 newline chars, or between the beginning of the string and a newline, or
between a newline and the end of the string, or, if the string contain no
newline, between the beginning and the end of the string.

.TP
\fBtextutil::trimleft\fR \fIstring {regexp [ \\t]+}\fR
Remove in \fIstring\fP any leading substring according to the regular
expression \fIregexp\fR and return the result as a new string. This apply
on any \fIline\fR in the string, that is any substring between 2 newline
chars, or between the beginning of the string and a newline, or between a
newline and the end of the string, or, if the string contain no newline,
between the beginning and the end of the string.

.TP
\fBtextutil::trimright\fR \fIstring {regexp [ \\t]+}\fR
Remove in \fIstring\fP any trailing substring according to the regular
expression \fIregexp\fR and return the result as a new string. This apply
on any \fIline\fR in the string, that is any substring between 2 newline
chars, or between the beginning of the string and a newline, or between a
newline and the end of the string, or, if the string contain no newline,
between the beginning and the end of the string.

.TP
\fBtextutil::untabify\fR \fIstring {num 8}\fR
Untabify the \fIstring\fP by replacing any tabulation char by a substring
of \fInum\fP space chars and return the result as a new string.

.TP
\fBtextutil::untabify2\fR \fIstring {num 8}\fR

Untabify the \fIstring\fP by replacing any tabulation char by a
substring of at most \fInum\fP space chars and return the result as a
new string. Unlike \fBtextutil::untabify\fR each tab is not replaced
by a fixed number of space characters.  The command overlays each line
in the \fIstring\fR with tabstops every \fInum\fR columns instead and
replaces tabs with just enough space characters to reach the next
tabstop. This is the complement of the actions taken by
\fBtextutil::tabify2\fR.
.sp
There is one asymmetry though: A tab can be replaced with a single
space, but not the other way around.

.TP
\fBtextutil::strRepeat\fR \fItext num\fR
The implementation depends on the core executing the package. Used
\fBstring repeat\fR if it is present, or a fast tcl implementation if
it is not. Returns a string containing the \fItext\fR repeated
\fInum\fR times. The repetitions are joined without characters between
them. A value of \fInum\fR <= 0 causes the command to return an empty
string.

.SH "SEE ALSO"
regexp, split, string

.SH KEYWORDS
string, regular expression
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































Deleted modules/textutil/textutil.tcl.

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

namespace eval ::textutil {
    namespace export strRepeat
    
    variable HaveStrRepeat [ expr {![ catch { string repeat a 1 } ]} ]

    if {0} {
	# Problems with the deactivated code:
	# - Linear in 'num'.
	# - Tests for 'string repeat' in every call!
	#   (Ok, just the variable, still a test every call)
	# - Fails for 'num == 0' because of undefined 'str'.

	proc StrRepeat { char num } {
	    variable HaveStrRepeat
	    if { $HaveStrRepeat == 0 } then {
		for { set i 0 } { $i < $num } { incr i } {
		    append str $char
		}
	    } else {
		set str [ string repeat $char $num ]
	    }
	    return $str
	}
    }

}

if {$::textutil::HaveStrRepeat} {
    proc ::textutil::strRepeat {char num} {
	return [string repeat $char $num]
    }

    proc ::textutil::blank {n} {
	return [string repeat " " $n]
    }

} else {
    proc ::textutil::strRepeat {char num} {
	if {$num <= 0} {
	    # No replication required
	    return ""
	} elseif {$num == 1} {
	    # Quick exit for recursion
	    return $char
	} elseif {$num == 2} {
	    # Another quick exit for recursion
	    return $char$char
	} elseif {0 == ($num % 2)} {
	    # Halving the problem results in O (log n) complexity.
	    set result [strRepeat $char [expr {$num / 2}]]
	    return "$result$result"
	} else {
	    # Uneven length, reduce problem by one
	    return "$char[strRepeat $char [incr num -1]]"
	}
    }

    proc ::textutil::blank {n} {
	return [strRepeat " " $n]
    }
}


# @c Removes the last character from the given <a string>.
#
# @a string: The string to manipulate.
#
# @r The <a string> without its last character.
#
# @i chopping

proc ::textutil::chop {string} {
    return [string range $string 0 [expr {[string length $string]-2}]]
}



# @c Removes the first character from the given <a string>.
# @c Convenience procedure.
#
# @a string: string to manipulate.
#
# @r The <a string> without its first character.
#
# @i tail

proc ::textutil::tail {string} {
    return [string range $string 1 end]
}



# @c Capitalizes first character of the given <a string>.
# @c Complementary procedure to <p ::textutil::uncap>.
#
# @a string: string to manipulate.
#
# @r The <a string> with its first character capitalized.
#
# @i capitalize

proc ::textutil::cap {string} {
    return [string toupper [string index $string 0]][string range $string 1 end]
}

# @c unCapitalizes first character of the given <a string>.
# @c Complementary procedure to <p ::textutil::cap>.
#
# @a string: string to manipulate.
#
# @r The <a string> with its first character uncapitalized.
#
# @i uncapitalize

proc ::textutil::uncap {string} {
    return [string tolower [string index $string 0]][string range $string 1 end]
}


# Compute the longest string which is common to all strings given to
# the command, and at the beginning of said strings, i.e. a prefix. If
# only one argument is specified it is treated as a list of the
# strings to look at. If more than one argument is specified these
# arguments are the strings to be looked at. If only one string is
# given, in either form, the string is returned, as it is its own
# longest common prefix.

proc ::textutil::longestCommonPrefix {args} {
    return [longestCommonPrefixList $args]
}

proc ::textutil::longestCommonPrefixList {list} {
    if {[llength $list] == 0} {
	return ""
    } elseif {[llength $list] == 1} {
	return [lindex $list 0]
    }

    set list [lsort  $list]
    set min  [lindex $list 0]
    set max  [lindex $list end]

    # Min and max are the two strings which are most different. If
    # they have a common prefix, it will also be the common prefix for
    # all of them.

    # Fast bailouts for common cases.

    set n [string length $min]
    if {$n == 0}                         {return ""}
    if {0 == [string compare $min $max]} {return $min}

    set prefix ""
    for {set i 0} {$i < $n} {incr i} {
	if {0 == [string compare [set x [string range $min 0 $i]] [string range $max 0 $i]]} {
	    set prefix $x
	    continue
	}
	break
    }
    return $prefix
}



source [ file join [ file dirname [ info script ] ] adjust.tcl ]
source [ file join [ file dirname [ info script ] ] split.tcl ]
source [ file join [ file dirname [ info script ] ] tabify.tcl ]
source [ file join [ file dirname [ info script ] ] trim.tcl ]

# Do the [package provide] last, in case there is an error in the code above.
package provide textutil 0.6

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































Deleted modules/textutil/textutil.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}	

#source [ file join [ file dirname [ info script ] ] [ file rootname [ file tail [ info script ] ] ].tcl ]
#source [ file join [ file dirname [ info script ] ] adjust.test ]
#source [ file join [ file dirname [ info script ] ] split.test ]
#source [ file join [ file dirname [ info script ] ] tabify.test ]
#source [ file join [ file dirname [ info script ] ] trim.test ]
#source [ file join [ file dirname [ info script ] ] repeat.test ]


test textutil-1.0 {blank -1} {
    textutil::blank -1
} {}

test textutil-1.0 {blank 0} {
    textutil::blank 0
} {}

test textutil-1.0 {blank 1} {
    textutil::blank 1
} { }

test textutil-1.0 {blank 10} {
    textutil::blank 10
} {          }



test textutil-2.0 {chop empty} {
    textutil::chop {}
} {}

test textutil-2.1 {chop single} {
    textutil::chop { }
} {}

test textutil-2.2 {chop long} {
    textutil::chop {abcde}
} {abcd}



test textutil-3.0 {tail empty} {
    textutil::tail {}
} {}

test textutil-3.1 {tail single} {
    textutil::tail { }
} {}

test textutil-3.2 {tail long} {
    textutil::tail {abcde}
} {bcde}



test textutil-4.0 {cap empty} {
    textutil::cap {}
} {}

test textutil-4.1 {cap single} {
    textutil::cap {a}
} {A}

test textutil-4.2 {cap long} {
    textutil::cap {abcde}
} {Abcde}

test textutil-4.3 {cap capped} {
    textutil::cap {Abcde}
} {Abcde}



test textutil-5.0 {uncap empty} {
    textutil::uncap {}
} {}

test textutil-5.1 {uncap single} {
    textutil::uncap {A}
} {a}

test textutil-5.2 {uncap long} {
    textutil::uncap {Abcde}
} {abcde}

test textutil-5.3 {uncap uncapped} {
    textutil::uncap {abcde}
} {abcde}



test textutil-6.0 {lcs, no strings} {
    textutil::longestCommonPrefixList {}
} {}

test textutil-6.1 {lcs, one string} {
    textutil::longestCommonPrefixList {foo}
} {foo}

test textutil-6.2 {lcs, two strings, no prefix} {
    textutil::longestCommonPrefixList {foo bar}
} {}

test textutil-6.3 {lcs, two strings, small prefix} {
    textutil::longestCommonPrefixList {foo fbar}
} {f}

test textutil-6.4 {lcs, two strings, common} {
    textutil::longestCommonPrefixList {foo foo}
} {foo}

test textutil-6.5 {lcs, multiple strings} {
    textutil::longestCommonPrefixList {foo fox fubar}
} {f}




::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































Deleted modules/textutil/trim.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
namespace eval ::textutil {
	
    namespace eval trim {
    
	variable StrU "\[ \t\]+"
	variable StrR "(${StrU})\$"
	variable StrL "^(${StrU})"

	namespace export trim trimright trimleft \
		trimPrefix trimEmpyHeading

	# This will be redefined later. We need it just to let
	# a chance for the next import subcommand to work
	#
	proc trimleft  { text { trim "[ \t]+" } } { }
	proc trimright { text { trim "[ \t]+" } } { }
	proc trim      { text { trim "[ \t]+" } } { }

	proc trimPrefix {text prefix} {}
	proc trimEmptyHeading {text} {}
    }

    namespace import -force trim::trim trim::trimleft trim::trimright trim::trimPrefix trim::trimEmpyHeading
    namespace export trim trimleft trimright trimPrefix trimEmpyHeading
}


proc ::textutil::trim::trimleft {text {trim "[ \t]+"}} {
    regsub -line -all -- [MakeStr $trim left] $text {} text
    return $text
}

proc ::textutil::trim::trimright {text {trim "[ \t]+"}} {
    regsub -line -all -- [MakeStr $trim right] $text {} text
    return $text
}

proc ::textutil::trim::trim {text {trim "[ \t]+"}} {
    regsub -line -all -- [MakeStr $trim left]  $text {} text
    regsub -line -all -- [MakeStr $trim right] $text {} text
    return $text
}

proc ::textutil::trim::MakeStr { string pos }  {
    variable StrU
    variable StrR
    variable StrL

    if { "$string" != "$StrU" } {
        set StrU $string
        set StrR "(${StrU})\$"
        set StrL "^(${StrU})"
    }
    if { "$pos" == "left" } {
        return $StrL
    }
    if { "$pos" == "right" } {
        return $StrR
    }

    return -code error "Panic, illegal position key \"$pos\""
}


# @c Strips <a prefix> from <a text>, if found at its start.
#
# @a text: The string to check for <a prefix>.
# @a prefix: The string to remove from <a text>.
#
# @r The <a text>, but without <a prefix>.
#
# @i remove, prefix

proc ::textutil::trim::trimPrefix {text prefix} {
    if {[string first $prefix $text] == 0} {
	return [string range $text [string length $prefix] end]
    } else {
	return $text
    }
}


# @c Removes the Heading Empty Lines of <a text>.
#
# @a text: The text block to manipulate.
#
# @r The <a text>, but without heading empty lines.
#
# @i remove, empty lines

proc ::textutil::trim::trimEmptyHeading {text} {
    regsub -- "^(\[ \t\]*\n)*" $text {} text
    return $text
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































Deleted modules/textutil/trim.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

if { [ lsearch [ namespace children ] "::textutil" ] == -1 } then {
    source [file join [file dirname [info script]] textutil.tcl]
}

###################################################

test trim-0.1 {trim string on left} {
    set str [ ::textutil::trimleft "\t\t hello, world \t " ]
    set str
} "hello, world \t "

test trim-0.2 {trim string on right} {
    set str [ ::textutil::trimright "\t\t hello, world \t " ]
    set str 
} "\t\t hello, world"

test trim-0.3 {trim string on both side} {
    set str [ ::textutil::trim "\t\t hello, world \t " ]
    set str 
} "hello, world"

test trim-0.4 {trim string with embedded spaces and tabs on both side} {
    set str [ ::textutil::trim "\t\t hello,    \t\t  world \t " ]
    set str 
} "hello,    \t\t  world"

test trim-1.1 {trim text on left} {
    set str [ ::textutil::trimleft "\t\t hello, \t\n \tworld \t " ]
    set str
} "hello, \t
world \t "

test trim-1.2 {trim text on right} {
    set str [ ::textutil::trimright "\t\t hello, \t\n \tworld \t " ]
    set str 
} "\t\t hello,
 \tworld"

test trim-1.3 {trim string on both side} {
    set str [ ::textutil::trim "\t\t hello, \t\n \tworld \t " ]
    set str 
} "hello,
world"

test trim-1.4 {trim string with embedded spaces and tabs on both side} {
    set str [ ::textutil::trim "\t\t hello\t \t, \t\n \tthe\t  \t world \t " ]
    set str 
} "hello\t \t,
the\t  \t world"

test trim-2.1 {trim text on left with regexp} {
    set str [ ::textutil::trimleft "\t\t hello, \t\n \tworld \t " "\[ \thwdo\]+" ]
    set str
} "ello, \t
rld \t "

test trim-2.2 {trim text on right} {
    set str [ ::textutil::trimright "\t\t hello, \t\n \tworld \t " "\[ \thwdo\]+" ]
    set str 
} "\t\t hello,
 \tworl"

test trim-2.3 {trim string on both side} {
    set str [ ::textutil::trim "\t\t hello, \t\n \tworld \t " "\[ \thwdo\]+" ]
    set str 
} "ello,
rl"

test trim-2.4 {trim string with embedded spaces and tabs on both side} {
    set str [ ::textutil::trim "\t\t hello\t \t, \t\n \tthe\t  \t world \t " "\[ \thwdo\]+" ]
    set str 
} "ello\t \t,
the\t  \t worl"

# Not the real parray proc, because the default value of pattern is intentionnally omitted

set myparray "\t \tproc myparray {a pattern} {
    # print nicely an associated array sorted by element
    upvar 1 \$a array \t
    if {!\[array exists array\]} {
	error \"\\\"\$a\\\" isn't an array\" \t
    }
    set maxl 0 ; # used to find the longest name of element
    foreach name \[lsort \[array names array \$pattern\]\] {
	if {\[string length \$name\] > \$maxl} { \t\t\t 
	    set maxl \[string length \$name\]
	}
    }
    set maxl \[expr {\$maxl + \[string length \$a\] + 2}\]      \t
    foreach name \[lsort \[array names array \$pattern\]\] {
	set nameString \[format %s(%s) \$a \$name\]
	puts stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)\]
    }
\t\t}\t\t"

test trim-3.1 {trim block of Tcl code} {
    set code [ ::textutil::trim $myparray ]
    set code
} "proc myparray {a pattern} {
# print nicely an associated array sorted by element
upvar 1 \$a array
if {!\[array exists array\]} {
error \"\\\"\$a\\\" isn't an array\"
}
set maxl 0 ; # used to find the longest name of element
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 stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)\]
}
}"

test trim-3.2 {trim block of Tcl code with regexp} {
    set code [ ::textutil::trim $myparray "\[\] \t{}pu\]+" ]
    set code
} "roc myparray {a pattern
# print nicely an associated array sorted by element
var 1 \$a array
if {!\[array exists array
error \"\\\"\$a\\\" isn't an array\"

set maxl 0 ; # used to find the longest name of element
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
ts stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)

"

test trim-3.3 {trim block of commented Tcl code with regexp} {
    set code [ ::textutil::trim $myparray "(\[ \t\]+)|(\[ \t;\]*#.*)" ]
    set code
} "proc myparray {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 stdout \[format \"%-*s = %s\" \$maxl \$nameString \$array(\$name)\]
}
}"
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































Deleted modules/uri/ChangeLog.

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

	* uri.man:
	* uri.tcl (split): Accepted the FR [#545368] by Mark G. Saye
	  <[email protected]>, with a slight difference. To
	  keep API compatibibility the http stays the default scheme if
	  none was specified.

2003-04-13  Andreas Kupries  <[email protected]>

	* uri-rfc2396.test: Added constraint 'knownBug' to these
	  tests. And reference to [#581781].

2003-04-11  Andreas Kupries  <[email protected]>

	* uri.test:
	* uri.tcl (::uri::split): Fixed bug #676976 reported by Jason
	  Mills <[email protected]>. An incorrect regular
	  expression (typo in character class) accepted more character
	  than it should have.

2003-04-10  Andreas Kupries  <[email protected]>

	* pkgIndex.tcl:
	* uri.man:
	* uri.tcl: Fixed bug #614591. Set version
	  of the package to to 1.1.2.

	* urn-scheme.tcl: Fixed bug #614591. Set version
	  of the package to to 1.0.1

2003-03-28  Andreas Kupries  <[email protected]>

	* uri.man:
	* uri-rfc2396.test: New file. First step towards conformance with
	  RFC 2396, a testsuite for checking conformant behaviour. Thanks
	  to Rolf Ade <[email protected]>. Bug
	  #581781. Noted non-conformance in documentation, inviting help.

2003-02-07  Pat Thoyts  <[email protected]>

	* uri.test (uri-4.1): Fixed bad test.

2003-02-06  David N. Welton  <[email protected]>

	* uri.tcl (uri::SplitMailto): Use 'string match' instead of
	  regexp.

2003-01-16  Andreas Kupries  <[email protected]>

	* uri.man: More semantic markup, less visual one.

2003-01-07  Andreas Kupries  <[email protected]>
	
	* pkgIndex.tcl: Bump ifneeded patchlevel to match the provide in
	  uri.tcl. See last change.

2002-11-15  David N. Welton  <[email protected]>

	* uri.tcl (uri::canonicalize): Take care of trailing .., as in
	"http://foobar.com/foo/bar/..".

	* uri.test: Test for the above condition.

	* uri.tcl: Bump patchlevel in 'package provide'.

	* uri.test: Added tests for 'news' splitting and joining.

	* uri.man: Added 'news' to list of supported uri's.

	* uri.tcl (uri::SplitNews) (uri::JoinNews): Join and split 'news'
	URI's.  Fixes 636977.

	* uri.test: Added test to make sure that a URI can be split and
	then joined. to make sure the change below works.

	* uri.tcl (uri::JoinHttpInner): Make this proc deal with
	'fragments' - i.e. the #foo part of a URI.  Fixes 638075.

	* uri.test: Added tests relevant to the fix below.

	* uri.tcl (uri::resolve): Fix handling of queries so that the
	'new' query overrides the 'old' one.  This is how browsers do it.
	Fixes 639036.

2002-06-05  Andreas Kupries  <[email protected]>

	* urn-scheme.tcl: Moved provide up to the front to prevent
	  problems with [pkg_mkIndex]. Added namespace creation commands
	  to the top for the same reason.

2002-03-25  Andreas Kupries  <[email protected]>

	* uri.man: Fixed formatting errors in the doctools manpage.

2002-02-25  Andreas Kupries  <[email protected]>

	* uri.tcl: Fixed "::uri::canonicalize" to pass the extended
	  testsuite. The change to testsuite and command implementation
	  here was triggered through work on a spider and real life urls,
	  some of which where handled incorrectly.

	* uri.test: Extended the testsuite for "::uri::canonicalize" a
	  lot. Handling of uris with a path, without a path, unknown uri
	  schemes, path components which contain a ".", but are neither
	  "."  nor "..".

2002-02-14  Andreas Kupries  <[email protected]>

	* urn-scheme.tcl: Frink run.

	* Version is now 1.1.1 to distinguish from the code in tcllib
	  release 1.2

2002-01-15  Andreas Kupries  <[email protected]>

	* Bumped version to 1.1

2001-11-16  Andreas Kupries <[email protected]>

	* uri.n: Updated documentation to cover the change below.

	* uri.tcl: Changed geturl dispatcher to load a scheme::geturl
	  first and the scheme package only if that fails. See the ftp and
	  ftp::geturl packages. FR #476804.

2001-10-31  Pat Thoyts  <[email protected]>

	* uri.tcl: Fixed the ftptype regexp so that the type identifier
	  can be extracted. Fixed the ftp join code to follow the specs
	  for the type identifier. Added tests.

2001-10-31  Pat Thoyts  <[email protected]>

	* uri.tcl: Fixes for SF bug 474846 concerning bugs with ftp
	  userinfo and path construction.

	* uri.test: New tests to chec the above fixes.

2001-10-21  Andreas Kupries <[email protected]>

	* The changes below are made as part of accepting SF patch #470211
	  provided by Pat Thoyts <[email protected]>

	* uri.n: Documented "uri::register".

	* urn-scheme.tcl: Changed to use the new registration
	  command. Added declaration of "schemepart" as that variable is
	  required for the registration.

	* uri.tcl (uri::register): New command to register url
	  schemes. Rewrote the module to make use of this command when
	  declaring the standard schemes like ftp, http, ... Fixed a bug
	  in the url declarations (access to namespace basic was
	  incorrect). The command takes care to update the overall
	  variables tracking scheme information.

	* pkgIndex.tcl: Added the new sub-package to our package index.

	* urn.test: 
	* urn-scheme.tcl: New files, new sub-packages, provide the URN
	  schema for uri's and associated testsuite.

2001-08-21  Don Porter <[email protected]>

	* uri.n: Corrected title.  The 'uri' package does not
	provide "Tcl Built-In Commands."

2001-07-10  Andreas Kupries <[email protected]>

	* uri.tcl: Frink 2.2 run, fixed dubious code.

2001-06-21  Andreas Kupries <[email protected]>

	* uri.tcl: Fixed dubious code reported by frink.

2000-09-06  Brent Welch  <[email protected]>

	* uri.tcl:
	* uri.test:
	Added https support

2000-07-20  Eric Melski  <[email protected]>

	* uri.test:
	* uri.tcl: Applied patch from Andreas Kupries, to correct infinite loop
	condition in uri::canonicalize.

2000-06-16  Eric Melski  <[email protected]>

	* uri.test: Fixed bad test, added tcltest::cleanupTests call.

2000-06-13  Eric Melski  <[email protected]>

	* uri: initial import of uri package.

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































Deleted modules/uri/pkgIndex.tcl.

1
2
3
4
5
6
if {![package vsatisfies [package provide Tcl] 8.2]} {
    # FRINK: nocheck
    return
}
package ifneeded uri      1.1.2 [list source [file join $dir uri.tcl]]
package ifneeded uri::urn 1.0.1 [list source [file join $dir urn-scheme.tcl]]
<
<
<
<
<
<












Deleted modules/uri/uri-rfc2396.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}
set dirname [file dirname [info script]]
source      [file join $dirname uri.tcl]
package require uri

test uri-rfc2396-1.1 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g:h]
} g:h

test uri-rfc2396-1.2 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g]
} http://a/b/c/g

test uri-rfc2396-1.3 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ./g]
} http://a/b/c/g

test uri-rfc2396-1.4 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g/]
} http://a/b/c/g/

test uri-rfc2396-1.5 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q /g]
} http://a/g

test uri-rfc2396-1.6 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q //g]
} http://g

test uri-rfc2396-1.7 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ?y]
} http://a/b/c/?y

test uri-rfc2396-1.8 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g?y]
} http://a/b/c/g?y

test uri-rfc2396-1.9 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q \#s]
} {(current document)\#s}

test uri-rfc2396-1.10 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\#s]
} http://a/b/c/g\#s

test uri-rfc2396-1.11 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g?y\#s]
} http://a/b/c/g?y\#s

test uri-rfc2396-1.12 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q \;x]
} http://a/b/c/\;x

test uri-rfc2396-1.13 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\;x]
} http://a/b/c/g\;x

test uri-rfc2396-1.14 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q g\;x?y#s]
} http://a/b/c/g\;x?y#s

test uri-rfc2396-1.15 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q .]
} http://a/b/c/

test uri-rfc2396-1.16 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ./]
} http://a/b/c/

test uri-rfc2396-1.17 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ..]
} http://a/b/

test uri-rfc2396-1.18 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../]
} http://a/b/

test uri-rfc2396-1.19 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../g]
} http://a/b/g

test uri-rfc2396-1.20 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../..]
} http://a/

test uri-rfc2396-1.21 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../../]
} http://a/

test uri-rfc2396-1.22 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p?q ../../g]
} http://a/g


test uri-rfc2396-2.1 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g:h]
} g:h

test uri-rfc2396-2.2 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g]
} http://a/b/c/g

test uri-rfc2396-2.3 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ./g]
} http://a/b/c/g

test uri-rfc2396-2.4 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g/]
} http://a/b/c/g/

test uri-rfc2396-2.5 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p /g]
} http://a/g

test uri-rfc2396-2.6 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p //g]
} http://g

test uri-rfc2396-2.7 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ?y]
} http://a/b/c/?y

test uri-rfc2396-2.8 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g?y]
} http://a/b/c/g?y

test uri-rfc2396-2.9 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p \#s]
} {(current document)\#s}

test uri-rfc2396-2.10 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g\#s]
} http://a/b/c/g\#s

test uri-rfc2396-2.11 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g?y\#s]
} http://a/b/c/g?y\#s

test uri-rfc2396-2.12 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p \;x]
} http://a/b/c/\;x

test uri-rfc2396-2.13 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g\;x]
} http://a/b/c/g\;x

test uri-rfc2396-2.14 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p g\;x?y#s]
} http://a/b/c/g\;x?y#s

test uri-rfc2396-2.15 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p .]
} http://a/b/c/

test uri-rfc2396-2.16 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ./]
} http://a/b/c/

test uri-rfc2396-2.17 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ..]
} http://a/b/

test uri-rfc2396-2.18 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ../]
} http://a/b/

test uri-rfc2396-2.19 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ../g]
} http://a/b/g

test uri-rfc2396-2.20 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ../..]
} http://a/

test uri-rfc2396-2.21 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ../../]
} http://a/

test uri-rfc2396-2.22 {uri::resolve} {knownBug sf-tcllib-bug-581781} {
    uri::canonicalize [uri::resolve http://a/b/c/d\;p ../../g]
} http://a/g


#test uri-rfc2396-2. {uri::resolve} {knownBug sf-tcllib-bug-581781} {
#    uri::resolve http://a/b/c/d\;p 
#} 

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

::tcltest::cleanupTests
return

# -------------------------------------------------------------------------
# Local Variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































































































































































































































Deleted modules/uri/uri.man.

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

This package contains two parts. First it provides regular expressions
for a number of url/uri schemes. Second it provides a number of
commands for manipulating urls/uris and fetching data specified by
them. For the latter this package analyses the requested url/uri and
then dispatches it to the appropriate package (http, ftp, ...) for
actual fetching.

[para]

The package currently does not conform to
RFC 2396 ([uri http://www.rfc-editor.org/rfc/rfc2396.txt]),
but quite likely should be. Patches and other help are welcome.



[section COMMANDS]

[list_begin definitions]

[call [cmd uri::split] [arg url] [opt [arg defaultscheme]]]

[cmd uri::split] takes an [arg url], decodes it and then returns a
list of key/value pairs suitable for [cmd "array set"] containing the
constituents of the [arg url]. If the scheme is missing from the url
it defaults to the value of [arg defaultscheme] if it was specified,
or [term http] else. Currently only the schemes [term http],

[term ftp], [term mailto], [term urn], [term news], and [term file]
are supported by the package itself. See section [sectref EXTENDING]
on how to expand that range.


[call [cmd uri::join] [opt "[arg key] [arg value]"]...]

[cmd uri::join] takes a list of key/value pairs (generated by

[cmd uri::split], for example) and returns the canonical url they
represent. Currently only the schemes [term http], [term ftp],
[term mailto], [term urn], [term news], and [term file] are
supported. See section [sectref EXTENDING] on how to expand that range.


[call [cmd uri::resolve] [arg base] [arg url]]

[cmd uri::resolve] resolves the specified [arg url] relative to

[arg base]. In other words: A non-relative [arg url] is returned
unchanged, whereas for a relative [arg url] the missing parts are
taken from [arg base] and prepended to it. The result of this
operation is returned. For an empty [arg url] the result is

[arg base].


[call [cmd uri::isrelative] [arg url]]

[cmd uri::isrelative] determines whether the specified [arg url] is
absolute or relative.


[call [cmd uri::geturl] [arg url] [opt "[arg options]..."]]

[cmd uri::geturl] decodes the specified [arg url] and then dispatches
the request to the package appropriate for the scheme found in the
url. The command assumes that the package to handle the given scheme
either has the same name as the scheme itself (including possible
capitalization) followed by [cmd ::geturl], or, in case of this
failing, has the same name as the scheme itself (including possible
capitalization). It further assumes that whatever package was loaded
provides a [cmd geturl]-command in the namespace of the same name as
the package itself. This command is called with the given [arg url]
and all given [arg options]. Currently [cmd geturl] does not handle
any options itself.

[nl]

[emph Note:] [term file]-urls are an exception to the rule
described above. They are handled internally.

[nl]

It is not possible to specify results of the command. They depend on
the [cmd geturl]-command for the scheme the request was dispatched to.


[call [cmd uri::canonicalize] [arg uri]]

[cmd uri::canonicalize] returns the canonical form of a URI.  The
canonical form of a URI is one where relative path specifications,
ie. . and .., have been resolved.


[call [cmd uri::register] [arg schemeList] [arg script]]

[cmd uri::register] registers the first element of [arg schemeList] as
a new scheme and the remaining elements as aliases for this scheme. It
creates the namespace for the scheme and executes the [arg script] in
the new namespace. The script has to declare variables containing the
regular expressions relevant to the scheme. At least the variable
[var schemepart] has to be declared as that one is used to extend
the variables keeping track of the registered schemes.

[list_end]

[section  SCHEMES]

In addition to the commands mentioned above this package provides
regular expression to recognize urls for a number of url schemes.

[para]

For each supported scheme a namespace of the same name as the scheme
itself is provided inside of the namespace [emph uri] containing the
variable [var url] whose contents are a regular expression to
recognize urls of that scheme. Additional variables may contain
regular expressions for parts of urls for that scheme.

[para]

The variable [var uri::schemes] contains a list of all supported
schemes. Currently these are [term ftp], [term file],

[term http], [term gopher], [term mailto], [term news],
[term wais] and [term prospero].

[section  EXTENDING]

Extending the range of schemes supported by [cmd uri::split] and

[cmd uri::join] is easy because both commands do not handle the
request by themselves but dispatch it to another command in the
[emph uri] namespace using the scheme of the url as criterion.

[para]

[cmd uri::split] and [cmd uri::join]

call [cmd "Split[lb]string totitle <scheme>[rb]"]
and  [cmd "Join[lb]string totitle <scheme>[rb]"] respectively.

[section  CREDITS]
[para]

Original code (regular expressions) by Andreas Kupries.
Modularisation by Steve Ball, also the split/join/resolve functionality.

[keywords uri url {fetching information} www http ftp mailto news gopher wais prospero file {rfc 2396}] 
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































































































































































































Deleted modules/uri/uri.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
'\" 
'\" Copyright (c) 2000 Andreas Kupries
'\" Copyright (c) 2000 Zveno Pty Ltd
'\" 
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\" 
'\" SCCS: @(#) uri.n
'\" 
.so man.macros
.TH "uri" n 1.1.1 Tcl "Tcl Uniform Resource Identifier Management"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
uri \- URI utilities
.SH "SYNOPSIS"
\fBpackage require Tcl 8.2\fR
.sp
\fBpackage require uri ?1.1.1?\fR
.sp
\fB uri::split      \fIurl\fR
\fB uri::join       \fR?\fIkey\fR \fIvalue\fR?...
\fB uri::resolve    \fIbase\fR \fIurl\fR
\fB uri::isrelative \fIurl\fR
\fB uri::geturl     \fIurl\fR ?\fIoptions\fR...?
\fB uri::canonicalize \fIuri\fR
\fB uri::register \fIschemeList\fR \fIscript\fR
.BE
.SH "DESCRIPTION"
.PP
This package contains two parts. First it provides regular expressions
for a number of url/uri schemes. Second it provides a number of
commands for manipulating urls/uris and fetching data specified by
them. For the latter this package analyses the requested url/uri and
then dispatches it to the appropriate package (http, ftp, ...) for
actual fetching.
.SH "COMMANDS"
\fBuri::split\fR takes a single \fIurl\fR, decodes it and then returns
a list of key/value pairs suitable for \fBarray set\fR containing
the constituents of the \fIurl\fR. If the scheme is missing from the
url it defaults to \fBhttp\fR. Currently only the schemes
\fBhttp\fR, \fBftp\fR, \fBmailto\fR, \fBurn\fR and \fBfile\fR are
supported. See section EXTENDING on how to expand that range.
.PP
\fBuri::join\fR takes a list of key/value pairs (generated by
\fBuri::split\fR, for example) and returns the canonical url they
represent. Currently only the schemes \fBhttp\fR, \fBftp\fR,
\fBmailto\fR, \fBurn\fR and \fBfile\fR are supported. See section 
EXTENDING on how to expand that range.
.PP
\fBuri::isrelative\fR determines whether the specified \fIurl\fR is
absolute or relative.
.PP
\fBuri::resolve\fR resolves the specified \fIurl\fR relative to
\fIbase\fR. In other words: A non-relative \fIurl\fR is returned
unchanged, whereas for a relative \fIurl\fR the missing parts are
taken from \fIbase\fR and prepended to it. The result of this
operation is returned. For an empty \fIurl\fR the result is
\fIbase\fR.
.PP
\fBuri::geturl\fR decodes the specified \fIurl\fR and then dispatches
the request to the package appropriate for the scheme found in the
url. The command assumes that the package to handle the given scheme
either has the same name as the scheme itself (including possible
capitalization) followed by \fB::geturl\fR, or, in case of this
failing, has the same name as the scheme itself (including possible
capitalization). It further assumes that whatever package was loaded
provides a \fBgeturl\fR-command in the namespace of the same name as
the package itself. This command is called with the given \fIurl\fR
and all given \fIoptions\fR. Currently \fBgeturl\fR does not handle
any options itself.
.PP
\fBNote:\fR \fBfile\fR-urls are an exception to the rule described
above. They are handled internally.
.PP
It is not possible to specify results of the command. They depend on
the \fBgeturl\fR-command for the scheme the request was dispatched to.
.PP
\fBuri::canonicalize\fR returns the canonical form of a URI.
The canonical form of a URI is one where relative path specifications,
ie. . and .., have been resolved.
.PP
\fBuri::register\fR registers the first element of \fIschemeList\fR as
a new scheme and the remaining elements as aliases for this scheme. It
creates the namespace for the scheme and executes the \fIscript\fR in
the new namespace. The script has to declare variables containing the
regular expressions relevant to the scheme. At least the variable
\fBschemepart\fR has to be declared as that one is used to extend the
variables keeping track of the registered schemes.
.SH "SCHEMES"
In addition to the commands mentioned above this package provides
regular expression to recognize urls for a number of url schemes.
.PP
For each supported scheme a namespace of the same name as the scheme
itself is provided inside of the namespace \fBuri\fR containing the
variable \fBurl\fR whose contents are a regular expression to
recognize urls of that scheme. Additional variables may contain
regular expressions for parts of urls for that scheme.
.PP
The variable \fBuri::schemes\fR contains a list of all supported
schemes. Currently these are \fBftp\fR, \fBfile\fR, \fBhttp\fR,
\fBgopher\fR, \fBmailto\fR, \fBnews\fR, \fBwais\fR and
\fBprospero\fR.
.SH "EXTENDING"
Extending the range of schemes supported by \fBuri::split\fR and
\fBuri::join\fR is easy because both commands do not handle the
request by themselves but dispatch it to another command in the
\fBuri\fR namespace using the scheme of the url as criterion.
.PP
\fBuri:split\fR and \fBuri:join\fR call Split[string totitle <scheme>]
and Join[string totitle <scheme>] respectively.
.SH "SEE ALSO"
.SH "CREDITS"
Original code by Andreas Kupries.  Modularisation by Steve Ball.
.PP
.SH "KEYWORDS"
uri, url, fetching information, www, http, ftp, mailto, gopher, wais, prospero, file
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































Deleted modules/uri/uri.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
# uri.tcl --
#
#	URI parsing and fetch
#
# Copyright (c) 2000 Zveno Pty Ltd
# Steve Ball, http://www.zveno.com/
# Derived from urls.tcl by Andreas Kupries
#
# TODO:
#	Handle www-url-encoding details
#
# CVS: $Id: uri.tcl,v 1.22 2003/04/14 20:15:51 andreas_kupries Exp $

package require Tcl 8.2

namespace eval ::uri {

    namespace export split join
    namespace export resolve isrelative
    namespace export geturl
    namespace export canonicalize
    namespace export register

    variable file:counter 0

    # extend these variable in the coming namespaces
    variable schemes       {}
    variable schemePattern ""
    variable url           ""
    variable url2part
    array set url2part     {}

    # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    # basic regular expressions used in URL syntax.

    namespace eval basic {
	variable	loAlpha		{[a-z]}
	variable	hiAlpha		{[A-Z]}
	variable	digit		{[0-9]}
	variable	alpha		{[a-zA-Z]}
	variable	safe		{[$_.+-]}
	variable	extra		{[!*'(,)]}
	# danger in next pattern, order important for []
	variable	national	{[][|\}\{\^~`]}
	variable	punctuation	{[<>#%"]}	;#" fake emacs hilit
	variable	reserved	{[;/?:@&=]}
	variable	hex		{[0-9A-Fa-f]}
	variable	alphaDigit	{[A-Za-z0-9]}
	variable	alphaDigitMinus	{[A-Za-z0-9-]}

	# next is <national | punctuation>
	variable	unsafe		{[][<>"#%\{\}|\\^~`]} ;#" emacs hilit
	variable	escape		"%${hex}${hex}"

	#	unreserved	= alpha | digit | safe | extra
	#	xchar		= unreserved | reserved | escape

	variable	unreserved	{[a-zA-Z0-9$_.+!*'(,)-]}
	variable	uChar		"(${unreserved}|${escape})"
	variable	xCharN		{[a-zA-Z0-9$_.+!*'(,);/?:@&=-]}
	variable	xChar		"(${xCharN}|${escape})"
	variable	digits		"${digit}+"

	variable	toplabel	\
		"(${alpha}${alphaDigitMinus}*${alphaDigit}|${alpha})"
	variable	domainlabel	\
		"(${alphaDigit}${alphaDigitMinus}*${alphaDigit}|${alphaDigit})"

	variable	hostname	\
		"((${domainlabel}\\.)*${toplabel})"
	variable	hostnumber	\
		"(${digits}\\.${digits}\\.${digits}\\.${digits})"

	variable	host		"(${hostname}|${hostnumber})"

	variable	port		$digits
	variable	hostOrPort	"${host}(:${port})?"

	variable	usrCharN	{[a-zA-Z0-9$_.+!*'(,);?&=-]}
	variable	usrChar		"(${usrCharN}|${escape})"
	variable	user		"${usrChar}*"
	variable	password	$user
	variable	login		"(${user}(:${password})?@)?${hostOrPort}"
    } ;# basic {}
}


# ::uri::register --
#
#	Register a scheme (and aliases) in the package. The command
#	creates a namespace below "::uri" with the same name as the
#	scheme and executes the script declaring the pattern variables
#	for this scheme in the new namespace. At last it updates the
#	uri variables keeping track of overall scheme information.
#
#	The script has to declare at least the variable "schemepart",
#	the pattern for an url of the registered scheme after the
#	scheme declaration. Not declaring this variable is an error.
#
# Arguments:
#	schemeList	Name of the scheme to register, plus aliases
#       script		Script declaring the scheme patterns
#
# Results:
#	None.

proc ::uri::register {schemeList script} {
    variable schemes
    variable schemePattern
    variable url
    variable url2part

    # Check scheme and its aliases for existence.
    foreach scheme $schemeList {
	if {[lsearch -exact $schemes $scheme] >= 0} {
	    return -code error \
		    "trying to register scheme (\"$scheme\") which is already known"
	}
    }

    # Get the main scheme
    set scheme  [lindex $schemeList 0]

    if {[catch {namespace eval $scheme $script} msg]} {
	catch {namespace delete $scheme}
	return -code error \
	    "error while evaluating scheme script: $msg"
    }

    if {![info exists ${scheme}::schemepart]} {
	namespace delete $scheme
	return -code error \
	    "Variable \"schemepart\" is missing."
    }

    # Now we can extend the variables which keep track of the registered schemes.

    eval lappend schemes $schemeList
    set schemePattern	"([::join $schemes |]):"

    foreach s schemeList {
	# FRINK: nocheck
	set url2part($s) "${s}:[set ${scheme}::schemepart]"
	# FRINK: nocheck
	append url "(${s}:[set ${scheme}::schemepart])|"
    }
    set url [string trimright $url |]
    return
}

# ::uri::split --
#
#	Splits the given <a url> into its constituents.
#
# Arguments:
#	url	the URL to split
#
# Results:
#	Tcl list containing constituents, suitable for 'array set'.

proc ::uri::split {url {defaultscheme http}} {

    set url [string trim $url]
    set scheme {}

    # RFC 1738:	scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
    regexp -- {^([a-z0-9+.-][a-z0-9+.-]*):} $url dummy scheme

    if {$scheme == {}} {
	set scheme $defaultscheme
    }

    # ease maintenance: dynamic dispatch, able to handle all schemes
    # added in future!

    if {[::info procs Split[string totitle $scheme]] == {}} {
	error "unknown scheme '$scheme' in '$url'"
    }

    regsub -- "^${scheme}:" $url {} url

    set       parts(scheme) $scheme
    array set parts [Split[string totitle $scheme] $url]

    # should decode all encoded characters!

    return [array get parts]
}

proc ::uri::SplitFtp {url} {
    # @c Splits the given ftp-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
    #
    # additional rules:
    #
    # <user>:<password> are optional, detectable by presence of @.
    # <password> is optional too.
    #
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    #	<cwd1> "/" ..."/" <cwdN> "/" <name> [";type=" <typecode>]

    upvar \#0 [namespace current]::ftp::typepart ftptype

    array set parts {user {} pwd {} host {} port {} path {} type {}}

    # slash off possible type specification

    if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {

	set from	[lindex $ftype 0]
	set to		[lindex $ftype 1]

	set parts(type)	[string range   $url $from $to]

	set from	[lindex $dummy 0]
	set url		[string replace $url $from end]
    }

    # Handle user, password, host and port

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	array set parts [GetUPHP url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

proc ::uri::JoinFtp args {
    array set components {
	user {} pwd {} host {} port {}
	path {} type {}
    }
    array set components $args

    set userPwd {}
    if {[string length $components(user)] || [string length $components(pwd)]} {
	set userPwd $components(user)[expr {[string length $components(pwd)] ? ":$components(pwd)" : {}}]@
    }

    set port {}
    if {[string length $components(port)]} {
	set port :$components(port)
    }

    set type {}
    if {[string length $components(type)]} {
	set type \;type=$components(type)
    }

    return ftp://${userPwd}$components(host)${port}/[string trimleft $components(path) /]$type
}

proc ::uri::SplitHttps {url} {
    uri::SplitHttp $url
}

proc ::uri::SplitHttp {url} {
    # @c Splits the given http-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    # general syntax:
    # //<host>:<port>/<path>?<searchpart>
    #
    #   where <host> and <port> are as described in Section 3.1. If :<port>
    #   is omitted, the port defaults to 80.  No user name or password is
    #   allowed.  <path> is an HTTP selector, and <searchpart> is a query
    #   string. The <path> is optional, as is the <searchpart> and its
    #   preceding "?". If neither <path> nor <searchpart> is present, the "/"
    #   may also be omitted.
    #
    #   Within the <path> and <searchpart> components, "/", ";", "?" are
    #   reserved.  The "/" character may be used within HTTP to designate a
    #   hierarchical structure.
    #
    # path == <cwd1> "/" ..."/" <cwdN> "/" <name> ["#" <fragment>]

    upvar #0 [namespace current]::http::search  search
    upvar #0 [namespace current]::http::segment segment

    array set parts {host {} port {} path {} query {}}

    set searchPattern   "\\?(${search})\$"
    set fragmentPattern "#(${segment})\$"

    # slash off possible query

    if {[regexp -indices -- $searchPattern $url match query]} {
	set from [lindex $query 0]
	set to   [lindex $query 1]

	set parts(query) [string range $url $from $to]

	set url [string replace $url [lindex $match 0] end]
    }

    # slash off possible fragment

    if {[regexp -indices -- $fragmentPattern $url match fragment]} {
	set from [lindex $fragment 0]
	set to   [lindex $fragment 1]

	set parts(fragment) [string range $url $from $to]

	set url [string replace $url [lindex $match 0] end]
    }

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	array set parts [GetHostPort url]
    }

    set parts(path) [string trimleft $url /]

    return [array get parts]
}

proc ::uri::JoinHttp {args} {
    eval uri::JoinHttpInner http 80 $args
}

proc ::uri::JoinHttps {args} {
    eval uri::JoinHttpInner https 443 $args
}

proc ::uri::JoinHttpInner {scheme defport args} {
    array set components [list \
	host {} port $defport path {} query {} \
    ]
    array set components $args

    set port {}
    if {[string length $components(port)] && $components(port) != $defport} {
	set port :$components(port)
    }

    set query {}
    if {[string length $components(query)]} {
	set query ?$components(query)
    }

    regsub -- {^/} $components(path) {} components(path)

    if { [info exists components(fragment)] && $components(fragment) != "" } {
	set components(fragment) "#$components(fragment)"
    } else {
	set components(fragment) ""
    }

    return $scheme://$components(host)$port/$components(path)$components(fragment)$query
}

proc ::uri::SplitFile {url} {
    # @c Splits the given file-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    upvar #0 [namespace current]::basic::hostname	hostname
    upvar #0 [namespace current]::basic::hostnumber	hostnumber

    if {[string match "//*" $url]} {
	set url [string range $url 2 end]

	set hostPattern "^($hostname|$hostnumber)"
	switch -exact -- $::tcl_platform(platform) {
	    windows {
		# Catch drive letter
		append hostPattern :?
	    }
	    default {
		# Proceed as usual
	    }
	}

	if {[regexp -indices -- $hostPattern $url match host]} {
	    set fh	[lindex $host 0]
	    set th	[lindex $host 1]

	    set parts(host)	[string range $url $fh $th]

	    set  matchEnd   [lindex $match 1]
	    incr matchEnd

	    set url	[string range $url $matchEnd end]
	}
    }

    set parts(path) $url

    return [array get parts]
}

proc ::uri::JoinFile args {
    array set components {
	host {} port {} path {}
    }
    array set components $args

    switch -exact -- $::tcl_platform(platform) {
	windows {
	    if {[string length $components(host)]} {
		return file://$components(host):$components(path)
	    } else {
		return file://$components(path)
	    }
	}
	default {
	    return file://$components(host)$components(path)
	}
    }
}

proc ::uri::SplitMailto {url} {
    # @c Splits the given mailto-<a url> into its constituents.
    # @a url: The url to split, without! scheme specification.
    # @r List containing the constituents, suitable for 'array set'.

    if {[string match "*@*" $url]} {
	set url [::split $url @]
	return [list user [lindex $url 0] host [lindex $url 1]]
    } else {
	return [list user $url]
    }
}

proc ::uri::JoinMailto args {
    array set components {
	user {} host {}
    }
    array set components $args

    return mailto:$components(user)@$components(host)
}

proc ::uri::SplitNews {url} {
    if { [string first @ $url] >= 0 } {
	return [list message-id $url]
    } else {
	return [list newsgroup-name $url]
    }
}

proc ::uri::JoinNews args {
    array set components {
	message-id {} newsgroup-name {}
    }
    array set components $args
    return news:$components(message-id)$components(newsgroup-name)
}

proc ::uri::GetUPHP {urlvar} {
    # @c Parse user, password host and port out of the url stored in
    # @c variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar \#0 [namespace current]::basic::user		user
    upvar \#0 [namespace current]::basic::password	password
    upvar \#0 [namespace current]::basic::hostname	hostname
    upvar \#0 [namespace current]::basic::hostnumber	hostnumber
    upvar \#0 [namespace current]::basic::port		port

    upvar $urlvar url

    array set parts {user {} pwd {} host {} port {}}

    # syntax
    # "//" [ <user> [":" <password> ] "@"] <host> [":" <port>] "/"
    # "//" already cut off by caller

    set upPattern "^(${user})(:(${password}))?@"

    if {[regexp -indices -- $upPattern $url match theUser c d thePassword]} {
	set fu	[lindex $theUser 0]
	set tu	[lindex $theUser 1]

	set fp	[lindex $thePassword 0]
	set tp	[lindex $thePassword 1]

	set parts(user)	[string range $url $fu $tu]
	set parts(pwd)	[string range $url $fp $tp]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    set hpPattern "^($hostname|$hostnumber)(:($port))?"

    if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
	set fh	[lindex $theHost 0]
	set th	[lindex $theHost 1]

	set fp	[lindex $thePort 0]
	set tp	[lindex $thePort 1]

	set parts(host)	[string range $url $fh $th]
	set parts(port)	[string range $url $fp $tp]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url	[string range $url $matchEnd end]
    }

    return [array get parts]
}

proc ::uri::GetHostPort {urlvar} {
    # @c Parse host and port out of the url stored in variable <a urlvar>.
    # @d Side effect: The extracted information is removed from the given url.
    # @r List containing the extracted information in a format suitable for
    # @r 'array set'.
    # @a urlvar: Name of the variable containing the url to parse.

    upvar #0 [namespace current]::basic::hostname	hostname
    upvar #0 [namespace current]::basic::hostnumber	hostnumber
    upvar #0 [namespace current]::basic::port		port

    upvar $urlvar url

    set pattern "^(${hostname}|${hostnumber})(:(${port}))?"

    if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
	set fromHost	[lindex $host 0]
	set toHost	[lindex $host 1]

	set fromPort	[lindex $thePort 0]
	set toPort	[lindex $thePort 1]

	set parts(host)	[string range $url $fromHost $toHost]
	set parts(port)	[string range $url $fromPort $toPort]

	set  matchEnd   [lindex $match 1]
	incr matchEnd

	set url [string range $url $matchEnd end]
    }

    return [array get parts]
}

# ::uri::resolve --
#
#	Resolve an arbitrary URL, given a base URL
#
# Arguments:
#	base	base URL (absolute)
#	url	arbitrary URL
#
# Results:
#	Returns a URL

proc ::uri::resolve {base url} {
    if {[string length $url]} {
	if {[isrelative $url]} {

	    array set baseparts [split $base]

	    switch -- $baseparts(scheme) {
		http -
		https -
		ftp -
		file {
		    array set relparts [split $url]
		    if { [string match /* $url] } {
			catch { set baseparts(path) $relparts(path) }
		    } elseif { [string match */ $baseparts(path)] } {
			set baseparts(path) "$baseparts(path)$relparts(path)"
		    } else {
			if { [string length $relparts(path)] > 0 } {
			    set path [lreplace [::split $baseparts(path) /] end end]
			    set baseparts(path) "[::join $path /]/$relparts(path)"
			}
		    }
		    catch { set baseparts(query) $relparts(query) }
		    catch { set baseparts(fragment) $relparts(fragment) }
		    return [eval join [array get baseparts]]
		}
		default {
		    return -code error "unable to resolve relative URL \"$url\""
		}
	    }

	} else {
	    return $url
	}
    } else {
	return $base
    }
}

# ::uri::isrelative --
#
#	Determines whether a URL is absolute or relative
#
# Arguments:
#	url	URL to check
#
# Results:
#	Returns 1 if the URL is relative, 0 otherwise

proc ::uri::isrelative url {
    return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
}

# ::uri::geturl --
#
#	Fetch the data from an arbitrary URL.
#
#	This package provides a handler for the file:
#	scheme, since this conflicts with the file command.
#
# Arguments:
#	url	address of data resource
#	args	configuration options
#
# Results:
#	Depends on scheme

proc ::uri::geturl {url args} {
    array set urlparts [split $url]

    switch -- $urlparts(scheme) {
	file {
	    return [eval file_geturl [list $url] $args]
	}
	default {
	    # Load a geturl package for the scheme first and only if
	    # that fails the scheme package itself. This prevents
	    # cyclic dependencies between packages.
	    if {[catch {package require $urlparts(scheme)::geturl}]} {
		package require $urlparts(scheme)
	    }
	    return [eval [list $urlparts(scheme)::geturl $url] $args]
	}
    }
}

# ::uri::file_geturl --
#
#	geturl implementation for file: scheme
#
# TODO:
#	This is an initial, basic implementation.
#	Eventually want to support all options for geturl.
#
# Arguments:
#	url	URL to fetch
#	args	configuration options
#
# Results:
#	Returns data from file

proc ::uri::file_geturl {url args} {
    variable file:counter

    set var [namespace current]::file[incr file:counter]
    upvar #0 $var state
    array set state {data {}}

    array set parts [split $url]

    set ch [open $parts(path)]
    # Could determine text/binary from file extension,
    # except on Macintosh
    # fconfigure $ch -translation binary
    set state(data) [read $ch]
    close $ch

    return $var
}

# ::uri::join --
#
#	Format a URL
#
# Arguments:
#	args	components, key-value format
#
# Results:
#	A URL

proc ::uri::join args {
    array set components $args

    return [eval [list Join[string totitle $components(scheme)]] $args]
}

# ::uri::canonicalize --
#
#	Canonicalize a URL
#
# Acknowledgements:
#	Andreas Kupries, [email protected]
#
# Arguments:
#	uri	URI (which contains a path component)
#
# Results:
#	The canonical form of the URI

proc ::uri::canonicalize uri {

    # Make uri canonical with respect to dots (path changing commands)
    #
    # Remove single dots (.)  => pwd not changing
    # Remove double dots (..) => gobble previous segment of path
    #
    # Fixes for this command:
    #
    # * Ignore any url which cannot be split into components by this
    #   module. Just assume that such urls do not have a path to
    #   canonicalize.
    #
    # * Ignore any url which could be split into components, but does
    #   not have a path component.
    #
    # In the text above 'ignore' means
    # 'return the url unchanged to the caller'.

    if {[catch {array set u [uri::split $uri]}]} {
	return $uri
    }
    if {![info exists u(path)]} {
	return $uri
    }

    set uri $u(path)

    # Remove leading "./" "../" "/.." (and "/../")
    regsub -all -- {^(\./)+}    $uri {}  uri
    regsub -all -- {^/(\.\./)+} $uri {/} uri
    regsub -all -- {^(\.\./)+}  $uri {}  uri

    # Remove inner /./ and /../
    while {[regsub -all -- {/\./}         $uri {/} uri]} {}
    while {[regsub -all -- {/[^/]+/\.\./} $uri {/} uri]} {}
    while {[regsub -all -- {^[^/]+/\.\./} $uri {}  uri]} {}
    # Munge trailing /..
    while {[regsub -all -- {/[^/]+/\.\.} $uri {/} uri]} {}
    if { $uri == ".." } { set uri "/" }

    set u(path) $uri
    set uri [eval uri::join [array get u]]

    return $uri
}

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# regular expressions covering various url schemes

# Currently known URL schemes:
#
# (RFC 1738)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# ftp		//<user>:<password>@<host>:<port>/<cwd1>/.../<cwdN>/<name>;type=<typecode>
#
# http		//<host>:<port>/<path>?<searchpart>
#
# gopher	//<host>:<port>/<gophertype><selector>
#				<gophertype><selector>%09<search>
#		<gophertype><selector>%09<search>%09<gopher+_string>
#
# mailto	<rfc822-addr-spec>
# news		<newsgroup-name>
#		<message-id>
# nntp		//<host>:<port>/<newsgroup-name>/<article-number>
# telnet	//<user>:<password>@<host>:<port>/
# wais		//<host>:<port>/<database>
#		//<host>:<port>/<database>?<search>
#		//<host>:<port>/<database>/<wtype>/<wpath>
# file		//<host>/<path>
# prospero	//<host>:<port>/<hsoname>;<field>=<value>
# ------------------------------------------------
#
# (RFC 2111)
# ------------------------------------------------
# scheme	basic syntax of scheme specific part
# ------------------------------------------------
# mid	message-id
#		message-id/content-id
# cid	content-id
# ------------------------------------------------

# FTP
uri::register ftp {
    set escape [set [namespace parent [namespace current]]::basic::escape]
    set login  [set [namespace parent [namespace current]]::basic::login]

    variable	charN	{[a-zA-Z0-9$_.+!*'(,)?:@&=-]}
    variable	char	"(${charN}|${escape})"
    variable	segment	"${char}*"
    variable	path	"${segment}(/${segment})*"

    variable	type		{[AaDdIi]}
    variable	typepart	";type=(${type})"
    variable	schemepart	\
		    "//${login}(/${path}(${typepart})?)?"

    variable	url		"ftp:${schemepart}"
}

# FILE
uri::register file {
    set host [set [namespace parent [namespace current]]::basic::host]
    set path [set [namespace parent [namespace current]]::ftp::path]

    variable	schemepart	"//(${host}|localhost)?/${path}"
    variable	url		"file:${schemepart}"
}

# HTTP
uri::register http {
    set escape		[set [namespace parent [namespace current]]::basic::escape]
    set hostOrPort	[set [namespace parent [namespace current]]::basic::hostOrPort]

    variable	charN		{[a-zA-Z0-9$_.+!*'(,);:@&=-]}
    variable	char		"($charN|${escape})"
    variable	segment		"${char}*"

    variable	path		"${segment}(/${segment})*"
    variable	search		$segment
    variable	schemepart	\
	    "//${hostOrPort}(/${path}(\\?${search})?)?"

    variable	url		"http:${schemepart}"
}

# GOPHER
uri::register gopher {
    set xChar		[set [namespace parent [namespace current]]::basic::xChar]
    set hostOrPort	[set [namespace parent [namespace current]]::basic::hostOrPort]
    set search		[set [namespace parent [namespace current]]::http::search]

    variable	type		$xChar
    variable	selector	"$xChar*"
    variable	string		$selector
    variable	schemepart	\
	    "//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
    variable	url		"gopher:${schemepart}"
}

# MAILTO
uri::register mailto {
    set xChar	[set [namespace parent [namespace current]]::basic::xChar]
    set host	[set [namespace parent [namespace current]]::basic::host]

    variable	schemepart	"$xChar+(@${host})?"
    variable	url		"mailto:${schemepart}"
}

# NEWS
uri::register news {
    set escape		[set [namespace parent [namespace current]]::basic::escape]
    set alpha		[set [namespace parent [namespace current]]::basic::alpha]
    set host		[set [namespace parent [namespace current]]::basic::host]

    variable	aCharN		{[a-zA-Z0-9$_.+!*'(,);/?:&=-]}
    variable	aChar		"($aCharN|${escape})"
    variable	gChar		{[a-zA-Z0-9$_.+-]}
    variable	newsgroup-name	"${alpha}${gChar}*"
    variable	message-id	"${aChar}+@${host}"
    variable	schemepart	"\\*|${newsgroup-name}|${message-id}"
    variable	url		"news:${schemepart}"
}

# WAIS
uri::register wais {
    set uChar		[set [namespace parent [namespace current]]::basic::xChar]
    set hostOrPort	[set [namespace parent [namespace current]]::basic::hostOrPort]
    set search		[set [namespace parent [namespace current]]::http::search]

    variable	db		"${uChar}*"
    variable	type		"${uChar}*"
    variable	path		"${uChar}*"

    variable	database	"//${hostOrPort}/${db}"
    variable	index		"//${hostOrPort}/${db}\\?${search}"
    variable	doc		"//${hostOrPort}/${db}/${type}/${path}"

    #variable	schemepart	"${doc}|${index}|${database}"

    variable schemepart \
	    "//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"

    variable	url		"wais:${schemepart}"
}

# PROSPERO
uri::register prospero {
    set escape		[set [namespace parent [namespace current]]::basic::escape]
    set hostOrPort	[set [namespace parent [namespace current]]::basic::hostOrPort]
    set path		[set [namespace parent [namespace current]]::ftp::path]

    variable	charN		{[a-zA-Z0-9$_.+!*'(,)?:@&-]}
    variable	char		"(${charN}|$escape)"

    variable	fieldname	"${char}*"
    variable	fieldvalue	"${char}*"
    variable	fieldspec	";${fieldname}=${fieldvalue}"

    variable	schemepart	"//${hostOrPort}/${path}(${fieldspec})*"
    variable	url		"prospero:$schemepart"
}

package provide uri 1.1.2
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/uri/uri.test.

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

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}
set dirname [file dirname [info script]]
source      [file join $dirname uri.tcl]
package require uri

puts "uri [package present uri]"

# Take a key-value list and return list sorted by key, 
# but with corresponding values staying with their key
proc kvsort args {
    array set arr $args
    set result {}
    foreach key [lsort [array names arr]] {
	lappend result $key $arr($key)
    }
    return $result
}

# -------------------------------------------------------------------------
# Split tests

test uri-1.1 {uri::split - http w/- query} {
    eval kvsort [uri::split http://test.net/path/path2?query]
} {host test.net path path/path2 port {} query query scheme http}

test uri-1.2 {uri::split - https w/- query} {
    eval kvsort [uri::split https://test.net/path/path2?query]
} {host test.net path path/path2 port {} query query scheme https}

test uri-1.3 {uri::split - http w/- port} {
    eval kvsort [uri::split http://test.net:8080]
} {host test.net path {} port 8080 query {} scheme http}

test uri-1.4 {uri::split - https w/- port} {
    eval kvsort [uri::split https://test.net:8888]
} {host test.net path {} port 8888 query {} scheme https}

test uri-1.5 {uri::split - ftp} {
    eval kvsort [uri::split ftp://ftp.test.net/path/to/resource]
} {host ftp.test.net path path/to/resource port {} pwd {} scheme ftp type {} user {}}

test uri-1.6 {uri::split - ftp with userinfo} {
    eval kvsort [uri::split {ftp://user:passwd@localhost/a/b/c.d}]
} {host localhost path a/b/c.d port {} pwd passwd scheme ftp type {} user user}

test uri-1.7 {uri::split - ftp with type} {
    eval kvsort [uri::split {ftp://localhost/a/b/c.d;type=i}]
} {host localhost path a/b/c.d port {} pwd {} scheme ftp type i user {}}

test uri-1.8 {uri::split - ftp with port} {
    eval kvsort [uri::split {ftp://localhost:21/a/b/c.d}]
} {host localhost path a/b/c.d port 21 pwd {} scheme ftp type {} user {}}

test uri-1.9 {uri::split - news with message-id} {
    eval kvsort [uri::split {news:[email protected]}]
} {message-id [email protected] scheme news}

test uri-1.10 {uri::split - news with newsgroup-name} {
    eval kvsort [uri::split {news:comp.lang.tcl}]
} {newsgroup-name comp.lang.tcl scheme news}

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

test uri-2.1 {uri::join - http} {
    uri::join scheme http path / host www.w3.org
} http://www.w3.org/

test uri-2.2 {uri::join - https} {
    uri::join scheme https path / host www.w3.org
} https://www.w3.org/

test uri-2.3 {uri::join - http w/- query} {
    uri::join scheme http query abc=def&ghi=jkl host www.test.net path /path/
} http://www.test.net/path/?abc=def&ghi=jkl

test uri-2.4 {uri::join - https w/- query} {
    uri::join scheme https query abc=def&ghi=jkl host www.test.net path /path/
} https://www.test.net/path/?abc=def&ghi=jkl

test uri-2.5 {uri::join - http w/- port} {
    uri::join scheme http port 8080 host www.test.net path /path/
} http://www.test.net:8080/path/

test uri-2.6 {uri::join - https w/- port} {
    uri::join scheme https port 8888 host www.test.net path /path/
} https://www.test.net:8888/path/

test uri-2.7 {uri::join - ftp} {
    uri::join host ftp.test.net path /my/file scheme ftp
} ftp://ftp.test.net/my/file

test uri-2.8 {uri::join - identity function} {
    eval uri::join [uri::split http://www.w3.org/XML/?abc=def]
} http://www.w3.org/XML/?abc=def

test uri-2.9 {uri::join - ftp userinfo check} {
    eval uri::join scheme ftp host localhost port 21 path /filename user user pwd passwd
} {ftp://user:passwd@localhost:21/filename}

test uri-2.10 {uri::join - ftp userinfo check with no passwd} {
    eval uri::join scheme ftp host localhost path /filename user user
} {ftp://user@localhost/filename}

test uri-2.11 {uri::join - ftp path prefix} {
    eval uri::join scheme ftp host localhost path a/b/c.d
} ftp://localhost/a/b/c.d

test uri-2.12 {uri::join - ftp w/- image type} {
    eval uri::join scheme ftp host localhost path a/b/c.d type i
} {ftp://localhost/a/b/c.d;type=i}

test uri-2.13 {uri::join - ftp w/- ascii type} {
    eval uri::join scheme ftp host localhost path a/b/c.d type a
} {ftp://localhost/a/b/c.d;type=a}

# I am not sure that this shouldn't produce an error. The semi-colon is 
# reserved so in this case with an invalid suffix the semi-colon should
# probably be quoted. [PT]
test uri-2.14 {uri::join - ftp w/- invalid type} {
    eval uri::join scheme ftp host localhost path a/b/c.d type X
} {ftp://localhost/a/b/c.d;type=X}

test uri-2.15 {uri::join - news message-id} {
    eval uri::join scheme news message-id [email protected]
} {news:[email protected]}

test uri-2.16 {uri::join - news newsgroup-name} {
    eval uri::join scheme news newsgroup-name comp.lang.tcl
} {news:comp.lang.tcl}


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

test uri-3.1 {uri::resolve - relative URL, base trailing slash} {
    uri::resolve http://www.w3.org/path/ test.html
} http://www.w3.org/path/test.html

test uri-3.2 {uri::resolve - relative URL path, base trailing slash} {
    uri::resolve http://www.w3.org/path/ relpath/test.html
} http://www.w3.org/path/relpath/test.html

test uri-3.3 {uri::resolve - relative URL, base no trailing slash} {
    uri::resolve http://www.w3.org/path test.html
} http://www.w3.org/test.html

test uri-3.4 {uri::resolve - relative URL path, base no trailing slash} {
    uri::resolve http://www.w3.org/path relpath/test.html
} http://www.w3.org/relpath/test.html

test uri-3.5 {uri::resolve - relative URL w/- query} {
    uri::resolve http://www.w3.org/path/ test.html?abc=def
} http://www.w3.org/path/test.html?abc=def

test uri-3.6 {uri::resolve - absolute URL} {
    uri::resolve http://www.w3.org/path/ http://test.net/test.html
} http://test.net/test.html

test uri-3.7 {uri::resolve - two queries - one sans path} {
    uri::resolve http://www.example.com/foo/bar.rvt?foo=bar ?shoo=bee
} http://www.example.com/foo/bar.rvt?shoo=bee

test uri-3.8 {uri::resolve - two queries} {
    uri::resolve http://www.example.com/baz/?foo=bar ?shoo=bee
} http://www.example.com/baz/?shoo=bee

test uri-3.9 {uri::resolve - two absolute URL's with queries} {
    uri::resolve http://www.example.com/?foo=bar http://www.example.com/?shoo=bee
} http://www.example.com/?shoo=bee

test uri-3.10 {uri::resolve - two queries,
    one absolute URL, one absolute path} {
    uri::resolve http://www.example.com/baz?foo=bar /baz?shoo=bee
} http://www.example.com/baz?shoo=bee


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

test uri-4.1 {uri::geturl} {
    removeFile __testdata
    set data [info commands]
    set file [makeFile {} __testdata]
    set f [open $file w]
    puts -nonewline $f $data
    close $f

    set token [uri::geturl file://$file]
    string compare $data [set [subst $token](data)]
} 0

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

test uri-5.1-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/path1/./remove/../path2/resource
} http://www.test.net/path1/path2/resource

test uri-5.2-0 {uri::canonicalize infinite loop} {
    uri::canonicalize http://www.test.net/../path2/resource
} {http://www.test.net/path2/resource}

test uri-5.3-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/./path1/./remove/../path2/../resource
} http://www.test.net/path1/resource

test uri-5.4-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/./././path1/./remove/../path2/../resource
} http://www.test.net/path1/resource

test uri-5.5-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/./././path1/./remove/path2/../../resource
} http://www.test.net/path1/resource

test uri-5.6-0 {uri::canonicalize infinite loop} {
    uri::canonicalize http://www.test.net/../../../path2/resource
} {http://www.test.net/path2/resource}

test uri-5.7-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/path1/./remove/../path.html/resource
} http://www.test.net/path1/path.html/resource

test uri-5.8-0 {uri::canonicalize infinite loop} {
    uri::canonicalize http://www.test.net/../path.html/resource
} {http://www.test.net/path.html/resource}

test uri-5.9-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/./path1/./remove/../path.html/../resource
} http://www.test.net/path1/resource

test uri-5.10-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/./././path1/./remove/../path.html/../resource
} http://www.test.net/path1/resource

test uri-5.11-0 {uri::canonicalize} {
    uri::canonicalize http://www.test.net/./././path1/./remove/path.html/../../resource
} http://www.test.net/path1/resource

test uri-5.12-0 {uri::canonicalize infinite loop} {
    uri::canonicalize http://www.test.net/../../../path.html/resource
} {http://www.test.net/path.html/resource}

test uri-5.13-0 {uri::canonicalize} {
    uri::canonicalize http://www.eldritchpress.org/jc/../help.html
} {http://www.eldritchpress.org/help.html}

test uri-5.14-0 {uri::canonicalize trailing ..} {
    uri::canonicalize http://www.example.com/foo/bar/..
} {http://www.example.com/foo/}

test uri-5.14-0 {uri::canonicalize trailing ..} {
    uri::canonicalize http://www.example.com/..
} {http://www.example.com/}

test uri-5.1-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/path1/./remove/../path2/resource
} ftp://ftp.test.net/path1/path2/resource

test uri-5.2-1 {uri::canonicalize infinite loop} {
    uri::canonicalize ftp://ftp.test.net/../path2/resource
} {ftp://ftp.test.net/path2/resource}

test uri-5.3-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/./path1/./remove/../path2/../resource
} ftp://ftp.test.net/path1/resource

test uri-5.4-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/./././path1/./remove/../path2/../resource
} ftp://ftp.test.net/path1/resource

test uri-5.5-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/./././path1/./remove/path2/../../resource
} ftp://ftp.test.net/path1/resource

test uri-5.6-1 {uri::canonicalize infinite loop} {
    uri::canonicalize ftp://ftp.test.net/../../../path2/resource
} {ftp://ftp.test.net/path2/resource}

test uri-5.7-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/path1/./remove/../path.html/resource
} ftp://ftp.test.net/path1/path.html/resource

test uri-5.8-1 {uri::canonicalize infinite loop} {
    uri::canonicalize ftp://ftp.test.net/../path.html/resource
} {ftp://ftp.test.net/path.html/resource}

test uri-5.9-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/./path1/./remove/../path.html/../resource
} ftp://ftp.test.net/path1/resource

test uri-5.10-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/./././path1/./remove/../path.html/../resource
} ftp://ftp.test.net/path1/resource

test uri-5.11-1 {uri::canonicalize} {
    uri::canonicalize ftp://ftp.test.net/./././path1/./remove/path.html/../../resource
} ftp://ftp.test.net/path1/resource

test uri-5.12-1 {uri::canonicalize infinite loop} {
    uri::canonicalize ftp://ftp.test.net/../../../path.html/resource
} {ftp://ftp.test.net/path.html/resource}

test uri-5.1-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/path1/./remove/../path2/resource
} file://goo.test.net/path1/path2/resource

test uri-5.2-2 {uri::canonicalize infinite loop} {
    uri::canonicalize file://goo.test.net/../path2/resource
} {file://goo.test.net/path2/resource}

test uri-5.3-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/./path1/./remove/../path2/../resource
} file://goo.test.net/path1/resource

test uri-5.4-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/./././path1/./remove/../path2/../resource
} file://goo.test.net/path1/resource

test uri-5.5-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/./././path1/./remove/path2/../../resource
} file://goo.test.net/path1/resource

test uri-5.6-2 {uri::canonicalize infinite loop} {
    uri::canonicalize file://goo.test.net/../../../path2/resource
} {file://goo.test.net/path2/resource}

test uri-5.7-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/path1/./remove/../path.html/resource
} file://goo.test.net/path1/path.html/resource

test uri-5.8-2 {uri::canonicalize infinite loop} {
    uri::canonicalize file://goo.test.net/../path.html/resource
} {file://goo.test.net/path.html/resource}

test uri-5.9-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/./path1/./remove/../path.html/../resource
} file://goo.test.net/path1/resource

test uri-5.10-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/./././path1/./remove/../path.html/../resource
} file://goo.test.net/path1/resource

test uri-5.11-2 {uri::canonicalize} {
    uri::canonicalize file://goo.test.net/./././path1/./remove/path.html/../../resource
} file://goo.test.net/path1/resource

test uri-5.12-2 {uri::canonicalize infinite loop} {
    uri::canonicalize file://goo.test.net/../../../path.html/resource
} {file://goo.test.net/path.html/resource}

test uri-5.1-3 {uri::canonicalize} {
    uri::canonicalize file:///path1/./remove/../path2/resource
} file:///path1/path2/resource

test uri-5.2-3 {uri::canonicalize infinite loop} {
    uri::canonicalize file:///../path2/resource
} {file:///path2/resource}

test uri-5.3-3 {uri::canonicalize} {
    uri::canonicalize file:///./path1/./remove/../path2/../resource
} file:///path1/resource

test uri-5.4-3 {uri::canonicalize} {
    uri::canonicalize file:///./././path1/./remove/../path2/../resource
} file:///path1/resource

test uri-5.5-3 {uri::canonicalize} {
    uri::canonicalize file:///./././path1/./remove/path2/../../resource
} file:///path1/resource

test uri-5.6-3 {uri::canonicalize infinite loop} {
    uri::canonicalize file:///../../../path2/resource
} {file:///path2/resource}

test uri-5.7-3 {uri::canonicalize} {
    uri::canonicalize file:///path1/./remove/../path.html/resource
} file:///path1/path.html/resource

test uri-5.8-3 {uri::canonicalize infinite loop} {
    uri::canonicalize file:///../path.html/resource
} {file:///path.html/resource}

test uri-5.9-3 {uri::canonicalize} {
    uri::canonicalize file:///./path1/./remove/../path.html/../resource
} file:///path1/resource

test uri-5.10-3 {uri::canonicalize} {
    uri::canonicalize file:///./././path1/./remove/../path.html/../resource
} file:///path1/resource

test uri-5.11-3 {uri::canonicalize} {
    uri::canonicalize file:///./././path1/./remove/path.html/../../resource
} file:///path1/resource

test uri-5.12-3 {uri::canonicalize infinite loop} {
    uri::canonicalize file:///../../../path.html/resource
} {file:///path.html/resource}

test uri-6.0 {uri::canonicalize} {
    uri::canonicalize telnet://goo.test.net/
} telnet://goo.test.net/

test uri-7.0 {uri::split & uri::join} {
    set ls [uri::split http://tcl.apache.org/websh/faq.ws3\#generic?foo=bar]
    eval uri::join $ls
} {http://tcl.apache.org/websh/faq.ws3#generic?foo=bar}

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

test uri-8.0 {uri::split bug #676976, ill. char in scheme} {
    set ls [uri::split ht,tp://tcl.apache.org/websh]
    eval uri::join $ls
} {http:///ht,tp://tcl.apache.org/websh}

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


::tcltest::cleanupTests
return

# -------------------------------------------------------------------------
# Local Variables:
#   mode: tcl
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted modules/uri/urn-scheme.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
# urn-scheme.tcl - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# extend the uri package to deal with URN (RFC 2141)
# see http://www.normos.org/ietf/rfc/rfc2141.txt
#
# Released under the tcllib license.
#
# $Id: urn-scheme.tcl,v 1.5 2003/04/11 00:50:37 andreas_kupries Exp $
# -------------------------------------------------------------------------

package provide uri::urn 1.0.1
package require uri      1.1.2

namespace eval ::uri {}
namespace eval ::uri::urn {}

::uri::register {urn URN} {
	variable NIDpart {[a-zA-Z0-9][a-zA-Z0-9-]{0,31}}
        variable esc {%[0-9a-fA-F]{2}}
        variable trans {a-zA-Z0-9$_.+!*'(,):=@;-}
        variable NSSpart "($esc|\[$trans\])+"
        variable URNpart "($NIDpart):($NSSpart)"
        variable schemepart $URNpart
	variable url "urn:$NIDpart:$NSSpart"
}

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

# Description:
#   Called by uri::split with a url to split into its parts.
#
proc ::uri::SplitUrn {uri} {
    #@c Split the given uri into then URN component parts
    #@a uri: the URI to split without it's scheme part.
    #@r List of the component parts suitable for 'array set'

    upvar \#0 [namespace current]::urn::URNpart pattern
    array set parts {nid {} nss {}}
    if {[regexp -- ^$pattern $uri -> parts(nid) parts(nss)]} {
        return [array get parts]
    } else {
        error "invalid urn syntax: \"$uri\" could not be parsed"
    }
}


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

proc ::uri::JoinUrn args {
    #@c Join the parts of a URN scheme URI
    #@a list of nid value nss value
    #@r a valid string representation for your URI
    variable urn::NIDpart

    array set parts [list nid {} nss {}]
    array set parts $args
    if {! [regexp -- ^$NIDpart$ $parts(nid)]} {
        error "invalid urn: nid is invalid"
    }
    set url "urn:$parts(nid):[urn::quote $parts(nss)]"
    return $url
}

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

# Quote the disallowed characters according to the RFC for URN scheme.
# ref: RFC2141 sec2.2
proc ::uri::urn::quote {url} {
    variable trans

    set ndx 0
    while {[regexp -start $ndx -indices -- "\[^$trans\]" $url r]} {
        set ndx [lindex $r 0]
        scan [string index $url $ndx] %c chr
        set rep %[format %.2X $chr]
        if {[string match $rep %00]} {
            error "invalid character: character $chr is not allowed"
        }
        set url [string replace $url $ndx $ndx $rep]
        incr ndx 3
    }
    return $url
}

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

# Perform the reverse of urn::quote.
proc ::uri::urn::unquote {url} {
    set ndx 0
    while {[regexp -start $ndx -indices {%([0-9a-zA-Z]{2})} $url r]} {
        set first [lindex $r 0]
        set last [lindex $r 1]
        set str [string replace [string range $url $first $last] 0 0 0x]
        set c [format %c $str]
        set url [string replace $url $first $last $c]
        set ndx [expr {$last + 1}]
    }
    return $url
}

# -------------------------------------------------------------------------
# Local Variables:
#   indent-tabs-mode: nil
# End:
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































































































Deleted modules/uri/urn.test.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
# urn.test - Copyright (C) 2001 Pat Thoyts <[email protected]>
#
# Provide a set of tests to excercise the urn-scheme package.
#
# @(#)$Id: urn.test,v 1.2 2001/11/03 01:12:58 patthoyts Exp $

# Initialize the required packages

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
    #source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[catch {package require uri}]} {
    catch {puts stderr "Cannot load the URI package"}
    return
}

if {[catch {package require uri::urn}]} {
    catch {puts stderr "Failed to source the URN scheme extension"}
    return
}

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

# Tests to check for valid urn sections.

test urn-1.1 {Check basic split} {
    catch {uri::split urn:tcl:test} result
    set result
} {nss test scheme urn nid tcl}

test urn-1.2 {Check basic join} {
    catch {uri::join scheme urn nid tcl nss test} result
    set result
} {urn:tcl:test}

test urn-1.3 {Split permissible NID} {
    catch {uri::split urn:tcl-TCL-0123456789:test} result
    set result
} {nss test scheme urn nid tcl-TCL-0123456789}

test urn-1.4 {Join permissible NID} {
    catch {uri::join scheme urn nid tcl-TCL-0123456789 nss test} result
    set result
} {urn:tcl-TCL-0123456789:test}

test urn-1.5 {Split permissible NSS} {
    catch {uri::split {urn:tcl:Test-0123456789()+,-.:=@;$_!*'}} result
    set result
} {nss {Test-0123456789()+,-.:=@;$_!*'} scheme urn nid tcl}

test urn-1.6 {Join permissible NSS} {
    catch {uri::join scheme urn nid tcl nss {Test-0123456789()+,-.:=@;$_!*'}} result
    set result
} {urn:tcl:Test-0123456789()+,-.:=@;$_!*'}

# -------------------------------------------------------------------------
# Now some tests that should fail.

test urn-2.1 {NID too long} {
    set nid ThisURNNIDparthastoomanycharacters
    set nss test
    if {[catch {uri:split urn:$nid:$nss} result]} {
        set result ok
    }
    set result
} {ok}

test urn-2.2 {NID too long} {
    set nid ThisURNNIDparthastoomanycharacters
    set nss test
    if {[catch {uri:join scheme urn nid $nid nss $nss} result]} {
        set result ok
    }
    set result
} {ok}

test urn-2.3 {NID containing invalid characters} {
    set nid {This-NID//notOK}
    set nss test
    if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
        set result ok
    }
    set result
} {ok}

test urn-2.4 {NID containing no characters} {
    set nid {}
    set nss test
    if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
        set result ok
    }
    set result
} {ok}

test urn-2.5 {NID beginning with hyphen} {
    set nid {-notvalid}
    set nss test
    if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
        set result ok
    }
    set result
} {ok}


# Check the Namespace Specific String.

test urn-3.1 {NSS containing reserved characters} {
    set nid {tcl}
    set nss {%}
    catch {uri::join scheme urn nid $nid nss $nss} result
    set result
} {urn:tcl:%25}

test urn-3.2 {NSS containing reserved characters} {
    set nid {tcl}
    set nss {/?#}
    catch {uri::join scheme urn nid $nid nss $nss} result
    set result
} {urn:tcl:%2F%3F%23}

test urn-3.3 {NSS containing reserved characters} {
    set nid {tcl}
    set nss {urn-test}
    catch {uri::join scheme urn nid $nid nss $nss} result
    set result
} {urn:tcl:urn-test}

test urn-3.4 {NSS containing illegal characters} {
    set nid {tcl}
    set nss "\u00" ;# 0 is the only character explicitly denied.
    if {[catch {uri::join scheme urn nid $nid nss $nss} result]} {
        set result ok
    }
    set result
} {ok}

# -------------------------------------------------------------------------
# Clean up the tests

::tcltest::cleanupTests
return

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










































































































































































































































































































Deleted sak.tcl.

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

# --------------------------------------------------------------
# Perform various checks and operations on the distribution.
# SAK = Swiss Army Knife.

set distribution   [file dirname [info script]]
lappend auto_path  [file join $distribution modules]

source [file join $distribution tcllib_version.tcl] ; # Get version information.

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

proc tclfiles {} {
    global distribution
    package require fileutil
    set fl [fileutil::findByPattern $distribution -glob *.tcl]
    proc tclfiles {} [list return $fl]
    return $fl
}

proc modules {} {
    global distribution
    set fl [list]
    foreach f [glob -nocomplain [file join $distribution modules *]] {
	if {![file isdirectory $f]} {continue}
	if {[string match CVS [file tail $f]]} {continue}
	lappend fl [file tail $f]
    }
    proc modules {} [list return $fl]
    return $fl
}

proc sep {} {puts ~~~~~~~~~~~~~~~~~~~~~~~~}

proc gendoc {fmt ext {mode user} {flags {}}} {
    global distribution

    set mpe [file join $distribution modules doctools mpexpand]
    set ::env(TCLLIBPATH) [file join $distribution modules]

    foreach m [modules] {
	switch -exact -- $mode {
	    user   {set fl [glob -nocomplain [file join $distribution modules $m *.man]]}
	    dev    {set fl [glob -nocomplain [file join $distribution modules $m *.dev.man]]}
	    all    {set fl [glob -nocomplain [file join $distribution modules $m *.man]]}
	    single {set fl [list ]}
	    default {return -code error "Invalid mode $mode"}
	}
	if {[llength $fl] == 0} {continue}
	file mkdir [file join doc $fmt]

	if {$flags == {}} {
	    foreach f $fl {
		puts "Gen ($fmt): $f"
		if {[catch {
		    exec \
			[list $mpe] -module [list $m] \
			$fmt [list $f] [list [file join doc $fmt [file rootname [file tail $f]].$ext]] \
			>@ stdout 2>@ stderr
		} msg]} {
		    puts $msg
		}
	    }
	} else {
	    foreach f $fl {
		puts "Gen ($fmt): $f"
		if {[catch {
		    exec \
			[list $mpe] -module [list $m] \
			$flags \
			$fmt [list $f] [list [file join doc $fmt [file rootname [file tail $f]].$ext]] \
			>@ stdout 2>@ stderr
		} msg]} {
		    puts $msg
		}
	    }
	}
    }
}


proc gd-cleanup {} {
    global tcllib_version

    puts {Cleaning up...}

    set        fl [glob -nocomplain tcllib-${tcllib_version}*]
    foreach f $fl {
	puts "    Deleting $f ..."
	catch {file delete -force $f}
    }
    return
}

proc gd-gen-archives {} {
    global tcllib_version

    puts {Generating archives...}

    puts "    Gzipped tarball (tcllib-${tcllib_version}.tar.gz)..."
    exec tar cf - tcllib-${tcllib_version} | gzip --best > tcllib-${tcllib_version}.tar.gz 

    puts "    Zip archive     (tcllib-${tcllib_version}.zip)..."
    exec zip -r   tcllib-${tcllib_version}.zip             tcllib-${tcllib_version}

    set bzip [auto_execok bzip2]
    if {$bzip != {}} {
	puts "    Bzipped tarball (tcllib-${tcllib_version}.tar.bz2)..."
	exec tar cf - tcllib-${tcllib_version} | bzip2 > tcllib-${tcllib_version}.tar.bz2
    }

    set sdx [auto_execok sdx]
    if {$sdx != {}} {
	file rename tcllib-${tcllib_version} tcllib.vfs

	puts "    Starkit         (tcllib-${tcllib_version}.kit)..."
	exec sdx wrap tcllib
	file rename   tcllib tcllib-${tcllib_version}.kit

	if {![file exists tclkit]} {
	    puts "    No tclkit present in current working directory, no starpack."
	} else {
	    puts "    Starpack        (tcllib-${tcllib_version}.exe)..."
	    exec sdx wrap tcllib -runtime tclkit
	    file rename   tcllib tcllib-${tcllib_version}.exe
	}

	file rename tcllib.vfs tcllib-${tcllib_version}
    }

    puts {    Keeping directory for other archive types}

    ## Keep the directory for 'sdx' - kit/pack
    return
}

proc xcopy {src dest recurse {pattern *}} {
    file mkdir $dest
    foreach file [glob [file join $src $pattern]] {
        set base [file tail $file]
	set sub  [file join $dest $base]

	# Exclude CVS automatically, and possibly the temp hierarchy
	# itself too.

	if {0 == [string compare CVS $base]} {continue}
	if {[string match tcllib-*   $base]} {continue}
	if {[string match *~         $base]} {continue}

        if {[file isdirectory $file]} then {
	    if {$recurse} {
		file mkdir  $sub
		xcopy $file $sub $recurse $pattern
	    }
        } else {
	    puts -nonewline stdout . ; flush stdout

            file copy -force $file $sub
        }
    }
}

proc gd-assemble {} {
    global tcllib_version distribution

    puts "Assembling distribution in directory 'tcllib-${tcllib_version}'"

    xcopy $distribution tcllib-${tcllib_version} 1
    file delete -force \
	    tcllib-${tcllib_version}/config \
	    tcllib-${tcllib_version}/modules/ftp/example \
	    tcllib-${tcllib_version}/modules/ftpd/examples \
	    tcllib-${tcllib_version}/modules/stats \
	    tcllib-${tcllib_version}/modules/fileinput
    puts ""
    return
}

proc validate_testsuites {} {
    global distribution
    foreach m [modules] {
	if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} {
	    puts "  Without testsuite : $m"
	}
    }
    return
}

proc validate_pkgIndex {} {
    global distribution
    foreach m [modules] {
	if {[llength [glob -nocomplain [file join $distribution modules $m pkgIndex.tcl]]] == 0} {
	    puts "  Without package index : $m"
	}
    }
    return
}

proc validate_doc_existence {} {
    global distribution
    foreach m [modules] {
	if {[llength [glob -nocomplain [file join $distribution modules $m {*.[13n]}]]] == 0} {
	    if {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} {
		puts "  Without * any ** manpages : $m"
	    }
	} elseif {[llength [glob -nocomplain [file join $distribution modules $m {*.man}]]] == 0} {
	    puts "  Without doctools manpages : $m"
	} else {
	    foreach f [glob -nocomplain [file join $distribution modules $m {*.[13n]}]] {
		if {![file exists [file rootname $f].man]} {
		    puts "     no .man equivalent : $f"
		}
	    }
	}
    }
    return
}


proc validate_doc_markup {} {
    gendoc null null user -deprecated
    file delete -force [file join doc null]
    return
}


proc run-frink {} {
    global distribution
    foreach f [tclfiles] {
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	puts "$f..."
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	catch {exec frink 2>@ stderr -H $f}
    }
    return
}

proc run-procheck {} {
    global distribution
    foreach f [tclfiles] {
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	puts "$f ..."
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	catch {exec procheck >@ stdout $f}
    }
    return
}

# --------------------------------------------------------------
# Help

proc __help {} {
    puts stdout {
	Commands avalable through the swiss army knife aka SAK:

	help     - This help

	/Configuration
	version  - Return tcllib version number
	major    - Return tcllib major version number
	minor    - Return tcllib minor version number
	name     - Return tcllib package name

	/Development
	modules          - Return list of modules.
	validate         - Check various parts of tcllib for problems.
	test ?module...? - Run testsuite for listed modules.
	                   For all modules if none specified.

	/Release engineering
	gendist  - Generate distribution from CVS snapshot

	/Documentation
	nroff    - Generate manpages
	html     - Generate HTML pages
	tmml     - Generate TMML
	list     - Generate a list of manpages
	wiki     - Generate wiki markup
	latex    - Generate LaTeX pages
	dvi      - See latex, + conversion to dvi
	ps       - See dvi,   + conversion to PostScript
    }
}

# --------------------------------------------------------------
# Configuration

proc __name    {} {global tcllib_name    ; puts $tcllib_name}
proc __version {} {global tcllib_version ; puts $tcllib_version}
proc __minor   {} {global tcllib_version ; puts [lindex [split $tcllib_version .] 1]}
proc __major   {} {global tcllib_version ; puts [lindex [split $tcllib_version .] 0]}

# --------------------------------------------------------------
# Development

proc __modules {} {puts [modules]}


proc __test {} {
    global argv distribution
    # Run testsuite

    set modules $argv
    if {[llength $modules] == 0} {
	set modules [modules]
    }

    exec [info nameofexecutable] \
	    [file join $distribution all.tcl] \
	    -modules $modules \
	    >@ stdout 2>@ stderr
    return
}



proc __validate {} {
    global tcllib_name tcllib_version
    set i 0

    puts "Validating $tcllib_name $tcllib_version development"
    puts "==================================================="
    puts "[incr i]: Existence of testsuites ..."
    puts "------------------------------------------------------"
    validate_testsuites
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Existence of package indices ..."
    puts "------------------------------------------------------"
    validate_pkgIndex
    puts "------------------------------------------------------"
    puts ""


    puts "[incr i]: Existence of documentation ..."
    puts "------------------------------------------------------"
    validate_doc_existence
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Validate documentation markup (doctools) ..."
    puts "------------------------------------------------------"
    validate_doc_markup
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Static syntax check ..."
    puts "------------------------------------------------------"

    set frink    [auto_execok frink]
    set procheck [auto_execok procheck]

    if {$frink    == {}} {puts "  Tool 'frink'    not found, no check"}
    if {$procheck == {}} {puts "  Tool 'procheck' not found, no check"}
    if {($frink == {}) || ($procheck == {})} {
	puts "------------------------------------------------------"
    }
    if {($frink == {}) && ($procheck == {})} {
	return
    }
    if {$frink    != {}} {
	run-frink
	puts "------------------------------------------------------"
    }
    if {$procheck    != {}} {
	run-procheck
	puts "------------------------------------------------------"
    }
    puts ""

    return
}


# --------------------------------------------------------------
# Release engineering

proc __gendist {} {
    gd-cleanup
    gd-assemble
    gd-gen-archives

    puts ...Done
    return
}

# --------------------------------------------------------------
# Documentation

proc __html  {} {gendoc html  html}
proc __nroff {} {gendoc nroff n}
proc __tmml  {} {gendoc tmml  tmml}
proc __wiki  {} {gendoc wiki  wiki}
proc __latex {} {gendoc latex tex}
proc __dvi   {} {
    __latex
    file mkdir [file join doc dvi]
    cd         [file join doc dvi]
    foreach f [glob -nocomplain ../latex/*.tex] {
	puts "Gen (dvi): $f"
	exec latex $f 1>@ stdout 2>@ stderr
    }
    cd ../..
}
proc __ps   {} {
    __dvi
    file mkdir [file join doc ps]
    cd         [file join doc ps]
    foreach f [glob -nocomplain ../dvi/*.dvi] {
	puts "Gen (dvi): $f"
	exec dvips -o [file rootname [file tail $f]].ps $f 1>@ stdout 2>@ stderr
    }
    cd ../..
}

proc __list  {} {
    gendoc list l
    exec cat [glob -nocomplain doc/list/*.l] > doc/list/manpages.tcl
    eval file delete -force [glob -nocomplain doc/list/*.l]
    return
}

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

set cmd [lindex $argv 0]
if {[llength [info procs __$cmd]] == 0} {
    puts stderr "unknown command $cmd"
    set fl {}
    foreach p [lsort [info procs __*]] {
	lappend fl [string range $p 2 end]
    }
    puts stderr "use: [join $fl ", "]"
    exit 1
}

set  argv [lrange $argv 1 end]
incr argc -1

__$cmd
exit 0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted tcllib_version.tcl.

1
2
set tcllib_version 1.4
set tcllib_name    tcllib
<
<