TaoLib

Check-in [7c1b4765ca]
Login

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

Overview
Comment:Replaced sak with Practcl installation manager
Timelines: family | ancestors | descendants | both | clay
Files: files | file ages | folders
SHA1:7c1b4765ca03cf8d711c585b5a0a8589f7bbd788
User & Date: hypnotoad 2018-10-24 00:13:07
Context
2018-10-30
23:28
Updated clay and httpd from tcllib Leaf check-in: c0972ee07c user: hypnotoad tags: clay
2018-10-24
00:13
Replaced sak with Practcl installation manager check-in: 7c1b4765ca user: hypnotoad tags: clay
2018-10-16
15:28
Added an annotation capacity to practcl, which allows the doctools generator to read and document class variables, options, and delegates. Added missing documentation to httpd. New version of clay which adds a new "branch" method to oo::class/oo::object's clay ensemble. The branch method tells the system to mark the designated address as a branch, even it empty. Fixed a bug in clay where a Dict or Array keyword with no values would fail to actually register in the clay system check-in: db5edcaf33 user: hypnotoad tags: clay
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Deleted ChangeLog.

1
2
2014-11-14 Sean Woods <yoda@etoyoc.com>
	* Began assembling taolib by mimicing the structure of tcllib
<
<




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
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
# 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.101 2007/08/21 22:04:14 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@
bindir		= @bindir@

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:
doc:     html-doc nroff-doc

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

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

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

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

test:
	if test -t 1 ; \
	then $(MAKE) test_interactive ; \
	else $(MAKE) test_batch ; \
	fi

test_batch:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test run -v -s "$(TCLSH_PROG)"

test_interactive:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` test run -s "$(TCLSH_PROG)"

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

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

clean:

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` doc html
nroff-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc nroff
tmml-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc tmml
wiki-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc wiki
latex-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc ps
list-doc:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/sak.tcl` doc list

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

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

shed:
	$(TCLSH_PROG) `$(CYGPATH) $(srcdir)/../sherpa/sherpa.tcl` shed generate `pwd`

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

# 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 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*|*MSYS*)
	    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 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
32
33
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

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

SAK=`$CYGPATH ${srcdir}/sak.tcl`

PACKAGE=`$TCLSH_PROG "${SAK}" name`
MAJOR_VERSION=`$TCLSH_PROG "${SAK}" major`
MINOR_VERSION=`$TCLSH_PROG "${SAK}" minor`
PATCHLEVEL=""

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

AC_SUBST(PACKAGE)
AC_SUBST(VERSION)

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

AC_OUTPUT([Makefile])
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































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
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
#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}

# --------------------------------------------------------------
# Installer for Tcllib. The lowest version of the tcl core supported
# by any module is 8.2. So we enforce that the installer is run with
# at least that.

package require Tcl 8.2

set distribution   [file dirname [info script]]
lappend auto_path  [file join $distribution modules]


# --------------------------------------------------------------
# Version information for tcllib.
# List of modules to install (and definitions guiding the process)

proc package_name    {text} {global package_name    ; set package_name    $text}
proc package_version {text} {global package_version ; set package_version $text}
proc dist_exclude    {path} {}
proc critcl       {name files} {}
proc critcl_main  {name files} {}
proc critcl_notes {text} {}

source [file join $distribution support installation version.tcl] ; # Get version information.
source [file join $distribution support installation modules.tcl] ; # Get list of installed modules.
source [file join $distribution support installation actions.tcl] ; # Get code to perform install actions.

set package_nv ${package_name}-${package_version}
set package_name_cap [string toupper [string index $package_name 0]][string range $package_name 1 end]

# --------------------------------------------------------------
# Low-level commands of the installation engine.

###
# topic: 003ce0c0d69b74076e8433492deac920
# description:
#    Descends into a directory structure, returning
#    a list of items found in the form of:
#    type object
#    where type is one of: csource source parent_name
#    and object is the full path to the file
###
proc ::sniffPath {spath stackvar} {
  upvar 1 $stackvar stack
  set result {}
  if { ![file isdirectory $spath] } {
    switch [file extension $spath] {
      .tm {
        return [list parent_name $spath]
      }
      .tcl {
        return [list source $spath]
      }
      .h {
        return [list cheader $spath]
      }
      .c {
        return [list csource $spath]
      }
    }
    return
  }
  foreach f [glob -nocomplain $spath/*] {
    if {[file isdirectory $f]} {
      if {[file tail $f] in {CVS build} } continue
      if {[file extension $f] eq ".vfs" } continue
      set stack [linsert $stack 0 $f]
    }
  }
  set idx 0
  if {[file exists [set fname [file join $spath pkgIndex.tcl]]]} {
    if {[pkgindex_is_special $fname]} {
      lappend result index $fname
    }
  }
  if {[file exists [set fname [file join $spath tclIndex]]]} {
    lappend result index $fname
  }
  if {[llength $result]} {
    return $result
  }
  foreach f [glob -nocomplain $spath/*] {
    if {![file isdirectory $f]} {
      set stack [linsert $stack 0 $f]
    }
  }
  return {}
}

proc ::pkgindex_is_special pkgidxfile {
  set fin [open $pkgidxfile r]
  set dat [read $fin]
  close $fin
  set thisline {}
  foreach line [split $dat \n] {
    append thisline $line \n
    if {![info complete $thisline]} continue
    set line [string trim $line]
    if {[string length $line]==0} {
      set thisline {} ; continue
    }
    if {[string index $line 0] eq "#"} {
      set thisline {} ; continue
    }
    if {[lindex $line 0] != "package"} {return 1}
    if {[lindex $line 1] != "ifneeded"} {return 1}
    set thisline {}
  }
  return 0
}


###
# topic: 929629f0ebaa554710f66410dfa51f8a
###
proc ::pkgindex_path base {
  set stack {}
  set buffer {}
  set base [file normalize $base]
  set i    [string length  $base]
  set result [::sniffPath $base stack]
  while {[llength $stack]} {
    set stackpath [lindex $stack 0]
    set stack [lrange $stack 1 end]
    lappend result {*}[::sniffPath $stackpath stack]
  }
  foreach {type file} $result {
    switch $type {
      parent_name {
        set file [file normalize $file]
        set fname [file rootname [file tail $file]]
        ###
        # Assume the package is correct in the filename
        ###
        set package [lindex [split $fname -] 0]
        set version [lindex [split $fname -] 1]
        set path [string trimleft [string range [file dirname $file] $i end] /]
        ###
        # Read the file, and override assumptions as needed
        ###
        set fin [open $file r]
        set dat [read $fin]
        close $fin
        foreach line [split $dat \n] {
          set line [string trim $line]
          if { [string range $line 0 9] != "# Package " } continue
          set package [lindex $line 2]
          set version [lindex $line 3]
          break
        }
        append buffer "package ifneeded $package $version \[list source \[file join \$BASE $path [file tail $file]\]\]"
        append buffer \n
      }
      source {
        set file [file normalize $file]
        if { $file == [file join $base tcl8.6 package.tcl] } continue
        if { $file == [file join $base packages.tcl] } continue
        if { $file == [file join $base main.tcl] } continue
        if { [file tail $file] == "version_info.tcl" } continue
        set fin [open $file r]
        set dat [read $fin]
        close $fin
        if {![regexp "package provide" $dat]} continue
        set fname [file rootname [file tail $file]]
        set dir [string trimleft [string range [file dirname $file] $i end] /]

        foreach line [split $dat \n] {
          set line [string trim $line]
          if { [string range $line 0 14] != "package provide" } continue
          set package [lindex $line 2]
          set version [lindex $line 3]
          append buffer "package ifneeded $package $version \[list source \[file join \$BASE $dir [file tail $file]\]\]"
          append buffer \n
          break
        }
      }
      index {
        if {[file dirname $file] eq $base } continue
        set dir [string trimleft [string range [file dirname $file] $i end] /]
        append buffer "set dir \[file join \$BASE $dir\] \; source \[file join \$BASE $dir [file tail $file]\]"
        append buffer \n
      }
    }
  }
  return $buffer
}

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}
# Here are equivalent contents
# of the pkgIndex.tcl files of all the modules

}
    puts $index ""
    puts $index "set BASE \$dir"
    puts $index [::pkgindex_path $outdir]
    puts  $index "unset BASE"
    puts  $index ""
    close $index
    return
}

proc xcopyfile {src dest} {
    # dest can be dir or file
    run file copy -force $src $dest
    return
}

proc xcopy {src dest recurse {pattern *}} {
    run file mkdir $dest

    if {[string equal $pattern *] || !$recurse} {
	foreach file [glob -nocomplain [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

		    # If the directory is empty after the recursion remove it again.
		    if {![llength [glob -nocomplain [file join $sub *]]]} {
			file delete $sub
		    }
		}
	    } else {
		xcopyfile $file $sub
	    }
	}
    } else {
	foreach file [glob [file join $src *]] {
	    set base [file tail $file]
	    set sub  [file join $dest $base]

	    if {[string equal CVS $base]} {continue}

	    if {[file isdirectory $file]} then {
		if {$recurse} {
		    run file mkdir $sub
		    xcopy $file $sub $recurse $pattern

		    # If the directory is empty after the recursion remove it again.
		    if {![llength [glob -nocomplain [file join $sub *]]]} {
			run file delete $sub
		    }
		}
	    } else {
		if {![string match $pattern $base]} {continue}
		xcopyfile $file $sub
	    }
	}
    }
}

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}
    catch {file delete -force $f}
    puts -nonewline [set of [open $f w]] $text
    close $of
}


# --------------------------------------------------------------
# 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
    }
    if {[catch {eval $args} msg]} {
        if {$config(gui)} {
            installErrorMsgBox $msg
        } else {
            return -code error "Install error:\n $msg"
        }
    }
    log* .
    return
}

proc xinstall {type args} {
    global modules guide
    foreach m $modules {
	eval $guide($m,$type) $m $args
    }
    return
}

proc ainstall {} {
    global apps config tcl_platform distribution

    if {[string compare $tcl_platform(platform) windows] == 0} {
	set ext .tcl
    } else {
	set ext ""
    }

    foreach a $apps {
	set aexe [file join $distribution apps $a]
	set adst [file join $config(app,path) ${a}$ext]

	log "\nGenerating $adst"
	if {!$config(dry)} {
	    file mkdir [file dirname  $adst]
	    catch {file delete -force $adst}
	    file copy -force $aexe    $adst
	}
    }
    return
}

proc doinstall {} {
    global config package_version distribution package_name modules excluded

    if {!$config(no-exclude)} {
	foreach p $excluded {
	    set pos [lsearch -exact $modules $p]
	    if {$pos < 0} {continue}
	    set modules [lreplace $modules $pos $pos]
	}
    }

    if {$config(doc,nroff)} {
	set config(man.macros) [string trim [get_input \
		[file join $distribution support installation man.macros]]]
    }
    if {$config(pkg)}       {
	xinstall   pkg $config(pkg,path)
	gen_main_index $config(pkg,path) $package_name $package_version
    }
    if {$config(doc,nroff)} {
	foreach dir [glob -nocomplain -directory $distribution/embedded/man/files/modules *] {
	    xcopy $dir $config(doc,nroff,path) 1
	}
	#xcopy $distribution/embedded/man/files/apps $config(doc,nroff,path) 1
    }
    if {$config(doc,html)}  {
	#xinstall doc html  html $config(doc,html,path)
	xcopy $distribution/embedded/www $config(doc,html,path) 1
    }
    if {$config(exa)}       {xinstall exa $config(exa,path)}
    if {$config(app)}       {ainstall}
    log ""
    return
}


# --------------------------------------------------------------
# Initialize configuration.

array set config {
    pkg 1 pkg,path {}
    app 1 app,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 no-exclude 0
}

# --------------------------------------------------------------
# Determine a default configuration, if possible

proc defaults {} {
    global tcl_platform config package_version package_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 ${package_name}_doc]
	} else {
	    set mandir  [file join $basedir man mann]
	    set htmldir [file join $libdir  ${package_name}${package_version} ${package_name}_doc]
	}

	set config(app,path)       $bindir
	set config(pkg,path)       [file join $libdir ${package_name}${package_version}]
	set config(doc,nroff,path) $mandir
	set config(doc,html,path)  $htmldir
	set config(exa,path)       [file join $bindir ${package_name}_examples${package_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 package_version package_name_cap

    puts "Installing $package_name_cap $package_version"
    if {$config(dry)} {
	puts "\tDry run, simulation, no actual activity."
	puts ""
    }

    puts "You have chosen the following configuration ..."
    puts ""

    showpath "Packages:      " pkg
    showpath "Applications:  " app
    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 package_name_cap package_version
    set config(gui) 1

    wm withdraw .
    wm title . "Installing $package_name_cap $package_version"

    foreach {w type cspan col row opts} {
	.pkg checkbutton 1 0 0 {-anchor w -text {Packages:}     -variable config(pkg)}
	.app checkbutton 1 0 1 {-anchor w -text {Applications:} -variable config(app)}
	.dnr checkbutton 1 0 2 {-anchor w -text {Doc. Nroff:}   -variable config(doc,nroff)}
	.dht checkbutton 1 0 3 {-anchor w -text {Doc. HTML:}    -variable config(doc,html)}
	.exa checkbutton 1 0 4 {-anchor w -text {Examples:}     -variable config(exa)}

	.spa frame  3 0 5 {-bg black -height 2}

	.dry checkbutton 2 0 7 {-anchor w -text {Simulate installation} -variable config(dry)}

	.pkge entry 1 1 0 {-width 40 -textvariable config(pkg,path)}
	.appe entry 1 1 1 {-width 40 -textvariable config(app,path)}
	.dnre entry 1 1 2 {-width 40 -textvariable config(doc,nroff,path)}
	.dhte entry 1 1 3 {-width 40 -textvariable config(doc,html,path)}
	.exae entry 1 1 4 {-width 40 -textvariable config(exa,path)}

	.pkgb button 1 2 0 {-text ... -command {browse Packages     pkg,path}}
	.appb button 1 2 1 {-text ... -command {browse Applications app,path}}
	.dnrb button 1 2 2 {-text ... -command {browse Nroff        doc,nroff,path}}
	.dhtb button 1 2 3 {-text ... -command {browse HTML         doc,html,path}}
	.exab button 1 2 4 {-text ... -command {browse Examples     exa,path}}

	.sep  frame  3 0 8 {-bg black -height 2}

	.run  button 1 0 9 {-text {Install} -command {set ::run 1}}
	.can  button 1 1 9 {-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] {
	    +excluded    {set config(no-exclude) 1}
	    -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}
	    -apps        {set config(app) 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}
	    -no-apps     {set config(app) 0}
	    -pkg-path {
		set config(pkg) 1
		set config(pkg,path) [lindex $argv 1]
		set argv             [lrange $argv 1 end]
	    }
	    -app-path {
		set config(app) 1
		set config(app,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? ?-apps|-no-apps? ?-app-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 installErrorMsgBox {msg} {
    tk_messageBox \
	    -icon error -type ok \
	    -default ok \
	    -title "Install error" \
	    -parent . -message $msg
    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
}

# --------------------------------------------------------------
if {[catch {
    main
}]} {
    puts $errorInfo
}
exit 0
# --------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Added make.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
set ::CWD [pwd]
set ::SRCDIR [file dirname [file normalize [info script]]]
set ::SANDBOX  [file dirname $::SRCDIR]

namespace eval ::main {
  variable DIR [file dirname [file normalize [info script]]]
  set ::auto_path [linsert $::auto_path 0 [file join $DIR modules]]
}
source [file join $::main::DIR scripts practcl.tcl]
set ::SRCDIR $::main::DIR

::practcl::library  create PROJECT {
name clay
version 0.1
}
[::practcl::LOCAL tool tcllib] define set tag hypnotoad
::practcl::LOCAL add_tool clay {
  tag trunk
  class subproject.practcl
  install vfs
  fossil_url http://fossil.etoyoc.com/clay
  module_install all
}
::practcl::LOCAL add_tool taolib {
  tag trunk
  class subproject.practcl
  install vfs
  fossil_url http://fossil.etoyoc.com/taolib
  module_install all
}
::practcl::LOCAL add_tool thread {
  profile {
    release: 2a36d0a6c31569bfb3562e3d58e9e8204f447a7e
    devel:   practcl
  }
  class subproject.binary
  install static
  pkg_name Thread
  initfunc Thread_Init
  fossil_url http://fossil.etoyoc.com/fossil/thread
}
PROJECT add_project bootswatch {
  class subproject.source
  git_url https://github.com/thomaspark/bootswatch
  tag master
}

proc installModule {modpath DEST} {
  puts [list installModule $modpath $DEST]
  set dpath  [file join $DEST modules [file tail $modpath]]
  if {[file exists $dpath] && [file type $dpath] eq "link"} return
  if {[file exists [file join $modpath build build.tcl]]} {
    puts [list Rebuild $modpath]
    ::practcl::dotclexec [file join $modpath build build.tcl]
  } elseif {![file exists [file join $modpath pkgIndex.tcl]]} {
    puts [list Reindex $modpath]
    pkg_mkIndex $modpath
  }
  file delete -force $dpath
  file mkdir $dpath
  foreach file [glob  [file join $modpath *.tcl]] {
    file copy $file $dpath
  }
  if {[file exists [file join $modpath htdocs]]} {
    ::practcl::installDir [file join $modpath htdocs] [file join $dpath htdocs]
  }
}

proc installPlugin {modpath DEST} {
  set dpath  [file join $DEST plugin [file tail $modpath]]
  if {[file exists [file join $modpath build build.tcl]]} {
    puts [list Rebuild $modpath]
    ::practcl::dotclexec [file join $modpath build build.tcl]
  } elseif {![file exists [file join $modpath pkgIndex.tcl]]} {
    puts [list Reindex $modpath]
    pkg_mkIndex $modpath
  }
  file delete -force $dpath
  file mkdir $dpath
  foreach file [glob  [file join $modpath *.tcl]] {
    file copy $file $dpath
  }
  if {[file exists [file join $modpath htdocs]]} {
    ::practcl::installDir [file join $modpath htdocs] [file join $dpath htdocs]
  }
}

proc modules {} {
  set result {}
  foreach modpath [glob [file join $::main::DIR modules *]] {
    ::practcl::buildModule $modpath
    if {![file exists [file join $modpath pkgIndex.tcl]]} continue
    lappend result [file tail $modpath]
  }
  return $result
}
###
# Build level scripting
###
switch [lindex $argv 0] {
  packages {
    ###
    # Build external packages needed by toadhttpd
    ###
    puts "BUILDING LOCAL TCL ENVIRONMENT"
    foreach item {tclconfig tcl sqlite thread} {
      set obj [::practcl::LOCAL tool $item]
      puts [list $item $obj]
      if {[catch {$obj env-install} err errdat]} {
        puts ***
        puts [dict get $errdat -errorinfo]
        puts ***
      }
    }
    ###
    # Just unpack the source for bootswatch
    ###
    foreach item {tcllib bootswatch} {
      set obj [PROJECT project $item]
      puts [list $item $obj]
      if {[catch {$obj unpack} err errdat]} {
        puts ***
        puts [dict get $errdat -errorinfo]
        puts ***
      }
    }
  }
  modules {
    set modules [modules]
    puts $modules
    exit 0
    #return $result
  }
  install {
    set DEST [file normalize [lindex $argv 1]]
    file mkdir $DEST
    set modlist [modules]
    foreach module $modlist {
      set modpath [file join $::main::DIR modules $module]
      ::practcl::installModule $modpath [file join $DEST $module]
    }
  }
  install-module {
    set DEST [file normalize [lindex $argv 1]]
    file mkdir $DEST
    if {[lindex $argv 2] in {all *}} {
      set modlist [modules]
    } else {
      set modlist [lrange $argv 2 end]
    }
    foreach module $modlist {
      set modpath [file join $::main::DIR modules $module]
      ::practcl::installModule $modpath [file join $DEST $module]
    }
  }

}

Changes to modules/clay-stage/build/core.tcl.

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

namespace eval ::stage {}
namespace eval ::objects {}

set ::GAME(DBTIMEOUT) 1000

###
# title: Define an option for the class
###
proc ::clay::define::Option {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::clay::args_to_dict {*}$args] {
    dict set dictargs [string trim $var -:/] $val
  }
  set name [string trimleft $name -]

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

###
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::clay::define::Option_Class {name args} {
  set class [current_class]
  set dictargs {default {}}
  set name [string trimleft $name -:]
  foreach {f v} [::clay::args_to_dict {*}$args] {
    $class clay set option_class $name [string trim $f -/:] $v
  }
}

proc ::stage::uuid {} {
  return [string toupper [::uuid::uuid generate]]
}








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




3
4
5
6
7
8
9













































10
11
12
13
package require Thread

namespace eval ::stage {}
namespace eval ::objects {}

set ::GAME(DBTIMEOUT) 1000














































proc ::stage::uuid {} {
  return [string toupper [::uuid::uuid generate]]
}

Changes to modules/clay-stage/clay-stage.tcl.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
package require Thread

namespace eval ::stage {}
namespace eval ::objects {}

set ::GAME(DBTIMEOUT) 1000

###
# title: Define an option for the class
###
proc ::clay::define::Option {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::clay::args_to_dict {*}$args] {
    dict set dictargs [string trim $var -:/] $val
  }
  set name [string trimleft $name -]

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

###
# title: Define a class of options
# description:
#    Option classes are a template of properties that other
#    options can inherit.
###
proc ::clay::define::Option_Class {name args} {
  set class [current_class]
  set dictargs {default {}}
  set name [string trimleft $name -:]
  foreach {f v} [::clay::args_to_dict {*}$args] {
    $class clay set option_class $name [string trim $f -/:] $v
  }
}

proc ::stage::uuid {} {
  return [string toupper [::uuid::uuid generate]]
}


###
# END: core.tcl







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







15
16
17
18
19
20
21













































22
23
24
25
26
27
28
package require Thread

namespace eval ::stage {}
namespace eval ::objects {}

set ::GAME(DBTIMEOUT) 1000














































proc ::stage::uuid {} {
  return [string toupper [::uuid::uuid generate]]
}


###
# END: core.tcl

Changes to modules/clay/build/build.tcl.

1
2
3
4
5
6
7
8
9
10
11
..
52
53
54
55
56
57
58














59
60
61
62

63
64
65
66
67


68
69
70
71
72
73
74
...
116
117
118
119
120
121
122












123
124
125
126
127
128
129
130
131
132
set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.5
set module clay
set filename clay
if {[file exists [file join $moddir .. practcl build doctool.tcl]]} {
  source [file join $moddir .. practcl build doctool.tcl]
} else {
  package require practcl 0.13
}
................................................................................
namespace eval ::%module% {}
}]


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















# These files must be loaded in a particular order
foreach file {
  core.tcl

  procs.tcl
  class.tcl
  object.tcl
  metaclass.tcl
  ensemble.tcl


} {
  lappend loaded $file
  set content [::practcl::cat [file join $srcdir {*}$file]]
  AutoDoc scan_text $content
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [::practcl::docstrip $content]
  puts $fout "###\n# END: [file tail $file]\n###"
................................................................................

###
# Generate the test script
###
namespace eval ::clay {}
source [file join $srcdir procs.tcl]
set fout [open [file join $moddir $filename.test] w]












puts $fout [source [file join $srcdir test.tcl]]
close $fout
set manout [open [file join $moddir $filename.man] w]
puts $manout [AutoDoc manpage map $modmap \
  header [::practcl::cat [file join $srcdir manual.txt]] \
  authors $authors \
  footer [::practcl::cat [file join $srcdir footer.txt]] \
]
close $manout




|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>




>

|
<


>
>







 







>
>
>
>
>
>
>
>
>
>
>
>










1
2
3
4
5
6
7
8
9
10
11
..
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
...
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 0.6
set module clay
set filename clay
if {[file exists [file join $moddir .. practcl build doctool.tcl]]} {
  source [file join $moddir .. practcl build doctool.tcl]
} else {
  package require practcl 0.13
}
................................................................................
namespace eval ::%module% {}
}]


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

foreach {omod files} {
  uuid      {uuid.tcl}
  oodialect {oodialect.tcl}
  dicttool  {build/core.tcl build/dict.tcl build/list.tcl}
} {
  foreach file $files {
    set content [::practcl::cat [file join $moddir .. $omod {*}$file]]
    #AutoDoc scan_text $content
    puts $fout "###\n# START: [file join $omod $file]\n###"
    puts $fout [::practcl::docstrip $content]
    puts $fout "###\n# END: [file join $omod $file]\n###"
  }
}

# These files must be loaded in a particular order
foreach file {
  core.tcl
  dialect.tcl
  procs.tcl
  dictargs.tcl

  metaclass.tcl
  ensemble.tcl
  class.tcl
  object.tcl
} {
  lappend loaded $file
  set content [::practcl::cat [file join $srcdir {*}$file]]
  AutoDoc scan_text $content
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [::practcl::docstrip $content]
  puts $fout "###\n# END: [file tail $file]\n###"
................................................................................

###
# Generate the test script
###
namespace eval ::clay {}
source [file join $srcdir procs.tcl]
set fout [open [file join $moddir $filename.test] w]
puts $fout {
namespace eval ::oo::dialect {}
set ::oo::dialect::has(tip470) 0
}
puts $fout [source [file join $srcdir test.tcl]]
puts $fout {

if {![package vsatisfies [package provide Tcl] 8.7]} {return}
puts "Repeating tests with 8.7 features"
namespace eval ::oo::dialect {}
set ::oo::dialect::has(tip470) 1
}
puts $fout [source [file join $srcdir test.tcl]]
close $fout
set manout [open [file join $moddir $filename.man] w]
puts $manout [AutoDoc manpage map $modmap \
  header [::practcl::cat [file join $srcdir manual.txt]] \
  authors $authors \
  footer [::practcl::cat [file join $srcdir footer.txt]] \
]
close $manout

Changes to modules/clay/build/class.tcl.

1
2
3
4
5
6
7
8
...
166
167
168
169
170
171
172



173
174
175
176
177
178
179
oo::define oo::class {

  ###
  # description:
  # The [method clay] method allows a class object access
  # to a combination of its own clay data as
  # well as to that of its ancestors
  # ensemble:
................................................................................
        return [::dicttool::sanitize $result]
      }
      merge {
        foreach arg $args {
          ::dicttool::dictmerge clay {*}$arg
        }
      }



      search {
        foreach aclass [::clay::ancestors [self]] {
          if {[$aclass clay exists {*}$args]} {
            return [$aclass clay get {*}$args]
          }
        }
      }
|







 







>
>
>







1
2
3
4
5
6
7
8
...
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
::oo::define ::clay::class {

  ###
  # description:
  # The [method clay] method allows a class object access
  # to a combination of its own clay data as
  # well as to that of its ancestors
  # ensemble:
................................................................................
        return [::dicttool::sanitize $result]
      }
      merge {
        foreach arg $args {
          ::dicttool::dictmerge clay {*}$arg
        }
      }
      noop {
        # Do nothing. Used as a sign of clay savviness
      }
      search {
        foreach aclass [::clay::ancestors [self]] {
          if {[$aclass clay exists {*}$args]} {
            return [$aclass clay get {*}$args]
          }
        }
      }

Changes to modules/clay/build/ensemble.tcl.

34
35
36
37
38
39
40



41
42
43
44
45
46
47
..
84
85
86
87
88
89
90
91
92
93
94
95
      } else {
        set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      if {$submethod eq "default"} {
        set default $body
      } else {



        dict set eswitch $submethod $body
      }
    }
  }
  set methodlist [lsort -dictionary [dict keys $eswitch]]
  if {![dict exists $eswitch <list>]} {
    dict set eswitch <list> {return $methodlist}
................................................................................
      set body {puts [list [self] $class [self method]]}
      append body \n $rawbody
    }
    ::oo::define $class method $rawmethod $arglist $body
    return
  }
  set method [join [lrange $mlist 2 end] "::"]
  $class clay set method_ensemble/ $mensemble [string trim $method :/] [dict create arglist $arglist body $body]
  if {$::clay::trace>2} {
    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  }
}







>
>
>







 







|




34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
..
87
88
89
90
91
92
93
94
95
96
97
98
      } else {
        set body "\n      ::clay::dynamic_arguments $ensemble \$method [list $arglist] {*}\$args"
      }
      append body "\n      " [string trim $realbody] "      \n"
      if {$submethod eq "default"} {
        set default $body
      } else {
        foreach alias [dict getnull $esubmethodinfo aliases] {
          dict set eswitch $alias -
        }
        dict set eswitch $submethod $body
      }
    }
  }
  set methodlist [lsort -dictionary [dict keys $eswitch]]
  if {![dict exists $eswitch <list>]} {
    dict set eswitch <list> {return $methodlist}
................................................................................
      set body {puts [list [self] $class [self method]]}
      append body \n $rawbody
    }
    ::oo::define $class method $rawmethod $arglist $body
    return
  }
  set method [join [lrange $mlist 2 end] "::"]
  $class clay set method_ensemble/ $mensemble [string trim [lindex $method 0] :/] [dict create arglist $arglist body $body]
  if {$::clay::trace>2} {
    puts [list $class clay set method_ensemble/ $mensemble [string trim $method :/]  ...]
  }
}

Changes to modules/clay/build/metaclass.tcl.

111
112
113
114
115
116
117












































118
119
120
121
122
123
124
...
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
  set class [current_class]
  set name [string trim $name :/]
  $class clay branch dict $name
  foreach {var val} $values {
    $class clay set dict/ $name/ $var $val
  }
}













































###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
................................................................................
proc ::clay::object_destroy objname {
  if {$::clay::trace>0} {
    puts [list $objname DESTROY]
  }
  ::cron::object_destroy $objname
}


# clay::object
#
# This class is inherited by all classes that have options.
#
::clay::define ::clay::object {
  clay branch array
  clay branch mixin
  clay branch option
  clay branch dict clay

  Variable DestroyEvent 0

  ###
  # Instantiate variables and build ensemble methods.
  ###
  method InitializePublic {} {
    next
    my variable clayorder clay claycache
    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble]
    } else {
      set emap {}
    }
    foreach class [lreverse $clayorder] {
      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      dict for {mensemble einfo} [$class clay get method_ensemble] {
        if {$mensemble eq {.}} continue
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

        dict for {method info} $einfo {
          if {$method eq {.}} continue
          if {![dict is_dict $info]} {
            puts [list WARNING: class: $class method: $method not dict: $info]
            continue
          }
          dict set info source $class
          if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]}
          dict set emap $ensemble $method $info
        }
      }
    }
    foreach {ensemble einfo} $emap {
      #if {[dict exists $einfo _body]} continue
      set body [::clay::ensemble_methodbody $ensemble $einfo]
      if {$::clay::trace>2} {
        set rawbody $body
        set body {puts [list [self] <object> [self method]]}
        append body \n $rawbody
      }
      oo::objdefine [self] method $ensemble {{method default} args} $body
    }
  }
}








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
...
191
192
193
194
195
196
197



























































  set class [current_class]
  set name [string trim $name :/]
  $class clay branch dict $name
  foreach {var val} $values {
    $class clay set dict/ $name/ $var $val
  }
}

###
# Define an option for the class
###
proc ::clay::define::Option {name args} {
  set class [current_class]
  set dictargs {default {}}
  foreach {var val} [::clay::args_to_dict {*}$args] {
    dict set dictargs [string trim $var -:/] $val
  }
  set name [string trimleft $name -]

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

###
# Define a class of options
# All field / value pairs will be be inherited by an option that
# specify [emph name] as it class field.
###
proc ::clay::define::Option_Class {name args} {
  set class [current_class]
  set dictargs {default {}}
  set name [string trimleft $name -:]
  foreach {f v} [::clay::args_to_dict {*}$args] {
    $class clay set option_class $name [string trim $f -/:] $v
  }
}

###
# topic: 615b7c43b863b0d8d1f9107a8d126b21
# title: Specify a variable which should be initialized in the constructor
# description:
#    This keyword can also be expressed:
#    [example {property variable NAME {default DEFAULT}}]
................................................................................
proc ::clay::object_destroy objname {
  if {$::clay::trace>0} {
    puts [list $objname DESTROY]
  }
  ::cron::object_destroy $objname
}




























































Changes to modules/clay/build/object.tcl.

1




2
3
4
5
6
7
8
...
542
543
544
545
546
547
548





549









550





551



















552
553
554
555

556

oo::define oo::object {





  ###
  # description:
  # The [method clay] method allows an object access
  # to a combination of its own clay data as
  # well as to that of its class
  # ensemble:
................................................................................
      }
      dict set config $field $value
      set setcmd [dict getnull $info set-command]
      if {$setcmd ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
      }
    }





  }









}

























oo::class clay branch array
oo::class clay branch mixin
oo::class clay branch option
oo::class clay branch dict clay



|
>
>
>
>







 







>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
>

>
1
2
3
4
5
6
7
8
9
10
11
12
...
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
# clay::object
#
# This class is inherited by all classes that have options.
#
::oo::define ::clay::object {

  ###
  # description:
  # The [method clay] method allows an object access
  # to a combination of its own clay data as
  # well as to that of its class
  # ensemble:
................................................................................
      }
      dict set config $field $value
      set setcmd [dict getnull $info set-command]
      if {$setcmd ne {}} {
        {*}[string map [list %field% [list $field] %value% [list $value] %self% [namespace which my]] $setcmd]
      }
    }
    my variable clayorder clay claycache
    if {[info exists clay]} {
      set emap [dict getnull $clay method_ensemble]
    } else {
      set emap {}
    }
    foreach class [lreverse $clayorder] {
      ###
      # Build a compsite map of all ensembles defined by the object's current
      # class as well as all of the classes being mixed in
      ###
      dict for {mensemble einfo} [$class clay get method_ensemble] {
        if {$mensemble eq {.}} continue
        set ensemble [string trim $mensemble :/]
        if {$::clay::trace>2} {puts [list Defining $ensemble from $class]}

        dict for {method info} $einfo {
          if {$method eq {.}} continue
          if {![dict is_dict $info]} {
            puts [list WARNING: class: $class method: $method not dict: $info]
            continue
          }
          dict set info source $class
          if {$::clay::trace>2} {puts [list Defining $ensemble -> $method from $class - $info]}
          dict set emap $ensemble $method $info
        }
      }
    }
    foreach {ensemble einfo} $emap {
      #if {[dict exists $einfo _body]} continue
      set body [::clay::ensemble_methodbody $ensemble $einfo]
      if {$::clay::trace>2} {
        set rawbody $body
        set body {puts [list [self] <object> [self method]]}
        append body \n $rawbody
      }
      oo::objdefine [self] method $ensemble {{method default} args} $body
    }
  }
}

::clay::object clay branch array
::clay::object clay branch mixin
::clay::object clay branch option
::clay::object clay branch dict clay
::clay::object clay set variable DestroyEvent 0


Changes to modules/clay/build/procs.tcl.

19
20
21
22
23
24
25











26
27
28
29
30
31
32
33
    foreach item $tqueue {
      if { $item ni $result } {
        lappend result $item
      }
    }
  }
  lappend result {*}$metaclasses











  return $result
}

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







>
>
>
>
>
>
>
>
>
>
>
|







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
    foreach item $tqueue {
      if { $item ni $result } {
        lappend result $item
      }
    }
  }
  lappend result {*}$metaclasses
  ###
  # Screen out classes that do not participate in clay
  # interactions
  ###
  set output {}
  foreach {item} $result {
    if {[catch {$item clay noop} err]} {
      continue
    }
    lappend output $item
  }
  return $output
}

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

Changes to modules/clay/build/test.tcl.

13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35











36
37
38
39
40
41
42
...
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
...
566
567
568
569
570
571
572



573
574
575




576
577
578

579
580
581
582
583
584
585
...
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605

606
607
608
609
610
611
612
...
630
631
632
633
634
635
636




637
638
639
640
641
642
643
644
645
646
...
650
651
652
653
654
655
656




657
658
659
660
661
662
663
...
773
774
775
776
777
778
779



780
781
782
783
784
785
786
787
788
789
...
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
source [file join  [file dirname [file dirname [file join [pwd] [info script]]]]  devtools testutilities.tcl]


testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1

support {
    use uuid/uuid.tcl uuid
    use dicttool/dicttool.tcl dicttool
    use oodialect/oodialect.tcl oo::dialect
}
testing {
    useLocal clay.tcl clay
}
}

putb result {
set ::clay::trace 0
}


putb result {











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

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

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


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




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





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





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


# -------------------------------------------------------------------------
# clay submodule testing
# -------------------------------------------------------------------------
# Test canonical path building
set path {const/ foo/ bar/ baz/}
}
................................................................................
test clay-object-clay-a-0003 {Test that objects of the class get properties} {
  $OBJ2 clay get color
} red
test clay-object-clay-a-0004 {Test that objects of the class get properties} {
  $OBJ2 clay get flavor
} strawberry




test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object ::oo::object}




test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object ::oo::object}

test clay-object-clay-a-0007 {Test the clay provenance  function} {
  $OBJ2 clay provenance  flavor
} ::TEST::myclass

###
# Test that object local setting override the class
###
................................................................................
  $OBJ2 clay provenance  color
} self

::clay::define ::TEST::myclasse {
  superclass ::TEST::myclass

  clay color blue

  method do args {
    return "I did $args"
  }

  Ensemble which::color {} {
    return [my clay get color]
  }

}

###
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
................................................................................
} ::TEST::myclasse
test clay-object-clay-b-0003 {Test that objects of the class get properties} {
  $OBJ3 clay get flavor
} strawberry
test clay-object-clay-b-0004 {Test the clay provenance  function} {
  $OBJ3 clay provenance  flavor
} ::TEST::myclass




test clay-object-clay-b-0005 {Test the clay provenance  function} {
  $OBJ3 clay ancestors
} {::TEST::myclasse ::TEST::myclass ::clay::object ::oo::object}

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
  $OBJ3 do this really cool thing
} {I did this really cool thing}
................................................................................
} blue
# Test setting properties
test clay-object-method-0004 {Test an ensemble} {
  $OBJ3 clay set color black
  $OBJ3 which color
} black





###
# Test that if you try to replace a global command you get an error
###
test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body {
::clay::define open {
  method bar {} { return foo }

................................................................................

test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {unknown}
test clay-mixin-b-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}



test clay-mixin-b-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::animal ::TEST::thing ::clay::object ::oo::object}

###
# Replacing a mixin replaces the behaviors
###
$OBJ clay mixinmap species ::TEST::vegetable
test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
................................................................................
test clay-mixin-c-0002 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which sound} \
  -returnCodes {error} \
  -result {unknown method which sound. Valid: color flavor}
test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} {
  $OBJ which flavor
} {unknown}



test clay-mixin-c-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::vegetable ::TEST::thing ::clay::object ::oo::object}

###
# Replacing a mixin
$OBJ clay mixinmap species ::TEST::species.cat
test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}
................................................................................
test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
###
# Test modified 2018-10-10
# clay::ancestors now rigged to descend into all classes depth-first
# and then place metaclasses at the end of the search
###
test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::thing ::TEST::animal ::clay::object ::oo::object}

$OBJ clay mixinmap coloring ::TEST::coloring.calico
test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {calico}
test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-f-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}

###
# Test modified 2018-10-10
# clay::ancestors now rigged to descend into all classes depth-first
# and then place metaclasses at the end of the search
###
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::coloring.calico ::TEST::thing ::TEST::animal ::clay::object ::oo::object}

test clay-mixin-f-0005 {Test that clay data from a mixin works} {
  $OBJ clay provenance  color
} {::TEST::coloring.calico}

###
# Test variable initialization







|
<
<
<
<











>
>
>
>
>
>
>
>
>
>
>







 







>
>
>


<
>

>
>
>


<
>

>
>
>


<
>







 







>
>
>


|
>
>
>
>


|
>







 







<







>







 







>
>
>
>


|







 







>
>
>
>







 







>
>
>


|







 







>
>
>


|







 







|
<
<



|













|
<
<



|







13
14
15
16
17
18
19
20




21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
...
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
...
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
...
615
616
617
618
619
620
621

622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
...
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
...
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
...
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
...
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
source [file join  [file dirname [file dirname [file join [pwd] [info script]]]]  devtools testutilities.tcl]


testsNeedTcl     8.6
testsNeedTcltest 2
testsNeed        TclOO 1

support {}




testing {
    useLocal clay.tcl clay
}
}

putb result {
set ::clay::trace 0
}


putb result {
# Modification History:
###
# Modification 2018-10-21
# The clay metaclass no longer exports the clay method
# to oo::class and oo::object, and clay::ancestors no
# longer returns any class that lacks the clay method
###
# Modification 2018-10-10
# clay::ancestors now rigged to descend into all classes depth-first
# and then place metaclasses at the end of the search
###
# -------------------------------------------------------------------------

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

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


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

###
# Test modified 2018-10-21
###
test oodialect-ancestry-003 {Testing heritage} {
  ::clay::ancestors ::test1::f

} {}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-004 {Testing heritage} {
  ::clay::ancestors ::alpha::object

} {}

###
# Test modified 2018-10-21
###
test oodialect-ancestry-005 {Testing heritage} {
  ::clay::ancestors ::delta::object

} {}

# -------------------------------------------------------------------------
# clay submodule testing
# -------------------------------------------------------------------------
# Test canonical path building
set path {const/ foo/ bar/ baz/}
}
................................................................................
test clay-object-clay-a-0003 {Test that objects of the class get properties} {
  $OBJ2 clay get color
} red
test clay-object-clay-a-0004 {Test that objects of the class get properties} {
  $OBJ2 clay get flavor
} strawberry

###
# Test modified 2018-10-21
###
test clay-object-clay-a-0005 {Test the clay ancestors function} {
  $OBJ clay ancestors
} {::clay::object}

###
# Test modified 2018-10-21
###
test clay-object-clay-a-0006 {Test the clay ancestors function} {
  $OBJ2 clay ancestors
} {::TEST::myclass ::clay::object}

test clay-object-clay-a-0007 {Test the clay provenance  function} {
  $OBJ2 clay provenance  flavor
} ::TEST::myclass

###
# Test that object local setting override the class
###
................................................................................
  $OBJ2 clay provenance  color
} self

::clay::define ::TEST::myclasse {
  superclass ::TEST::myclass

  clay color blue

  method do args {
    return "I did $args"
  }

  Ensemble which::color {} {
    return [my clay get color]
  }
  clay set method_ensemble which color aliases farbe
}

###
# Test clay information is passed town to subclasses
###
test clay-class-clay-0003 {Test that a clay statement is recorded in the object of the class} {
  ::TEST::myclasse clay get color
................................................................................
} ::TEST::myclasse
test clay-object-clay-b-0003 {Test that objects of the class get properties} {
  $OBJ3 clay get flavor
} strawberry
test clay-object-clay-b-0004 {Test the clay provenance  function} {
  $OBJ3 clay provenance  flavor
} ::TEST::myclass

###
# Test modified 2018-10-21
###
test clay-object-clay-b-0005 {Test the clay provenance  function} {
  $OBJ3 clay ancestors
} {::TEST::myclasse ::TEST::myclass ::clay::object}

###
# Test defining a standard method
###
test clay-object-method-0001 {Test and standard method} {
  $OBJ3 do this really cool thing
} {I did this really cool thing}
................................................................................
} blue
# Test setting properties
test clay-object-method-0004 {Test an ensemble} {
  $OBJ3 clay set color black
  $OBJ3 which color
} black

# Test setting properties
test clay-object-method-0004 {Test an ensemble alias} {
  $OBJ3 which farbe
} black
###
# Test that if you try to replace a global command you get an error
###
test clay-nspace-0001 {Test that if you try to replace a global command you get an error} -body {
::clay::define open {
  method bar {} { return foo }

................................................................................

test clay-mixin-b-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {unknown}
test clay-mixin-b-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
###
# Test Modified: 2018-10-21
###
test clay-mixin-b-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::animal ::TEST::thing ::clay::object}

###
# Replacing a mixin replaces the behaviors
###
$OBJ clay mixinmap species ::TEST::vegetable
test clay-mixin-c-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
................................................................................
test clay-mixin-c-0002 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which sound} \
  -returnCodes {error} \
  -result {unknown method which sound. Valid: color flavor}
test clay-mixin-c-0003 {Test that an ensemble is created during a mixin} {
  $OBJ which flavor
} {unknown}
###
# Test Modified: 2018-10-21
###
test clay-mixin-c-0004 {Test that mixins resolve in the correct order} {
  $OBJ clay ancestors
} {::TEST::vegetable ::TEST::thing ::clay::object}

###
# Replacing a mixin
$OBJ clay mixinmap species ::TEST::species.cat
test clay-mixin-e-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {unknown}
................................................................................
test clay-mixin-e-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-e-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}
###
# Test Modified: 2018-10-21, 2018-10-10


###
test clay-mixin-e-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::thing ::TEST::animal ::clay::object}

$OBJ clay mixinmap coloring ::TEST::coloring.calico
test clay-mixin-f-0001 {Test that an ensemble is created during a mixin} {
  $OBJ which color
} {calico}
test clay-mixin-f-0002 {Test that an ensemble is created during a mixin} {
  $OBJ which sound
} {meow}
test clay-mixin-f-0003 {Test that an ensemble is created during a mixin} \
  -body {$OBJ which flavor} -returnCodes {error} \
  -result {unknown method which flavor. Valid: color sound}

###
# Test modified 2018-10-21, 2018-10-10


###
test clay-mixin-f-0004 {Test that clay data follows the rules of inheritence and order of mixin} {
  $OBJ clay ancestors
} {::TEST::species.cat ::TEST::coloring.calico ::TEST::thing ::TEST::animal ::clay::object}

test clay-mixin-f-0005 {Test that clay data from a mixin works} {
  $OBJ clay provenance  color
} {::TEST::coloring.calico}

###
# Test variable initialization

Changes to modules/clay/clay.man.

1
2
3
4
5
6
7
8
9
...
196
197
198
199
200
201
202
















203
204
205
206
207
208
209
...
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
...
275
276
277
278
279
280
281
282





283
284
285
286
287
288
289
...
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
[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 0.5]
[manpage_begin clay n [vset PACKAGE_VERSION]]
[keywords oo]
[copyright {2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Clay Framework}]
[titledesc {A minimalist framework for large scale OO Projects}]
[category  {Programming tools}]
[keywords TclOO]
................................................................................

[call proc [cmd clay::define::destructor] [arg rawbody]]



[call proc [cmd clay::define::Dict] [arg name] [opt "[arg values] [const ""]"]]


















[call proc [cmd clay::define::Variable] [arg name] [opt "[arg default] [const ""]"]]

    This keyword can also be expressed:
    [example {property variable NAME {default DEFAULT}}]
    [para]
    Variables registered in the variable property are also initialized
................................................................................

[call proc [cmd clay::define::Ensemble] [arg rawmethod] [arg arglist] [arg body]]


[list_end]

[section Classes]
[subsection {Class  oo::class}]

[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "clay ancestors"]]
Return this class and all ancestors in search order.

................................................................................

[call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]]
Merge the conents of [const value] with the object's clay storage at [const path].

[list_end]
[para]

[subsection {Class  oo::object}]






[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "clay ancestors"]]
Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.

................................................................................
[call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]]
Merge the conents of [const value] with the object's clay storage at [const path].

[call method [cmd "InitializePublic"]]

 Instantiate variables. Called on object creation and during clay mixin.




[list_end]
[para]

[subsection {Class  branch}]

[para]
[class {Option}]
[list_begin definitions]
[call option [cmd ]]

[list_end]
[para]

[subsection {Class  clay::object}]
 clay::object

 This class is inherited by all classes that have options.



[para]
[class {Variable}]
[list_begin definitions]
[call variable [cmd DestroyEvent]]

[list_end]
[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "InitializePublic"]]

 Instantiate variables and build ensemble methods.




[list_end]
[para]

[section AUTHORS]
Sean Woods [uri mailto:<yoda@etoyoc.com>][para]
[vset CATEGORY oo]
[include ../doctools2base/include/feedback.inc]

[manpage_end]


|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







|
>
>
>
>
>







 







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













1
2
3
4
5
6
7
8
9
...
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
...
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
...
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
...
390
391
392
393
394
395
396




































397
398
399
400
401
402
403
404
405
406
407
408
409
[comment {-*- tcl -*- doctools manpage}]
[vset PACKAGE_VERSION 0.6]
[manpage_begin clay n [vset PACKAGE_VERSION]]
[keywords oo]
[copyright {2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Clay Framework}]
[titledesc {A minimalist framework for large scale OO Projects}]
[category  {Programming tools}]
[keywords TclOO]
................................................................................

[call proc [cmd clay::define::destructor] [arg rawbody]]



[call proc [cmd clay::define::Dict] [arg name] [opt "[arg values] [const ""]"]]


[call proc [cmd clay::define::Option] [arg name] [opt "[arg args]"]]

 Define an option for the class




[call proc [cmd clay::define::Option_Class] [arg name] [opt "[arg args]"]]

 Define a class of options
 All field / value pairs will be be inherited by an option that
 specify [emph name] as it class field.




[call proc [cmd clay::define::Variable] [arg name] [opt "[arg default] [const ""]"]]

    This keyword can also be expressed:
    [example {property variable NAME {default DEFAULT}}]
    [para]
    Variables registered in the variable property are also initialized
................................................................................

[call proc [cmd clay::define::Ensemble] [arg rawmethod] [arg arglist] [arg body]]


[list_end]

[section Classes]
[subsection {Class  clay::class}]

[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "clay ancestors"]]
Return this class and all ancestors in search order.

................................................................................

[call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]]
Merge the conents of [const value] with the object's clay storage at [const path].

[list_end]
[para]

[subsection {Class  clay::object}]
 clay::object

 This class is inherited by all classes that have options.



[para]
[class {Methods}]
[list_begin definitions]
[call method [cmd "clay ancestors"]]
Return the class this object belongs to, all classes mixed into this object, and all ancestors of those classes in search order.

................................................................................
[call method [cmd "clay set"] [arg path] [opt [option "path..."]] [arg value]]
Merge the conents of [const value] with the object's clay storage at [const path].

[call method [cmd "InitializePublic"]]

 Instantiate variables. Called on object creation and during clay mixin.








































[list_end]
[para]

[section AUTHORS]
Sean Woods [uri mailto:<yoda@etoyoc.com>][para]
[vset CATEGORY oo]
[include ../doctools2base/include/feedback.inc]

[manpage_end]

Changes to modules/clay/pkgIndex.tcl.

7
8
9
10
11
12
13
14
15
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}


package ifneeded clay 0.5 [list source [file join $dir clay.tcl]]








|

7
8
9
10
11
12
13
14
15
# in response to "package require" commands.  When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.

if {![package vsatisfies [package provide Tcl] 8.6]} {return}


package ifneeded clay 0.6 [list source [file join $dir clay.tcl]]

Changes to modules/dicttool/build/list.tcl.

9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
..
49
50
51
52
53
54
55
56
57
58
59
60
# ladd contents foo bar
# puts $contents
# > foo bar
# ladd contents foo bar baz bang
# puts $contents
# > foo bar baz bang
###
::tcllib::PROC ::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
................................................................................
# element {positional 1 mandatory 0 repeating 1}
# example:
# set contents {foo bar baz bang foo foo foo}
# ldelete contents foo
# puts $contents
# > bar baz bang
###
::tcllib::PROC ::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i]
................................................................................
  }
  return $var
}

###
# Return a random element from [variable list]
###
::tcllib::PROC ::lrandom list {
  set len [llength $list]
  set idx [expr int(rand()*$len)]
  return [lindex $list $idx]
}







|







 







|







 







|




9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
..
49
50
51
52
53
54
55
56
57
58
59
60
# ladd contents foo bar
# puts $contents
# > foo bar
# ladd contents foo bar baz bang
# puts $contents
# > foo bar baz bang
###
::tcllib::PROC ::dicttool::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
................................................................................
# element {positional 1 mandatory 0 repeating 1}
# example:
# set contents {foo bar baz bang foo foo foo}
# ldelete contents foo
# puts $contents
# > bar baz bang
###
::tcllib::PROC ::dicttool::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i]
................................................................................
  }
  return $var
}

###
# Return a random element from [variable list]
###
::tcllib::PROC ::dicttool::lrandom list {
  set len [llength $list]
  set idx [expr int(rand()*$len)]
  return [lindex $list $idx]
}

Changes to modules/dicttool/dicttool.man.

219
220
221
222
223
224
225










226
227
228
229
230
231
232
233
...
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
 if exists and contains an empty string or the value of NULL or null.
 [para]
 This function is added to the global dict ensemble as [fun {dict isnull}]














[call proc [cmd ladd] [arg varname] [opt "[arg element]"] [opt [option "element..."]]]

 Add elements to a list if that are not already present in the list.
 As a side effect, if variable [variable varname] does not exists,
 create it as an empty list.

[para]Example: [example { ladd contents foo bar
 puts $contents
................................................................................
 ladd contents foo bar baz bang
 puts $contents
 > foo bar baz bang


}]

[call proc [cmd ldelete] [arg varname] [opt "[arg element]"] [opt [option "element..."]]]

 Delete all instances of the elements given from a list contained in [variable varname].
 If the variable does exist this is a noop.

[para]Example: [example { set contents {foo bar baz bang foo foo foo}
 ldelete contents foo
 puts $contents
 > bar baz bang


}]

[call proc [cmd lrandom] [arg list]]

 Return a random element from [variable list]




[list_end]







>
>
>
>
>
>
>
>
>
>
|







 







|












|







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
...
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
 if exists and contains an empty string or the value of NULL or null.
 [para]
 This function is added to the global dict ensemble as [fun {dict isnull}]




[call proc [cmd dictargs::proc] [arg name] [arg argspec] [arg body]]

 Named Procedures as new command




[call proc [cmd dictargs::method] [arg name] [arg argspec] [arg body]]


[call proc [cmd dicttool::ladd] [arg varname] [opt "[arg element]"] [opt [option "element..."]]]

 Add elements to a list if that are not already present in the list.
 As a side effect, if variable [variable varname] does not exists,
 create it as an empty list.

[para]Example: [example { ladd contents foo bar
 puts $contents
................................................................................
 ladd contents foo bar baz bang
 puts $contents
 > foo bar baz bang


}]

[call proc [cmd dicttool::ldelete] [arg varname] [opt "[arg element]"] [opt [option "element..."]]]

 Delete all instances of the elements given from a list contained in [variable varname].
 If the variable does exist this is a noop.

[para]Example: [example { set contents {foo bar baz bang foo foo foo}
 ldelete contents foo
 puts $contents
 > bar baz bang


}]

[call proc [cmd dicttool::lrandom] [arg list]]

 Return a random element from [variable list]




[list_end]

Changes to modules/dicttool/dicttool.tcl.

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
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
}

###
# END: dict.tcl
###
###




























































# START: list.tcl
###
::tcllib::PROC ::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
  }
  return $var
}
::tcllib::PROC ::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i]
    }
  }
  return $var
}
::tcllib::PROC ::lrandom list {
  set len [llength $list]
  set idx [expr int(rand()*$len)]
  return [lindex $list $idx]
}

###
# END: list.tcl
###

namespace eval ::dicttool {
  namespace export *
}









>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|










|











|













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
  namespace ensemble configure dict -map [dict replace\
      [namespace ensemble configure dict -map] isnull ::tcl::dict::isnull]
}

###
# END: dict.tcl
###
###
# START: dictargs.tcl
###
namespace eval ::dictargs {
}
if {[info commands ::dictargs::parse] eq {}} {
  proc ::dictargs::parse {argdef argdict} {
    set result {}
    dict for {field info} $argdef {
      if {![string is alnum [string index $field 0]]} {
        error "$field is not a simple variable name"
      }
      upvar 1 $field _var
      set aliases {}
      if {[dict exists $argdict $field]} {
        set _var [dict get $argdict $field]
        continue
      }
      if {[dict exists $info aliases:]} {
        set found 0
        foreach {name} [dict get $info aliases:] {
          if {[dict exists $argdict $name]} {
            set _var [dict get $argdict $name]
            set found 1
            break
          }
        }
        if {$found} continue
      }
      if {[dict exists $info default:]} {
        set _var [dict get $info default:] \n
        continue
      }
      set mandatory 1
      if {[dict exists $info mandatory:]} {
        set mandatory [dict get $info mandatory:]
      }
      if {$mandatory} {
        error "$field is required"
      }
    }
  }
}
proc ::dictargs::proc {name argspec body} {
  set result {}
  append result "::dictargs::parse \{$argspec\} \$args" \;
  append result $body
  uplevel 1 [list ::proc $name [list [list args [list dictargs $argspec]]] $result]
}
proc ::dictargs::method {name argspec body} {
  set class [lindex [::info level -1] 1]
  set result {}
  append result "::dictargs::parse \{$argspec\} \$args" \;
  append result $body
  oo::define $class method $name [list [list args [list dictargs $argspec]]] $result
}

###
# END: dictargs.tcl
###
###
# START: list.tcl
###
::tcllib::PROC ::dicttool::ladd {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      set var {}
  }
  foreach item $args {
    if {$item in $var} continue
    lappend var $item
  }
  return $var
}
::tcllib::PROC ::dicttool::ldelete {varname args} {
  upvar 1 $varname var
  if ![info exists var] {
      return
  }
  foreach item [lsort -unique $args] {
    while {[set i [lsearch $var $item]]>=0} {
      set var [lreplace $var $i $i]
    }
  }
  return $var
}
::tcllib::PROC ::dicttool::lrandom list {
  set len [llength $list]
  set idx [expr int(rand()*$len)]
  return [lindex $list $idx]
}

###
# END: list.tcl
###

namespace eval ::dicttool {
  namespace export *
}

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
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
#!/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]]
set auto_path      [linsert $auto_path 0 [file join $distribution modules]]

set critcldefault {}
set critclnotes   {}
set dist_excluded {}

proc package_name    {text} {global package_name    ; set package_name    $text}
proc package_version {text} {global package_version ; set package_version $text}
proc dist_exclude    {path} {global dist_excluded   ; lappend dist_excluded $path}
proc critcl {name files} {
    global critclmodules
    set    critclmodules($name) $files
    return
}
proc critcl_main {name files} {
    global critcldefault
    set critcldefault $name
    critcl $name $files
    return
}
proc critcl_notes {text} {
    global critclnotes
    set critclnotes [string map {{\n    } \n} $text]
    return
}

source [file join $distribution support installation version.tcl] ; # Get version information.

set package_nv ${package_name}-${package_version}

catch {eval file delete -force [glob [file rootname [info script]].tmp.*]}

# --------------------------------------------------------------
# SAK internal debugging support.

# Configuration, change as needed
set  debug 0

if {$debug} {
    proc sakdebug {script} {uplevel 1 $script ; return}
} else {
    proc sakdebug {args} {}
}

# --------------------------------------------------------------
# Internal helper to load packages straight out of the local directory
# tree. Not something from an installation, possibly incompatible.

proc getpackage {package tclmodule} {
    global distribution
    if {[catch {package present $package}]} {
	set src [file join \
		$distribution modules \
		$tclmodule]
	if {[file exists $src]} {
	    uplevel #0 [list source $src]
	} else {
	    # Fallback
	    package require $package
	}
    }
}

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

proc tclfiles {} {
    global distribution
    getpackage fileutil fileutil/fileutil.tcl
    set fl [fileutil::findByPattern $distribution -glob *.tcl]
    # Remove files under SCCS. They are repository, not sources to check.
    set tmp {}
    foreach f $fl {
	if {[string match *SCCS* $f]} continue
	lappend tmp $f
    }
    proc tclfiles {} [list return $tmp]
    return $tmp
}

proc modtclfiles {modules} {
    global mfiles guide
    load_modinfo
    set mfiles [list]
    foreach m $modules {
	eval $guide($m,pkg) $m __dummy__
    }
    return $mfiles
}

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}

	if {![file exists [file join $f pkgIndex.tcl]]} {continue}

	lappend fl [file tail $f]
    }
    set fl [lsort $fl]
    proc modules {} [list return $fl]
    return $fl
}

proc modules_mod {m} {
    return [expr {[lsearch -exact [modules] $m] >= 0}]
}

proc dealias {modules} {
    set _ {}
    foreach m $modules {
	if {[file exists $m]} {
	    set m [file tail $m]
	}
	lappend _ $m
    }
    return $_
}

proc load_modinfo {} {
    global distribution modules guide
    source [file join $distribution support installation modules.tcl] ; # Get list of installed modules.
    source [file join $distribution support installation actions.tcl] ; # Get installer support code.
    proc load_modinfo {} {}
    return
}

proc imodules {} {global modules ; load_modinfo ; return $modules}

proc imodules_mod {m} {
    global modules
    load_modinfo
    return [expr {[lsearch -exact $modules $m] > 0}]
}

# Result: dict (package name --> list of package versions).

proc loadpkglist {fname} {
    set f [open $fname r]
    foreach line [split [read $f] \n] {
	set line [string trim $line]
	if {[string match @* $line]} continue
	if {$line == {}} continue
	foreach {n v} $line break
	lappend p($n) $v
	set p($n) [lsort -uniq -dict $p($n)]
    }
    close $f
    return [array get p]
}

# Result: dict (package name => list of (list of package versions, module)).

proc ipackages {args} {
    # Determine indexed packages (ifneeded, pkgIndex.tcl)

    global distribution

    if {[llength $args] == 0} {set args [modules]}

    array set p {}
    foreach m $args {
	set f [open [file join $distribution modules $m pkgIndex.tcl] r]
	foreach line [split [read $f] \n] {
	    if { [regexp {#}        $line]} {continue}
	    if {![regexp {ifneeded} $line]} {continue}
	    regsub {^.*ifneeded } $line {} line
	    regsub {([0-9]) \[.*$}  $line {\1} line

	    foreach {n v} $line break
	    set v [string trimright $v \\]

	    if {![info exists p($n)]} {
		set p($n) [list $v $m]
	    } else {
		# We have multiple versions of the same package. We
		# remember all versions.

		foreach {vlist mx} $p($n) break
		lappend vlist $v
		set p($n) [list [lsort -uniq -dict $vlist] $mx]
	    }
	}
	close $f
    }
    return [array get p]
}


# Result: dict (package name --> list of package versions).

proc ppackages {args} {
    # Determine provided packages (provide, *.tcl - pkgIndex.tcl)
    # We cache results for a bit of speed, some stuff uses this
    # multiple times for the same arguments.

    global ppcache
    if {[info exists ppcache($args)]} {
	return $ppcache($args)
    }

    global    p pf currentfile
    array set p {}

    if {[llength $args] == 0} {
	set files [tclfiles]
    } else {
	set files [modtclfiles $args]
    }

    getpackage fileutil fileutil/fileutil.tcl
    set capout [fileutil::tempfile] ; set capcout [open $capout w]
    set caperr [fileutil::tempfile] ; set capcerr [open $caperr w]

    array set notprovided {}

    foreach f $files {
	# We ignore package indices and all files not in a module.

	if {[string equal pkgIndex.tcl [file tail $f]]} {continue}
	if {![regexp modules $f]}                       {continue}

	# We use two methods to extract the version information from a
	# module and its packages. First we do a static scan for
	# appropriate statements. If that did not work out we try to
	# execute the script in a modified interpreter which lets us
	# pick up dynamically generated version data (like stored in
	# variables). If the second method fails as well we give up.

	# Method I. Static scan.

	# We do heuristic scanning of the code to locate suitable
	# package provide statements.

	set fh [open $f r]

	set currentfile [eval file join [lrange [file split $f] end-1 end]]

	set ok -1
	foreach line [split [read $fh] \n] {
	    if {[regexp "\#\\s*@sak\\s+notprovided\\s+(\[^\\s\]+)" $line -> nppname]} {
		sakdebug {puts stderr "PRAGMA notprovided = $nppname"}
		set notprovided($nppname) .
	    }

	    regsub "\#.*$" $line {} line
	    if {![regexp {provide} $line]} {continue}
	    if {![regexp {package} $line]} {continue}

	    # Now a stronger check for the actual command
	    if {![regexp {package[ 	][ 	]*provide} $line]} {continue}

	    set xline $line
	    regsub {^.*provide } $line {} line
	    regsub {\].*$}       $line {\1} line

	    sakdebug {puts stderr __$f\ _________$line}

	    foreach {n v} $line break

	    # HACK ...
	    # Module 'page', package 'page::gen::peg::cpkg'.
	    # Has a provide statement inside a template codeblock.
	    # Name is placeholder @@. Ignore this specific name.
	    # Better would be to use general static Tcl parsing
	    # to find that the string is a variable value.

	    if {[string equal $n @@]} continue

	    if {[regexp {^[0-9]+(\.[0-9]+)*$} $v]} {
		lappend p($n) $v
		set p($n) [lsort -uniq -dict $p($n)]
		set pf($n,$v) $currentfile
		set ok 1

		# We continue the scan. The file may provide several
		# versions of the same package, or multiple packages.
		continue
	    }

	    # 'package provide foo' are tests. Ignore.
	    if {$v == ""} continue

	    # We do not set the state to bad if we found ok provide
	    # statements before, only if nothing was found before.
	    if {$ok < 0} {
		set ok 0

		# No good version found on the current line. We scan
		# further through the file and hope for more luck.

		sakdebug {puts stderr @_$f\ _________$xline\t<$n>\t($v)}
	    }
	}
	close $fh

	# Method II. Restricted Execution.
	# We now try to run the code through a safe interpreter
	# and hope for better luck regarding package information.

	if {$ok == -1} {sakdebug {puts stderr $f\ IGNORE}}
	if {$ok == 0} {
	    sakdebug {puts -nonewline stderr $f\ EVAL}

	    # Source the code into a sub-interpreter. The sub
	    # interpreter overloads 'package provide' so that the
	    # information about new packages goes directly to us. We
	    # also make sure that the sub interpreter doesn't kill us,
	    # and will not get stuck early by trying to load other
	    # files, or when creating procedures in namespaces which
	    # do not exist due to us disabling most of the package
	    # management.

	    set fh [open $f r]

	    set ip [interp create]

	    # Kill control structures. Namespace is required, but we
	    # skip everything related to loading of packages,
	    # i.e. 'command import'.

	    $ip eval {
		rename ::if        ::_if_
		rename ::namespace ::_namespace_

		proc ::if {args} {}
		proc ::namespace {cmd args} {
		    #puts stderr "_nscmd_ $cmd"
		    ::_if_ {[string equal $cmd import]} return
		    #puts stderr "_nsdo_ $cmd $args"
		    return [uplevel 1 [linsert $args 0 ::_namespace_ $cmd]]
		}
	    }

	    # Kill more package stuff, and ensure that unknown
	    # commands are neither loaded nor abort execution. We also
	    # stop anything trying to kill the application at large.

	    interp alias $ip package {} xPackage
	    interp alias $ip source  {} xNULL
	    interp alias $ip unknown {} xNULL
	    interp alias $ip proc    {} xNULL
	    interp alias $ip exit    {} xNULL

	    # From here on no redefinitions anymore, proc == xNULL !!

	    $ip eval {close stdout} ; interp share {} $capcout $ip
	    $ip eval {close stderr} ; interp share {} $capcerr $ip

	    if {[catch {$ip eval [read $fh]} msg]} {
		sakdebug {puts stderr "ERROR in $currentfile:\n$::errorInfo\n"}
	    }

	    sakdebug {puts stderr ""}

	    close $fh
	    interp delete $ip
	}
    }

    close $capcout ; file delete $capout
    close $capcerr ; file delete $caperr

    # Process the accumulated pragma information, remove all the
    # packages which exist but not really, in terms of indexing.

    foreach n [array names notprovided] {
	catch { unset p($n) }
	array unset pf $n,*
    }

    set   pp [array get p]
    unset p

    set ppcache($args) $pp
    return $pp 
}

proc xNULL    {args} {}
proc xPackage {cmd args} {
    if {[string equal $cmd provide]} {
	global p pf currentfile
	foreach {n v} $args break

	# No version specified, this is an inquiry, we ignore these.
	if {$v == {}} {return}

	sakdebug {puts stderr \tOK\ $n\ =\ $v}

	lappend p($n) $v
	set p($n) [lsort -uniq -dict $p($n)]
	set pf($n,$v) $currentfile
    }
    return
}

proc sep {} {puts ~~~~~~~~~~~~~~~~~~~~~~~~}

proc gd-cleanup {} {
    global package_nv

    puts {Cleaning up...}

    set        fl [glob -nocomplain ${package_nv}*]
    foreach f $fl {
	puts "    Deleting $f ..."
	catch {file delete -force $f}
    }
    return
}

proc gd-gen-archives {} {
    global package_name package_nv

    puts {Generating archives...}

    set tar [auto_execok tar]
    if {$tar != {}} {
        puts "    Gzipped tarball (${package_nv}.tar.gz)..."
        catch {
            exec $tar cf - ${package_nv} | gzip --best > ${package_nv}.tar.gz
        }

        set bzip [auto_execok bzip2]
        if {$bzip != {}} {
            puts "    Bzipped tarball (${package_nv}.tar.bz2)..."
            exec tar cf - ${package_nv} | bzip2 > ${package_nv}.tar.bz2
        }
    }

    set zip [auto_execok zip]
    if {$zip != {}} {
        puts "    Zip archive     (${package_nv}.zip)..."
        catch {
            exec $zip -r ${package_nv}.zip ${package_nv}
        }
    }

    set sdx [auto_execok sdx]
    if {$sdx != {}} {
	file copy -force [file join ${package_nv} support installation main.tcl] \
		[file join ${package_nv} main.tcl]
	file rename ${package_nv} ${package_name}.vfs

	puts "    Starkit         (${package_nv}.kit)..."
	exec sdx wrap ${package_name}
	file rename   ${package_name} ${package_nv}.kit

	if {![file exists tclkit]} {
	    puts "    No tclkit present in current working directory, no starpack."
	} else {
	    puts "    Starpack        (${package_nv}.exe)..."
	    exec sdx wrap ${package_name} -runtime tclkit
	    file rename   ${package_name} ${package_nv}.exe
	}

	file rename ${package_name}.vfs ${package_nv}
    }

    puts {    Keeping directory for other archive types}

    ## Keep the directory for 'sdx' - kit/pack
    return
}

proc xcopyfile {src dest} {
    # dest can be dir or file
    global  mfiles
    lappend mfiles $src
    return
}

proc xcopy {src dest recurse {pattern *}} {
    if {[string equal $pattern *] || !$recurse} {
	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} {
		    xcopy $file $sub $recurse $pattern
		}
	    } else {
		xcopyfile $file $sub
	    }
	}
    } else {
	foreach file [glob [file join $src *]] {
	    set base [file tail $file]
	    set sub  [file join $dest $base]
	    if {[string equal CVS $base]} {continue}
	    if {[file isdirectory $file]} then {
		if {$recurse} {
		    xcopy $file $sub $recurse $pattern
		}
	    } else {
		if {![string match $pattern $base]} {continue}
		xcopyfile $file $sub
	    }
	}
    }
}

proc xxcopy {src dest recurse {pattern *}} {
    global package_name

    file mkdir $dest
    foreach file [glob -nocomplain [file join $src $pattern]] {
        set base [file tail $file]
	set sub  [file join $dest $base]

	# Exclude CVS, SCCS, ... automatically, and possibly the temp
	# hierarchy itself too.

	if {0 == [string compare CVS        $base]} {continue}
	if {0 == [string compare SCCS       $base]} {continue}
	if {0 == [string compare BitKeeper  $base]} {continue}
	if {[string match ${package_name}-* $base]} {continue}
	if {[string match *~                $base]} {continue}

        if {[file isdirectory $file]} then {
	    if {$recurse} {
		file mkdir  $sub
		xxcopy $file $sub $recurse $pattern
	    }
        } else {
	    puts -nonewline stdout . ; flush stdout
            file copy -force $file $sub
        }
    }
}

proc gd-assemble {} {
    global package_nv distribution dist_excluded

    puts "Assembling distribution in directory '${package_nv}'"

    xxcopy $distribution ${package_nv} 1

    foreach f $dist_excluded {
	file delete -force [file join $package_nv $f]
    }
    puts ""
    return
}

proc normalize-version {v} {
    # Strip everything after the first non-version character, and any
    # trailing dots left behind by that, to avoid the insertion of bad
    # version numbers into the generated .tap file.

    regsub {[^0-9.].*$} $v {} v
    return [string trimright $v .]
}

proc gd-gen-tap {} {
    getpackage textutil textutil/textutil.tcl
    getpackage fileutil fileutil/fileutil.tcl

    global package_name package_version distribution tcl_platform

    set pname [textutil::cap $package_name]

    set modules   [imodules]
    array set pd  [getpdesc]
    set     lines [list]
    # Header
    lappend lines {format  {TclDevKit Project File}}
    lappend lines {fmtver  2.0}
    lappend lines {fmttool {TclDevKit TclApp PackageDefinition} 2.5}
    lappend lines {}
    lappend lines "##  Saved at : [clock format [clock seconds]]"
    lappend lines "##  By       : $tcl_platform(user)"
    lappend lines {##}
    lappend lines "##  Generated by \"[file tail [info script]] tap\""
    lappend lines "##  of $package_name $package_version"
    lappend lines {}
    lappend lines {########}
    lappend lines {#####}
    lappend lines {###}
    lappend lines {##}
    lappend lines {#}

    # Bundle definition
    lappend lines {}
    lappend lines {# ###############}
    lappend lines {# Complete bundle}
    lappend lines {}
    lappend lines [list Package [list $package_name [normalize-version $package_version]]]
    lappend lines "Base     @TAP_DIR@"
    lappend lines "Platform *"
    lappend lines "Desc     \{$pname: Bundle of all packages\}"
    lappend lines "Path     pkgIndex.tcl"
    lappend lines "Path     [join $modules "\nPath     "]"

    set  strip [llength [file split $distribution]]
    incr strip 2

    foreach m $modules {
	# File set of module ...

	lappend lines {}
	lappend lines "# #########[::textutil::strRepeat {#} [string length $m]]" ; # {}
	lappend lines "# Module \"$m\""
	set n 0
	foreach {p vlist} [ppackages $m] {
	    foreach v $vlist {
		lappend lines "# \[[format %1d [incr n]]\]    | \"$p\" ($v)"
	    }
	}
	if {$n > 1} {
	    # Multiple packages (*). We create one hidden package to
	    # contain all the files and then have all the true
	    # packages in the module refer to it.
	    #
	    # (*) This can also be one package for which we have
	    # several versions. Or a combination thereof.

	    array set _ {}
	    foreach {p vlist} [ppackages $m] {
		catch {set _([lindex $pd($p) 0]) .}
	    }
	    set desc [string trim [join [array names _] ", "] " \n\t\r,"]
	    if {$desc == ""} {set desc "$pname module"}
	    unset _

	    lappend lines "# -------+"
	    lappend lines {}
	    lappend lines [list Package [list __$m 0.0]]
	    lappend lines "Platform *"
	    lappend lines "Desc     \{$desc\}"
	    lappend lines Hidden
	    lappend lines "Base     @TAP_DIR@/$m"

	    foreach f [lsort -dict [modtclfiles $m]] {
		lappend lines "Path     [fileutil::stripN $f $strip]"
	    }

	    # Packages in the module ...
	    foreach {p vlist} [ppackages $m] {
		# NO DANGER. As we are listing only the packages P for
		# the module any other version of P in a different
		# module is _not_ listed here.

		set desc ""
		catch {set desc [string trim [lindex $pd($p) 1]]}
		if {$desc == ""} {set desc "$pname package"}

		foreach v $vlist {
		    lappend lines {}
		    lappend lines [list Package [list $p [normalize-version $v]]]
		    lappend lines "See   [list __$m]"
		    lappend lines "Platform *"
		    lappend lines "Desc     \{$desc\}"
		}
	    }
	} else {
	    # A single package in the module. And only one version of
	    # it as well. Otherwise we are in the multi-pkg branch.

	    foreach {p vlist} [ppackages $m] break
	    set desc ""
	    catch {set desc [string trim [lindex $pd($p) 1]]}
	    if {$desc == ""} {set desc "$pname package"}

	    set v [lindex $vlist 0]

	    lappend lines "# -------+"
	    lappend lines {}
	    lappend lines [list Package [list $p [normalize-version $v]]]
	    lappend lines "Platform *"
	    lappend lines "Desc     \{$desc\}"
	    lappend lines "Base     @TAP_DIR@/$m"

	    foreach f [lsort -dict [modtclfiles $m]] {
		lappend lines "Path     [fileutil::stripN $f $strip]"
	    }
	}
	lappend lines {}
	lappend lines {#}
	lappend lines "# #########[::textutil::strRepeat {#} [string length $m]]"
    }

    lappend lines {}
    lappend lines {#}
    lappend lines {##}
    lappend lines {###}
    lappend lines {#####}
    lappend lines {########}

    # Write definition
    set    f [open [file join $distribution ${package_name}.tap] w]
    puts  $f [join $lines \n]
    close $f
    return
}

proc getpdesc  {} {
    global argv ; if {![checkmod]} return

    package require sak::doc
    sak::doc::Gen desc l $argv
    
    array set _ {}
    foreach file [glob -nocomplain doc/desc/*.l] {
        set f [open $file r]
	foreach l [split [read $f] \n] {
	    foreach {p sd d} $l break
	    set _($p) [list $sd $d]
	}
        close $f
    }
    file delete -force doc/desc

    return [array get _]
}

proc gd-gen-rpmspec {} {
    global package_version package_name distribution

    set in  [file join $distribution support releases package_rpm.txt]
    set out [file join $distribution ${package_name}.spec]

    write_out $out [string map \
			[list \
			     @PACKAGE_VERSION@ $package_version \
			     @PACKAGE_NAME@    $package_name] \
			[get_input $in]]
    return
}

proc gd-gen-yml {} {
    # YAML is the format used for the FreePAN archive network.
    # http://freepan.org/

    global package_version package_name distribution

    set in  [file join $distribution support releases package_yml.txt]
    set out [file join $distribution ${package_name}.yml]

    write_out $out [string map \
			[list \
			     @PACKAGE_VERSION@ $package_version \
			     @PACKAGE_NAME@    $package_name] \
			[get_input $in]]
    return
}

proc docfiles {} {
    global distribution

    getpackage fileutil fileutil/fileutil.tcl

    set res [list]
    foreach f [fileutil::findByPattern $distribution -glob *.man] {
	# Remove files under SCCS. They are repository, not sources to check.
	if {[string match *SCCS* $f]} continue
	lappend res [file rootname [file tail $f]].n
    }
    proc docfiles {} [list return $res]
    return $res
}

proc gd-tip55 {} {
    global package_version package_name distribution contributors
    contributors

    set in  [file join $distribution support releases package_tip55.txt]
    set out [file join $distribution DESCRIPTION.txt]

    set md [string map \
		[list \
		     @PACKAGE_VERSION@ $package_version \
		     @PACKAGE_NAME@    $package_name] \
		[get_input $in]]

    foreach person [lsort [array names contributors]] {
        set mail $contributors($person)
        regsub {@}  $mail " at " mail
        regsub -all {\.} $mail " dot " mail
        append md "Contributor: $person <$mail>\n"
    }

    write_out $out $md
    return
}

# Fill the global array of contributors to the bundle by processing
# the ChangeLog entries.
#
proc contributors {} {
    global distribution contributors
    if {![info exists contributors] || [array size contributors] == 0} {
        get_contributors [file join $distribution ChangeLog]

        foreach f [glob -nocomplain [file join $distribution modules *]] {
            if {![file isdirectory $f]} {continue}
            if {[string match CVS [file tail $f]]} {continue}
            if {![file exists [file join $f ChangeLog]]} {continue}
            get_contributors [file join $f ChangeLog]
        }
    }
}

proc get_contributors {changelog} {
    global contributors
    set f [open $changelog r]
    while {![eof $f]} {
        gets $f line
        if {[regexp {^[\d-]+\s+(.*?)<(.*?)>} $line r name mail]} {
            set name [string trim $name]
            if {![info exists names($name)]} {
                set contributors($name) $mail
            }
        }
    }
    close $f
}

proc validate_imodules_cmp {imvar dmvar} {
    upvar $imvar im $dmvar dm

    foreach m [lsort [array names im]] {
	if {![info exists dm($m)]} {
	    puts "  Installed, does not exist: $m"
	}
    }
    foreach m [lsort [array names dm]] {
	if {![info exists im($m)]} {
	    puts "  Missing in installer:      $m"
	}
    }
    return
}

proc validate_imodules {} {
    foreach m [imodules] {set im($m) .}
    foreach m [modules]  {set dm($m) .}

    validate_imodules_cmp im dm
    return
}

proc validate_imodules_mod {m} {
    array set im {}
    array set dm {}
    if {[imodules_mod $m]} {set im($m) .}
    if {[modules_mod  $m]} {set dm($m) .}

    validate_imodules_cmp im dm
    return
}
proc validate_versions_cmp {ipvar ppvar} {
    global pf
    getpackage struct::set struct/sets.tcl

    upvar $ipvar ip $ppvar pp
    set maxl 0
    foreach name [array names ip] {if {[string length $name] > $maxl} {set maxl [string length $name]}}
    foreach name [array names pp] {if {[string length $name] > $maxl} {set maxl [string length $name]}}

    foreach p [lsort [array names ip]] {
	if {![info exists pp($p)]} {
	    puts "  Indexed, no provider:           $p"
	}
    }
    foreach p [lsort [array names pp]] {
	if {![info exists ip($p)]} {
	    foreach k [array names pf $p,*] {
		puts "  Provided, not indexed:          [format "%-*s | %s" $maxl $p $pf($k)]"
	    }
	}
    }
    foreach p [lsort [array names ip]] {
	if {![info exists pp($p)]}               continue
	if {[struct::set equal $pp($p) $ip($p)]} continue

	# Compute intersection and set differences.
	foreach {__ pmi imp} [struct::set intersect3 $pp($p) $ip($p)] break

	puts "  Index/provided versions differ: [format "%-*s | %8s | %8s" $maxl $p $imp $pmi]"
    }
}

proc validate_versions {} {
    foreach {p vm}    [ipackages] {set ip($p) [lindex $vm 0]}
    foreach {p vlist} [ppackages] {set pp($p) $vlist}

    validate_versions_cmp ip pp
    return
}

proc validate_versions_mod {m} {
    foreach {p vm}    [ipackages $m] {set ip($p) [lindex $vm 0]}
    foreach {p vlist} [ppackages $m] {set pp($p) $vlist}

    validate_versions_cmp ip pp
    return
}

proc validate_testsuite_mod {m} {
    global distribution
    if {[llength [glob -nocomplain [file join $distribution modules $m *.test]]] == 0} {
	puts "  Without testsuite : $m"
    }
    return
}

proc bench_mod {mlist paths interp flags norm format verbose output} {
    global distribution env tcl_platform

    getpackage logger logger/logger.tcl
    getpackage bench  bench/bench.tcl

    ::logger::setlevel $verbose

    set pattern tclsh*
    if {$interp != {}} {
	set pattern [file tail $interp]
	set paths [list [file dirname $interp]]
    } elseif {![llength $paths]} {
	# Using the environment PATH is not a good default for
	# SAK. Use the interpreter running SAK as the default.
	if 0 {
	    set paths [split $env(PATH) \
			   [expr {($tcl_platform(platform) == "windows") ? ";" : ":"}]]
	}
	set interp [info nameofexecutable]
	set pattern [file tail $interp]
	set paths [list [file dirname $interp]]
    }

    set interps [bench::versions \
	    [bench::locate $pattern $paths]]

    if {![llength $interps]} {
	puts "No interpreters found"
	return
    }

    if {[llength $flags]} {
	set cmd [linsert $flags 0 bench::run]
    } else {
	set cmd [list bench::run]
    }

    array set DATA {}

    foreach m $mlist {
	set files [glob -nocomplain [file join $distribution modules $m *.bench]]
	if {![llength $files]} {
	    bench::log::warn "No benchmark files found for module \"$m\""
	    continue
	}

	set run $cmd
	lappend run $interps $files
	array set DATA [eval $run]
    }

    _bench_write $output [array get DATA] $norm $format
    return
}

proc bench_all {flags norm format verbose output} {
    bench_mod [modules] $flags $norm $format $verbose $output
    return
}


proc _bench_write {output data norm format} {
    if {$norm != {}} {
	getpackage logger logger/logger.tcl
	getpackage bench  bench/bench.tcl

	set data [bench::norm $data $norm]
    }

    set data [bench::out::$format $data]

    if {$output == {}} {
	puts $data
    } else {
	set    output [open $output w]
	puts  $output "# -*- tcl -*- bench/$format"
	puts  $output $data
	close $output
    }
}

proc validate_testsuites {} {
    foreach m [modules] {
	validate_testsuite_mod $m
    }
    return
}

proc validate_pkgIndex_mod {m} {
    global distribution
    if {[llength [glob -nocomplain [file join $distribution modules $m pkgIndex.tcl]]] == 0} {
	puts "  Without package index : $m"
    }
    return
}

proc validate_pkgIndex {} {
    global distribution
    foreach m [modules] {
	validate_pkgIndex_mod $m
    }
    return
}

proc validate_doc_existence_mod {m} {
    global distribution
    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_existence {} {
    global distribution
    foreach m [modules] {
	validate_doc_existence_mod $m
    }
    return
}


proc validate_doc_markup_mod {m} {
    package require sak::doc
    sak::doc::Gen null null [list $m]
    return
}

proc validate_doc_markup {} {
    package require sak::doc
    sak::doc::Gen null null [modules]
    return
}

proc run-frink {args} {
    global distribution

    set tmp [file rootname [info script]].tmp.[pid]

    if {[llength $args] == 0} {
	set files [tclfiles]
    } else {
	set files [lsort -dict [modtclfiles $args]]
    }

    foreach f $files {
	puts "FRINK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	puts "$f..."
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	catch {exec frink 2> $tmp -HJ $f}
	set data [get_input $tmp]
	if {[string length $data] > 0} {
	    puts $data
	}
    }
    catch {file delete -force $tmp}
    return
}

proc run-procheck {args} {
    global distribution

    if {[llength $args] == 0} {
	set files [tclfiles]
    } else {
	set files [lsort -dict [modtclfiles $args]]
    }

    foreach f $files {
	puts "PROCHECK ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	puts "$f ..."
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	catch {exec procheck >@ stdout $f}
    }
    return
}

proc run-tclchecker {args} {
    global distribution

    if {[llength $args] == 0} {
	set files [tclfiles]
    } else {
	set files [lsort -dict [modtclfiles $args]]
    }

    foreach f $files {
	puts "TCLCHECKER ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	puts "$f ..."
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	catch {exec tclchecker >@ stdout $f}
    }
    return
}

proc run-nagelfar {args} {
    global distribution

    if {[llength $args] == 0} {
	set files [tclfiles]
    } else {
	set files [lsort -dict [modtclfiles $args]]
    }

    foreach f $files {
	puts "NAGELFAR ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
	puts "$f ..."
	puts "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"

	catch {exec nagelfar >@ stdout $f}
    }
    return
}


proc get_input {f} {return [read [set if [open $f r]]][close $if]}

proc write_out {f text} {
    catch {file delete -force $f}
    puts -nonewline [set of [open $f w]] $text
    close $of
}

proc location_PACKAGES {} {
    global distribution
    return [file join $distribution support releases PACKAGES]
}

proc gd-gen-packages {} {
    global package_version distribution

    set P [location_PACKAGES]
    file copy -force $P $P.LAST
    set f [open $P w]
    puts $f "@@ RELEASE $package_version"
    puts $f ""

    array set packages {}
    foreach {p vm} [ipackages] {
	set packages($p) [lindex $vm 0]
    }

    nparray packages $f
    close $f
}



proc modified-modules {} {
    global distribution

    set mlist [modules]
    set modified [list]

    foreach m $mlist {
	set cl [file join $distribution modules $m ChangeLog]
	if {![file exists $cl]} {
	    lappend modified [list $m no-changelog]
	    continue
	}
	# Look for 'Released and tagged' within
	# the first four lines of the file. If
	# not present assume that the line is
	# deeper down, indicating that the module
	# has been modified since the last release.

	set f [open $cl r]
	set n 0
	set mod 1
	while {$n < 5} {
	    gets $f line
	    incr n
	    if {[string match -nocase "*Released and tagged*" $line]} {
		if {$n <= 4} {set mod 0 ; break}
	    }
	}
	if {$mod} {
	    lappend modified $m
	}
	close $f
    }
    return $modified
}

# --------------------------------------------------------------
# Handle modules using docstrip

proc docstripUser {m} {
    global distribution

    set mdir [file join $distribution modules $m]

    if {[llength [glob -nocomplain -dir $mdir *.stitch]]} {return 1}
    return 0
}

proc docstripRegen {m} {
    global distribution
    puts "$m ..."

    getpackage docstrip docstrip/docstrip.tcl

    set mdir [file join $distribution modules $m]

    foreach sf [glob -nocomplain -dir $mdir *.stitch] {
	puts "* [file tail $sf] ..."

	set here [pwd]
	set fail [catch {
	    cd [file dirname $sf]
	    docstripRunStitch [file tail $sf]
	} msg]
	cd $here
	if {$fail} {
	    puts "  [join [split $::errorInfo \n] "\n  "]"
	}
    }
    return
}

proc docstripRunStitch {sf} {
    # Run the stitch file in a restricted sandbox ...

    set box [restrictedIp {
	input   ::dsrs::Input
	options ::dsrs::Options
	stitch  ::dsrs::Stitch
	reset   ::dsrs::Reset
    }]

    ::dsrs::Init
    set fail [catch {interp eval $box [get_input $sf]} msg]
    if {$fail} {
	puts "    [join [split $::errorInfo \n] "\n    "]"
    } else {
	::dsrs::Final
    }

    interp delete $box
    return
}

proc emptyIp {} {
    set box [interp create]
    foreach c [interp eval $box {info commands}] {
	if {[string equal $c "rename"]} continue
	interp eval $box [list rename $c {}]
    }
    # Rename command goes last.
    interp eval $box [list rename rename {}]
    return $box
}

proc restrictedIp {dict} {
    set box [emptyIp]
    foreach {cmd localcmd} $dict {
	interp alias $box $cmd {} $localcmd
    }
    return $box
}

# --------------------------------------------------------------
# docstrip low level operations for stitching.

namespace eval ::dsrs {
    # Standard preamble to preambles

    variable preamble {}
    append   preamble                                       \n
    append   preamble "This is the file `@output@',"        \n
    append   preamble "generated with the SAK utility"      \n
    append   preamble "(sak docstrip/regen)."               \n
    append   preamble                                       \n
    append   preamble "The original source files were:"     \n
    append   preamble                                       \n
    append   preamble "@input@  (with options: `@guards@')" \n
    append   preamble                                       \n

    # Standard postamble to postambles

    variable postamble {}
    append   postamble                           \n
    append   postamble                           \n
    append   postamble "End of file `@output@'."

    # Default values for the options which are relevant to the
    # application itself and thus have to be defined always.
    # They are processed as global options, as part of argv.

    variable defaults {-metaprefix {%} -preamble {} -postamble {}}

    variable options ; array set options {}
    variable outputs ; array set outputs {}
    variable inputs  ; array set inputs  {}
    variable input   {}
}

proc ::dsrs::Init {} {
    variable outputs ; unset outputs ; array set outputs {}
    variable inputs  ; unset inputs  ; array set inputs  {}
    variable input   {}

    Reset ; # options
    return
}

proc ::dsrs::Reset {} {
    variable defaults
    variable options ; unset options ; array set options {}
    eval [linsert $defaults 0 Options]
    return
}

proc ::dsrs::Input {sourcefile} {
    # Relative to current directory = directory containing the active
    # stitch file.

    variable input $sourcefile
}

proc ::dsrs::Options {args} {
    variable options
    variable preamble
    variable postamble

    while {[llength $args]} {
	set opt [lindex $args 0]

	switch -exact -- $opt {
	    -nopreamble -
	    -nopostamble {
		set o -[string range $opt 3 end]
		set options($o) ""
		set args [lrange $args 1 end]
	    }
	    -preamble {
		set val $preamble[lindex $args 1]
		set options($opt) $val
		set args [lrange $args 2 end]
	    }
	    -postamble {
		set val [lindex $args 1]$postamble
		set options($opt) $val
		set args [lrange $args 2 end]
	    }
	    -metaprefix -
	    -onerror    -
	    -trimlines  {
		set val [lindex $args 1]
		set options($opt) $val
		set args [lrange $args 2 end]
	    }
	    default {
		return -code error "Unknown option: \"$opt\""
	    }
	}
    }
    return
}

proc ::dsrs::Stitch {outputfile guards} {
    variable options
    variable inputs
    variable input
    variable outputs
    variable preamble
    variable postamble

    if {[string equal $input {}]} {
	return -code error "No input file defined"
    }

    if {![info exist inputs($input)]} {
	set inputs($input) [get_input $input]
    }

    set intext $inputs($input)
    set otext  ""

    set c   $options(-metaprefix)
    set cc  $c$c

    set pmap [list @output@ $outputfile \
		  @input@   $input  \
		  @guards@  $guards]

    if {[info exists options(-preamble)]} {
	set pre $options(-preamble)

	if {![string equal $pre ""]} {
	    append otext [Subst $pre $pmap $cc] \n
	}
    }

    array set o [array get options]
    catch {unset o(-preamble)}
    catch {unset o(-postamble)}
    set opt [array get o]

    append otext [eval [linsert $opt 0 docstrip::extract $intext $guards]]

    if {[info exists options(-postamble)]} {
	set post $options(-postamble)

	if {![string equal $post ""]} {
	    append otext [Subst $post $pmap $cc]
	}
    }

    # Accumulate outputs in memory

    append outputs($outputfile) $otext
    return
}

proc ::dsrs::Subst {text pmap cc} {
    return [string trim "$cc [join [split [string map $pmap $text] \n] "\n$cc "]"]
}

proc ::dsrs::Final {} {
    variable outputs
    foreach o [array names outputs] {
	puts "  = Writing $o ..."

	if {[string equal \
		 docstrip/docstrip.tcl \
		 [file join [file tail [pwd]] $o]]} {

	    # We are writing over code required by ourselves.
	    # For easy recovery in case of problems we save
	    # the original 

	    puts "    *Saving original of code important to docstrip/regen itself*"
	    write_out $o.bak [get_input $o]
	}

	write_out $o $outputs($o)
    }
}

# --------------------------------------------------------------
# Configuration

proc __name    {} {global package_name    ; puts -nonewline $package_name}
proc __version {} {global package_version ; puts -nonewline $package_version}
proc __minor   {} {global package_version ; puts -nonewline [lindex [split $package_version .] 1]}
proc __major   {} {global package_version ; puts -nonewline [lindex [split $package_version .] 0]}

# --------------------------------------------------------------
# Development

proc __imodules {} {puts [imodules]}
proc __modules  {} {puts [modules]}
proc __lmodules {} {puts [join [modules] \n]}


proc nparray {a {chan stdout}} {
    upvar $a packages

    set maxl 0
    foreach name [lsort [array names packages]] {
        if {[string length $name] > $maxl} {
            set maxl [string length $name]
        }
    }
    foreach name [lsort [array names packages]] {
	foreach v $packages($name) {
	    puts $chan [format "%-*s %s" $maxl $name $v]
	}
    }
    return
}

proc __packages {} {
    array set packages {}
    foreach {p vm} [ipackages] {
	set packages($p) [lindex $vm 0]
    }
    nparray packages
    return
}

proc __provided {} {
    array set packages [ppackages]
    nparray packages
    return
}

proc checkmod {} {
    global argv
    package require sak::util
    return [sak::util::checkModules argv]
}

# -------------------------------------------------------------------------
# Critcl stuff
# -------------------------------------------------------------------------

# Build critcl modules. If no args then build the default critcl module.
proc __critcl {} {
    global argv critcl critclmodules critcldefault critclnotes tcl_platform
    if {$tcl_platform(platform) == "windows"} {

	# Windows is a bit more complicated. We have to choose an
	# interpreter, and a starkit for it, and call both.
	#
	# We prefer tclkitsh, but try to make do with a tclsh. That
	# one will have to have all the necessary packages to support
	# starkits. ActiveTcl for example.

	set interpreter {}
	foreach i {critcl.exe tclkitsh tclsh} {
	    set interpreter [auto_execok $i]
	    if {$interpreter != {}} break
	}

	if {$interpreter == {}} {
            return -code error \
		    "failed to find either tclkitsh.exe or tclsh.exe in path"
	}

	# The critcl starkit can come out of the environment, or we
	# try to locate it using several possible names. We try to
	# find it if and only if we did not find a critcl starpack
	# before.

	if {[file tail $interpreter] == "critcl.exe"} {
	    set critcl $interpreter
	} else {
	    set kit {}
            if {[info exists ::env(CRITCL)]} {
                set kit $::env(CRITCL)
            } else {
		foreach k {critcl.kit critcl} {
		    set kit [auto_execok $k]
		    if {$kit != {}} break
		}
            }

            if {$kit == {}} {
                return -code error "failed to find critcl.kit or critcl in \
                  path.\n\
                  You may wish to set the CRITCL environment variable to the\
                  location of your critcl(.kit) file."
            }
            set critcl [concat $interpreter $kit]
        }
    } else {
        # My, isn't it simpler under unix.
        set critcl [auto_execok critcl]
    }

    set flags ""
    while {[string match -* [set option [lindex $argv 0]]]} {
        # -debug and -clean only work with critcl >= v04
        switch -exact -- $option {
            -keep  { append flags " -keep" }
            -debug {
		append flags " -debug [lindex $argv 1]"
		set argv [lreplace $argv 0 0]
	    }
            -clean { append flags " -clean" }
            -target {
		append flags " -target [lindex $argv 1]"
		set argv [lreplace $argv 0 0]
	    }
            -- { set argv [lreplace $argv 0 0]; break }
            default { break }
        }
        set argv [lreplace $argv 0 0]
    }

    if {$critcl != {}} {
        if {[llength $argv] == 0} {
            puts stderr "[string repeat - 72]"
	    puts stderr "Building critcl components."
	    if {$critclnotes != {}} {
		puts stderr $critclnotes
	    }
	    puts stderr "[string repeat - 72]"

            critcl_module $critcldefault $flags
        } else {
            foreach m [dealias $argv] {
                if {[info exists critclmodules($m)]} {
                    critcl_module $m $flags
                } else {
                    puts "warning: $m is not a critcl module"
                }
            }
        }
    } else {
        puts "error: cannot find a critcl to run."
        return 1
    }
    return
}

# Prints a list of all the modules supporting critcl enhancement.
proc __critcl-modules {} {
    global critclmodules critcldefault
    foreach m [lsort -dict [array names critclmodules]] {
	if {$m == $critcldefault} {
	    puts "$m **"
	} else {
	    puts $m
	}
    }
    return
}

proc critcl_module {pkg {extra ""}} {
    global critcl distribution critclmodules critcldefault
    if {$pkg == $critcldefault} {
	set files {}
	foreach f $critclmodules($critcldefault) {
	    lappend files [file join $distribution modules $f]
	}
        foreach m [array names critclmodules] {
	    if {$m == $critcldefault} continue
            foreach f $critclmodules($m) {
                lappend files [file join $distribution modules $f]
            }
        }
    } else {
        foreach f $critclmodules($pkg) {
            lappend files [file join $distribution modules $f]
        }
    }
    set target [file join $distribution modules]
    catch {
        puts "$critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files"
        eval exec $critcl $extra -force -libdir [list $target] -pkg [list $pkg] $files 
    } r
    puts $r
    return
}

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

proc __bench/edit {} {
    global argv argv0

    set format text
    set output {}

    while {[string match -* [set option [lindex $argv 0]]]} {
	set val [lindex $argv 1]
        switch -exact -- $option {
	    -format {
		switch -exact -- $val {
		    raw - csv - text {}
		    default {
			return -error "Bad format \"$val\", expected text, csv, or raw"
		    }
		}
		set format $val
	    }
	    -o    {set output $val}
            -- {
		set argv [lrange $argv 1 end]
		break
	    }
            default { break }
        }
        set argv [lrange $argv 2 end]
    }

    switch -exact -- $format {
	raw {}
	csv {
	    getpackage csv             csv/csv.tcl
	    getpackage bench::out::csv bench/bench_wcsv.tcl
	}
	text {
	    getpackage report           report/report.tcl
	    getpackage struct::matrix   struct/matrix.tcl
	    getpackage bench::out::text bench/bench_wtext.tcl
	}
    }

    getpackage bench::in bench/bench_read.tcl
    getpackage bench     bench/bench.tcl

    if {[llength $argv] != 3} {
	puts "Usage: $argv0 benchdata column newvalue"
    }

    foreach {in col new} $argv break

    _bench_write $output \
	[bench::edit \
	     [bench::in::read $in] \
	     $col $new] \
	{} $format
    return
}

proc __bench/del {} {
    global argv argv0

    set format text
    set output {}

    while {[string match -* [set option [lindex $argv 0]]]} {
	set val [lindex $argv 1]
        switch -exact -- $option {
	    -format {
		switch -exact -- $val {
		    raw - csv - text {}
		    default {
			return -error "Bad format \"$val\", expected text, csv, or raw"
		    }
		}
		set format $val
	    }
	    -o    {set output $val}
            -- {
		set argv [lrange $argv 1 end]
		break
	    }
            default { break }
        }
        set argv [lrange $argv 2 end]
    }

    switch -exact -- $format {
	raw {}
	csv {
	    getpackage csv             csv/csv.tcl
	    getpackage bench::out::csv bench/bench_wcsv.tcl
	}
	text {
	    getpackage report           report/report.tcl
	    getpackage struct::matrix   struct/matrix.tcl
	    getpackage bench::out::text bench/bench_wtext.tcl
	}
    }

    getpackage bench::in bench/bench_read.tcl
    getpackage bench     bench/bench.tcl

    if {[llength $argv] < 2} {
	puts "Usage: $argv0 benchdata column..."
    }

    set in [lindex $argv 0]

    set data [bench::in::read $in]

    foreach c [lrange $argv 1 end] {
	set data [bench::del $data $c]
    }

    _bench_write $output $data {} $format
    return
}

proc __bench/show {} {
    global argv

    set format text
    set output {}
    set norm   {}

    while {[string match -* [set option [lindex $argv 0]]]} {
	set val [lindex $argv 1]
        switch -exact -- $option {
	    -format {
		switch -exact -- $val {
		    raw - csv - text {}
		    default {
			return -error "Bad format \"$val\", expected text, csv, or raw"
		    }
		}
		set format $val
	    }
	    -o    {set output $val}
	    -norm {set norm $val}
            -- {
		set argv [lrange $argv 1 end]
		break
	    }
            default { break }
        }
        set argv [lrange $argv 2 end]
    }

    switch -exact -- $format {
	raw {}
	csv {
	    getpackage csv             csv/csv.tcl
	    getpackage bench::out::csv bench/bench_wcsv.tcl
	}
	text {
	    getpackage report           report/report.tcl
	    getpackage struct::matrix   struct/matrix.tcl
	    getpackage bench::out::text bench/bench_wtext.tcl
	}
    }

    getpackage bench::in bench/bench_read.tcl

    array set DATA {}

    foreach path $argv {
	array set DATA [bench::in::read $path]
    }

    _bench_write $output [array get DATA] $norm $format
    return
}

proc __bench {} {
    global argv

    # I. Process command line arguments for the
    #    benchmark commands - Validation, possible
    #    translation ...

    set flags   {}
    set norm    {}
    set format  text
    set verbose warn
    set output  {}
    set paths   {}
    set interp  {}

    while {[string match -* [set option [lindex $argv 0]]]} {
	set val [lindex $argv 1]
        switch -exact -- $option {
	    -throwerrors {lappend flags -errors $val}
	    -match -
	    -rmatch -
	    -iters -
	    -threads {lappend flags $option $val}
	    -o       {set output $val}
	    -norm    {set norm $val}
	    -path    {lappend paths $val}
	    -interp  {set interp $val}
	    -format  {
		switch -exact -- $val {
		    raw - csv - text {}
		    default {
			return -error "Bad format \"$val\", expected text, csv, or raw"
		    }
		}
		set format $val
	    }
	    -verbose {
		set verbose info
		set argv [lrange $argv 1 end]
		continue
	    }
	    -debug {
		set verbose debug
		set argv [lrange $argv 1 end]
		continue
	    }
            -- {
		set argv [lrange $argv 1 end]
		break
	    }
            default { break }
        }
        set argv [lrange $argv 2 end]
    }

    switch -exact -- $format {
	raw {}
	csv {
	    getpackage csv             csv/csv.tcl
	    getpackage bench::out::csv bench/bench_wcsv.tcl
	}
	text {
	    getpackage report           report/report.tcl
	    getpackage struct::matrix   struct/matrix.tcl
	    getpackage bench::out::text bench/bench_wtext.tcl
	}
    }

    # Choose between benchmarking everything, or
    # only selected modules.

    if {[llength $argv] == 0} {
	_bench_all $paths $interp $flags $norm $format $verbose $output
    } else {
	if {![checkmod]} {return}
	_bench_module [dealias $argv] $paths $interp $flags $norm $format $verbose $output
    }
    return
}

proc _bench_module {mlist paths interp flags norm format verbose output} {
    global package_name package_version

    puts "Benchmarking $package_name $package_version development"
    puts "======================================================"
    bench_mod $mlist $paths $interp $flags $norm $format $verbose $output
    puts "------------------------------------------------------"
    puts ""
    return
}

proc _bench_all {paths flags interp norm format verbose output} {
    _bench_module [modules] $paths $interp $flags $norm $format $verbose $output
    return
}

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

proc __oldvalidate_v {} {
    global argv
    if {[llength $argv] == 0} {
	_validate_all_v
    } else {
	if {![checkmod]} {return}
	foreach m [dealias $argv] {
	    _validate_module_v $m
	}
    }
    return
}

proc _validate_all_v {} {
    global package_name package_version
    set i 0

    puts "Validating $package_name $package_version development"
    puts "==================================================="
    puts "[incr i]: Consistency of package versions ..."
    puts "------------------------------------------------------"
    validate_versions
    puts "------------------------------------------------------"
    puts ""
    return
}

proc _validate_module_v {m} {
    global package_name package_version
    set i 0

    puts "Validating $package_name $package_version development -- $m"
    puts "==================================================="
    puts "[incr i]: Consistency of package versions ..."
    puts "------------------------------------------------------"
    validate_versions_mod $m
    puts "------------------------------------------------------"
    puts ""
    return
}


proc __oldvalidate {} {
    global argv
    if {[llength $argv] == 0} {
	_validate_all
    } else {
	if {![checkmod]} {return}
	foreach m $argv {
	    _validate_module $m
	}
    }
    return
}

proc _validate_all {} {
    global package_name package_version
    set i 0

    puts "Validating $package_name $package_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]: Consistency of package versions ..."
    puts "------------------------------------------------------"
    validate_versions
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Installed vs. developed modules ..."
    puts "------------------------------------------------------"
    validate_imodules
    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]
    set tclchecker [auto_execok tclchecker]
    set nagelfar [auto_execok nagelfar]

    if {$frink == {}} {puts "  Tool 'frink'    not found, no check"}
    if {($procheck == {}) || ($tclchecker == {})} {
	puts "  Tools 'procheck'/'tclchecker' not found, no check"
    }
    if {$nagelfar == {}} {puts "  Tool 'nagelfar' not found, no check"}

    if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) 
        || ($nagelfar == {})} {
	puts "------------------------------------------------------"
    }
    if {($frink == {}) && ($procheck == {}) && ($tclchecker == {})
        && ($nagelfar == {})} {
	return
    }
    if {$frink != {}} {
	run-frink
	puts "------------------------------------------------------"
    }
    if {$tclchecker != {}} {
	run-tclchecker
	puts "------------------------------------------------------"
    } elseif {$procheck != {}} {
	run-procheck
	puts "------------------------------------------------------"
    }
    if {$nagelfar    !={}} {
    	run-nagelfar 
	puts "------------------------------------------------------"
    }
    puts ""
    return
}

proc _validate_module {m} {
    global package_name package_version
    set i 0

    puts "Validating $package_name $package_version development -- $m"
    puts "==================================================="
    puts "[incr i]: Existence of testsuites ..."
    puts "------------------------------------------------------"
    validate_testsuite_mod $m
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Existence of package indices ..."
    puts "------------------------------------------------------"
    validate_pkgIndex_mod $m
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Consistency of package versions ..."
    puts "------------------------------------------------------"
    validate_versions_mod $m
    puts "------------------------------------------------------"
    puts ""

    #puts "[incr i]: Installed vs. developed modules ..."
    puts "------------------------------------------------------"
    validate_imodules_mod $m
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Existence of documentation ..."
    puts "------------------------------------------------------"
    validate_doc_existence_mod $m
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Validate documentation markup (doctools) ..."
    puts "------------------------------------------------------"
    validate_doc_markup_mod $m
    puts "------------------------------------------------------"
    puts ""

    puts "[incr i]: Static syntax check ..."
    puts "------------------------------------------------------"

    set frink    [auto_execok frink]
    set procheck [auto_execok procheck]
    set nagelfar [auto_execok nagelfar]
    set tclchecker [auto_execok tclchecker]
    
    if {$frink    == {}} {puts "  Tool 'frink'    not found, no check"}
    if {($procheck == {}) || ($tclchecker == {})} {
	puts "  Tools 'procheck'/'tclchecker' not found, no check"
    }
    if {$nagelfar == {}} {puts "  Tool 'nagelfar' not found, no check"}
    
    if {($frink == {}) || ($procheck == {}) || ($tclchecker == {}) ||
    	($nagelfar == {})} {
	puts "------------------------------------------------------"
    }
    if {($frink == {}) && ($procheck == {}) && ($nagelfar == {})
        && ($tclchecker == {})} {
	return
    }
    if {$frink    != {}} {
	run-frink $m
	puts "------------------------------------------------------"
    }
    if {$tclchecker != {}} {
	run-tclchecker $m
	puts "------------------------------------------------------"
    } elseif {$procheck != {}} {
	run-procheck $m
	puts "------------------------------------------------------"
    }
    if {$nagelfar    !={}} {
    	run-nagelfar $m
	puts "------------------------------------------------------"
    }
    puts ""

    return
}

# --------------------------------------------------------------
# Release engineering

proc __gendist {} {
    gd-cleanup
    gd-tip55
    gd-gen-rpmspec
    gd-gen-tap
    gd-gen-yml
    gd-assemble
    gd-gen-archives

    puts ...Done
    return
}

proc __gentip55 {} {
    gd-tip55
    puts "Created DESCRIPTION.txt"
    return
}

proc __yml {} {
    global package_name
    gd-gen-yml
    puts "Created YAML spec file \"${package_name}.yml\""
    return
}

proc __contributors {} {
    global contributors
    contributors
    foreach person [lsort [array names contributors]] {
        puts "$person <$contributors($person)>"
    }
    return
}

proc __tap {} {
    global package_name
    gd-gen-tap
    puts "Created Tcl Dev Kit \"${package_name}.tap\""
}

proc __rpmspec {} {
    global package_name
    gd-gen-rpmspec
    puts "Created RPM spec file \"${package_name}.spec\""
}


proc __release {} {
    # Regenerate PACKAGES, and extend

    global argv argv0 distribution package_name package_version

    getpackage textutil textutil/textutil.tcl

    if {[llength $argv] != 2} {
	puts stderr "$argv0: wrong#args: release name sf-user-id"
	exit 1
    }

    foreach {name sfuser} $argv break
    set email "<${sfuser}@users.sourceforge.net>"
    set pname [textutil::cap $package_name]

    set notice "[clock format [clock seconds] -format "%Y-%m-%d"]  $name  $email

	*
	* Released and tagged $pname $package_version ========================
	* 

"

    set logs [list [file join $distribution ChangeLog]]
    foreach m [modules] {
	set m [file join $distribution modules $m ChangeLog]
	if {![file exists $m]} continue
	lappend logs $m
    }

    foreach f $logs {
	puts "\tAdding release notice to $f"
	set fh [open $f r] ; set data [read $fh] ; close $fh
	set fh [open $f w] ; puts -nonewline $fh $notice$data ; close $fh
    }

    gd-gen-packages
    return
}

# --------------------------------------------------------------
# Documentation

proc __desc  {} {
    global argv ; if {![checkmod]} return
    array set pd [getpdesc]

    getpackage struct::matrix struct/matrix.tcl
    getpackage textutil       textutil/textutil.tcl

    struct::matrix m
    m add columns 3

    puts {Descriptions...}
    if {[llength $argv] == 0} {set argv [modules]}

    foreach m [lsort [dealias $argv]] {
	array set _ {}
	set pkg {}
	foreach {p vlist} [ppackages $m] {
	    catch {set _([lindex $pd($p) 0]) .}
	    lappend pkg $p
	}
	set desc [string trim [join [array names _] ", "] " \n\t\r,"]
	set desc [textutil::adjust $desc -length 20]
	unset _

	m add row [list $m $desc]
	m add row {}

	foreach p [lsort -dictionary $pkg] {
	    set desc ""
	    catch {set desc [lindex $pd($p) 1]}
	    if {$desc != ""} {
		set desc [string trim $desc]
		set desc [textutil::adjust $desc -length 50]
		m add row [list {} $p $desc]
	    } else {
		m add row [list {**} $p ]
	    }
	}
	m add row {}
    }

    m format 2chan
    puts ""
    return
}

proc __desc/2  {} {
    global argv ; if {![checkmod]} return
    array set pd [getpdesc]

    getpackage struct::matrix struct/matrix.tcl
    getpackage textutil       textutil/textutil.tcl

    puts {Descriptions...}
    if {[llength $argv] == 0} {set argv [modules]}

    foreach m [lsort [dealias $argv]] {
	struct::matrix m
	m add columns 3

	m add row {}

	set pkg {}
	foreach {p vlist} [ppackages $m] {lappend pkg $p}

	foreach p [lsort -dictionary $pkg] {
	    set desc ""
	    set sdes ""
	    catch {set desc [lindex $pd($p) 1]}
	    catch {set sdes [lindex $pd($p) 0]}

	    if {$desc != ""} {
		set desc [string trim $desc]
		#set desc [textutil::adjust $desc -length 50]
	    }

	    if {$desc != ""} {
		set desc [string trim $desc]
		#set desc [textutil::adjust $desc -length 50]
	    }

	    m add row [list $p "  $sdes" "  $desc"]
	}
	m format 2chan
	puts ""
	m destroy
    }

    return
}

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

proc __docstrip/users {} {
    # Print the list of modules using docstrip for their code.

    set argv [modules]
    foreach m [lsort $argv] {
	if {[docstripUser $m]} {
	    puts $m
	}
    }

    return
}

proc __docstrip/regen {} {
    # Regenerate modules based on docstrip.

    global argv ; if {![checkmod]} return
    if {[llength $argv] == 0} {set argv [modules]}

    foreach m [lsort [dealias $argv]] {
	if {[docstripUser $m]} {
	    docstripRegen $m
	}
    }

    return
}

# --------------------------------------------------------------
## Make sak specific packages visible.

lappend auto_path [file join $distribution support devel sak]

# --------------------------------------------------------------
## Dispatcher to the sak commands.

set  cmd  [lindex $argv 0]
set  argv [lrange $argv 1 end]
incr argc -1

# Prefer a command implementation found in the support tree.
# Then see if the command is implemented here, in this file.
# At last fail and report possible commands.

set base  [file dirname [info script]]
set sbase [file join $base support devel sak]
set cbase [file join $sbase $cmd]
set cmdf  [file join $cbase cmd.tcl]

if {[file exists $cmdf] && [file readable $cmdf]} {
    source $cmdf
    exit 0
}

if {[llength [info procs __$cmd]] == 0} {
    puts stderr "$argv0 : Illegal command \"$cmd\""
    set fl {}
    foreach p [info procs __*] {
	lappend fl [string range $p 2 end]
    }
    foreach p [glob -nocomplain -directory $sbase */cmd.tcl] {
	lappend fl [lindex [file split $p] end-1]
    }

    regsub -all . $argv0 { } blank
    puts stderr "$blank : Should have been [linsert [join [lsort -uniq $fl] ", "] end-1 or]"
    exit 1
}

__$cmd
exit 0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/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
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
# 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.1 2009/02/07 05:18:22 andreas_kupries Exp $

catch {wm withdraw .}

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 ""] } {
	    # Ignore calls in the master.
	    return
	}

	# When called from a slave copy the information found in the
	# slave to here and update our own data.

	# Get total/pass/skip/fail counts
	array set foo [$c eval {array get ::tcltest::numTests}]
	foreach index {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 {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 \
	[file dirname [file dirname [info script]]]]

# We need to ensure that the testsDirectory is absolute
if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} {
    # The version of tcltest we have here does not support
    # 'normalizePath', so we have to do this on our own.

    set oldpwd [pwd]
    catch {cd $::tcltest::testsDirectory}
    set ::tcltest::testsDirectory [pwd]
    cd $oldpwd
}
set root $::tcltest::testsDirectory

proc Note {k v} {
    puts  stdout [list @@ $k $v]
    flush stdout
    return
}
proc Now {} {return [clock seconds]}

puts stdout ""
Note Host       [info hostname]
Note Platform   $tcl_platform(os)-$tcl_platform(osVersion)-$tcl_platform(machine)
Note CWD        $::tcltest::testsDirectory
Note Shell      [info nameofexecutable]
Note Tcl        [info patchlevel]

# Host  => Platform | Identity of the Test environment.
# Shell => Tcl      |
# CWD               | Identity of the Taolib under test.

if {[llength $::tcltest::skip]}       {Note SkipTests  $::tcltest::skip}
if {[llength $::tcltest::match]}      {Note MatchTests $::tcltest::match}
if {[llength $::tcltest::skipFiles]}  {Note SkipFiles  $::tcltest::skipFiles}
if {[llength $::tcltest::matchFiles]} {Note MatchFiles $::tcltest::matchFiles}

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 [lsort -dict [array names tmp]]
    unset tmp
}

Note Start [Now]

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]

    # For each module, make a slave interp and source that module's
    # tests into the slave. This isolates the test suites from one
    # another.

    Note Module [file tail $module]

    set c [interp create]
    interp alias $c pSet {} set
    interp alias $c Note {} Note

    $c eval {
	# import the auto_path from the parent interp,
	# so "package require" works

	set ::auto_path    [pSet ::auto_path]
	set ::argv0        [pSet ::argv0]
	set ::tcllibModule [pSet module]

	# The next command allows the execution of 'tk' constrained
	# tests, if Tk is present (for example when this code is run
	# run by 'wish').

	# Under wish 8.2/8.3 we have to explicitly load Tk into the
	# slave, the package management is not able to.

	if {![package vsatisfies [package provide Tcl] 8.4]} {
	    catch {
		load {} Tk
		wm withdraw .
	    }
	} else {
	    catch {
		package require Tk
		wm withdraw .
	    }
	}

	package require tcltest

	# Re-import, the loading of an older tcltest package reset it
	# to the standard set of paths.
	set ::auto_path [pSet ::auto_path]

	namespace import ::tcltest::*
	set ::tcltest::testSingleFile false
	set ::tcltest::testsDirectory [pSet ::tcltest::testsDirectory]

	# configure not present in tcltest 1.x
	if {[catch {::tcltest::configure -verbose bstep}]} {
	    set ::tcltest::verbose psb
	}
    }

    interp alias \
	    $c ::tcltest::cleanupTestsHook \
	    {} ::tcltest::cleanupTestsHook $c

    # source each of the specified tests
    foreach file [lsort [::tcltest::getMatchingFiles]] {
	set tail [file tail $file]
	Note Testsuite [string map [list "$root/" ""] $file]
	$c eval {
	    if {[catch {source [pSet file]} msg]} {
		puts stdout "@+"
		puts stdout @|[join [split $errorInfo \n] "\n@|"]
		puts stdout "@-"
	    }
	}
    }
    interp delete $c
    puts stdout ""
}

# cleanup
Note End [Now]
::tcltest::cleanupTests 1
# FRINK: nocheck
# Use of 'exit' ensures proper termination of the test system when
# driven by a 'wish' instead of a 'tclsh'. Otherwise 'wish' would
# enter its regular event loop and no tests would complete.
exit

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
















































































































































































































































































































































































































































































Deleted support/devel/doc/feedback.inc.

1
2
3
4
5
6
7
8
9
10
11
12
[section {Bugs, Ideas, Feedback}]
[vset TRACKER http://fossil.etoyoc.com/fossil/taolib/reportlist]
[vset LABEL   {Taolib Trackers}]

This document, and the package it describes, will undoubtedly contain
bugs and other problems.

Please report such in the category [emph [vset CATEGORY]] of the
[uri [vset TRACKER] [vset LABEL]].

Please also report any ideas for enhancements you may have for either
package and/or documentation.
<
<
<
<
<
<
<
<
<
<
<
<
























Deleted support/devel/sak/doc/cmd.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
# -*- tcl -*-
# Implementation of 'doc'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

if {![llength $argv]} {
    set format * 
} else {
    set format [lindex $argv 0]*
    set argv   [lrange $argv 1 end]
}

package require sak::util
if {![sak::util::checkModules argv]} return

set matches 0
foreach f {
    html nroff tmml text wiki latex dvi ps pdf list validate imake ishow index
} {
    if {![string match $format $f]} continue
    incr matches
}
if {!$matches} {
    puts "  No format matching \"$format\""
    return
}

# ###

package require sak::doc

foreach f {
    html nroff tmml text wiki latex dvi ps pdf list validate imake ishow index
} {
    if {![string match $format $f]} continue
    sak::doc::$f $argv
}

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































Deleted support/devel/sak/doc/doc.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
# -*- tcl -*-
# sak::doc - Documentation facilities

package require sak::util
package require sak::doc::auto

namespace eval ::sak::doc {}

# ###
# API commands

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

proc ::sak::doc::index {modules} {
    # The argument (= set of modules) is irrelevant to this command.
    global base

    # First locate all manpages in the CVS workspace.
    set manpages [auto::findManpages $base]
    auto::saveManpages $manpages

    # Then scan the found pages and extract the information needed for
    # keyword index and table of contents.
    array set meta [auto::scanManpages $manpages]

    # Sort through the extracted data.
    array set kwic  {} ; # map: keyword  -> list (file...)
    array set title {} ; # map: file     -> description
    array set cat   {} ; # map: category -> list (file...)
    array set name  {} ; # map: file     -> label
    set       apps  {} ; # list (file...) 
    array set mods  {} ; # map: module   -> list(file...)

    foreach page [array names meta] {
	unset -nocomplain m
	array set m $meta($page)

	# Collect keywords and file mapping for index.
	foreach kw $m(keywords) {
	    lappend kwic($kw) $page
	}
	# Get page title, relevant for display order
	if {$m(desc) eq ""} {
	    set m(desc) $m(shortdesc)
	}
	set title($page) $m(desc)
	# Get page name/title, relevant for display order.
	set name($page) $m(title)
	# Get page category, for sectioning and display order in the
	# table of contents
	if {$m(category) ne ""} {
	    set c $m(category)
	} else {
	    set c Unfiled
	}
	lappend cat($c) $page
	
	# Type of documented entity
	set type [lindex [file split $page] 0]
	if {$type eq "apps"} {
	    lappend apps $page
	} else {
	    lappend mods([lindex [file split $page] 1]) $page
	}
    }

    #parray meta
    #parray kwic
    #parray title
    #parray name
    #parray cat
    #puts "apps = $apps"
    #parray mods

    auto::saveKeywordIndex           kwic  name
    auto::saveTableOfContents        title name cat apps mods
    auto::saveSimpleTableOfContents1 title name apps toc_apps.txt
    auto::saveSimpleTableOfContents2 title name mods toc_mods.txt
    auto::saveSimpleTableOfContents3 title name cat  toc_cats.txt
    return
}

proc ::sak::doc::imake {modules} {
    global base
    # The argument (= set of modules) is irrelevant to this command.
    auto::saveManpages [auto::findManpages $base]
    return
}

proc ::sak::doc::ishow {modules} {
    if {[catch {
	set manpages [auto::loadManpages]
    } msg]} {
	puts stderr "Unable to use manpage listing '[auto::manpages]'\n$msg"
    } else {
	puts [join $manpages \n]
    }
    return
}

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

proc ::sak::doc::validate {modules} {Gen null  null $modules}
proc ::sak::doc::html     {modules} {Gen html  html $modules}
proc ::sak::doc::nroff    {modules} {Gen nroff n    $modules}
proc ::sak::doc::tmml     {modules} {Gen tmml  tmml $modules}
proc ::sak::doc::text     {modules} {Gen text  txt  $modules}
proc ::sak::doc::wiki     {modules} {Gen wiki  wiki $modules}
proc ::sak::doc::latex    {modules} {Gen latex tex  $modules}

proc ::sak::doc::dvi {modules} {
    latex $modules
    file mkdir [file join doc dvi]
    cd         [file join doc dvi]

    foreach f [lsort -dict [glob -nocomplain ../latex/*.tex]] {

	set target [file rootname [file tail $f]].dvi
	if {[file exists $target] 
	    && [file mtime $target] > [file mtime $f]} {
	    continue
	}

	puts "Gen (dvi): $f"
	exec latex $f 1>@ stdout 2>@ stderr
    }
    cd ../..
    return
}

proc ::sak::doc::ps {modules} {
    dvi $modules
    file mkdir [file join doc ps]
    cd         [file join doc ps]
    foreach f [lsort -dict [glob -nocomplain ../dvi/*.dvi]] {

	set target [file rootname [file tail $f]].ps
	if {[file exists $target] 
	    && [file mtime $target] > [file mtime $f]} {
	    continue
	}

	puts "Gen (ps): $f"
	exec dvips -o $target $f >@ stdout 2>@ stderr
    }
    cd ../..
    return
}

proc ::sak::doc::pdf {modules} {
    dvi $modules
    file mkdir [file join doc pdf]
    cd         [file join doc pdf]
    foreach f [lsort -dict [glob -nocomplain ../ps/*.ps]] {

	set target [file rootname [file tail $f]].pdf
	if {[file exists $target] 
	    && [file mtime $target] > [file mtime $f]} {
	    continue
	}

	puts "Gen (pdf): $f"
	exec ps2pdf $f $target >@ stdout 2>@ stderr
    }
    cd ../..
    return
}

proc ::sak::doc::list {modules} {
    Gen list l $modules
    
    set FILES [glob -nocomplain doc/list/*.l]
    set LIST  [open [file join doc list manpages.tcl] w]

    foreach file $FILES {
        set f [open $file r]
        puts $LIST [read $f]
        close $f
    }
    close $LIST

    eval file delete -force $FILES
    return
}

# ### ### ### ######### ######### #########
## Implementation

proc ::sak::doc::Gen {fmt ext modules} {
    global distribution
    global tcl_platform

    getpackage doctools doctools/doctools.tcl

    set null   0 ; if {![string compare $fmt null]} {set null   1}
    set hidden 0 ; if {![string compare $fmt desc]} {set hidden 1}

    if {!$null} {
	file mkdir [file join doc $fmt]
	set prefix "Gen ($fmt)"
    } else {
	set prefix "Validate  "
    }

    foreach m $modules {
	set mpath [sak::util::module2path $m]

	::doctools::new dt \
		-format $fmt \
		-module $m

	set fl [glob -nocomplain [file join $mpath *.man]]

	if {[llength $fl] == 0} {
	    dt destroy
	    continue
	}

	foreach f $fl {
	    if {!$null} {
                set target [file join doc $fmt \
                                [file rootname [file tail $f]].$ext]
                if {[file exists $target] 
                    && [file mtime $target] > [file mtime $f]} {
                    continue
                }
	    }
	    if {!$hidden} {puts "$prefix: $f"}

	    dt configure -file $f
	    if {$null} {
		dt configure -deprecated 1
	    }

	    set fail [catch {
		set data [dt format [get_input $f]]
	    } msg]

	    set warnings [dt warnings]
	    if {[llength $warnings] > 0} {
		puts stderr [join $warnings \n]
	    }

	    if {$fail} {
		puts stderr $msg
		continue
	    }

	    if {!$null} {
		write_out $target $data
	    }
	}
	dt destroy
    }
}

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

package provide sak::doc 1.0

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































Deleted support/devel/sak/doc/doc_auto.tcl.

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

package require sak::util

namespace eval ::sak::doc::auto {
    set here [file dirname [file normalize [info script]]]
}

getpackage fileutil         fileutil/fileutil.tcl
getpackage doctools         doctools/doctools.tcl
getpackage textutil::repeat textutil/repeat.tcl

# ###
# API commands

proc ::sak::doc::auto::manpages {} {
    variable here
    return [file join $here manpages.txt]
}

proc ::sak::doc::auto::kwic {} {
    variable here
    return [file join $here kwic.txt]
}

proc ::sak::doc::auto::toc {{name toc.txt}} {
    variable here
    return [file join $here $name]
}

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

proc ::sak::doc::auto::findManpages {base} {
    set top [file normalize $base]
    set manpages {}
    foreach page [concat \
		      [glob -nocomplain -directory $top/modules */*.man] \
		      [glob -nocomplain -directory $top/apps      *.man]] {
	lappend manpages [fileutil::stripPath $top $page]
    }
    return [lsort -dict $manpages]
}

proc ::sak::doc::auto::saveManpages {manpages} {
    fileutil::writeFile [manpages] [join [lsort -dict $manpages] \n]\n
    return
}

proc ::sak::doc::auto::loadManpages {} {
    return [lsort -dict [split [fileutil::cat [manpages]] \n]]
}

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

proc ::sak::doc::auto::scanManpages {manpages} {
    ::doctools::new dt -format list
    set data {}
    puts Scanning...
    foreach page $manpages {
	puts ...$page
	dt configure -ibase $page
	lappend data $page [lindex [dt format [fileutil::cat $page]] 1]
    }

    dt destroy
    return $data
}

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

proc ::sak::doc::auto::saveKeywordIndex {kv nv} {
    upvar 1 $kv kwic $nv name
    # kwic: keyword -> list (files)
    # name: file    -> label

    TagsBegin
    Tag+ index_begin [list {Keyword Index} {}]

    # Handle the keywords in dictionary order for nice display.
    foreach kw [lsort -dict [array names kwic]] {
	set tmp [Sortable $kwic($kw) name max _]

	Tag+ key [list $kw]
	foreach item [lsort -dict -index 0 $tmp] {
	    foreach {label file} $item break
	    Tag+ manpage [FmtR max $file] [list $label]
	}
    }

    Tag+ index_end

    fileutil::writeFile [kwic] [join $lines \n]
    return
}

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

proc ::sak::doc::auto::saveTableOfContents {tv nv cv av mv} {
    upvar 1 $tv title $nv name $cv cat $av apps $mv mods
    # title: file     -> description
    # name:  file     -> label
    # cat:   category -> list (file...)

    TagsBegin
    Tag+ toc_begin [list {Table Of Contents} {}]

    # The man pages are sorted in several ways for the toc.
    # 1. First section by category. Subsections are categories.
    #    Sorted by category name, in dictionary order.
    #    Inside the subsections the files, sorted by label and
    #    description.
    # 2. Second section for types. Subsections are modules and apps.
    #    Apps first, then modules. For apps items directly, sorted
    #    by name and description. For modules one sub-subsection
    #    per module, elements the packages, sorted by label and
    #    description.

    Tag+ division_start [list {By Categories}]
    foreach c [lsort -dict [array names cat]] {
	Tag+ division_start [list $c]
	foreach item [lsort -dict -index 0 [Sortable $cat($c) name maxf maxl]] {
	    foreach {label file} $item break
	    Tag+ item \
		[FmtR maxf $file] \
		[FmtR maxl $label] \
		[list $title($file)]
	}
	Tag+ division_end
    }
    Tag+ division_end

    Tag+ division_start [list {By Type}]
    # Not handled: 'no applications'
    Tag+ division_start [list {Applications}]
    foreach item [lsort -dict -index 0 [Sortable $apps name maxf maxl]] {
	foreach {label file} $item break
	Tag+ item \
	    [FmtR maxf $file] \
	    [FmtR maxl $label] \
	    [list $title($file)]
    }
    Tag+ division_end
    # Not handled: 'no modules'
    Tag+ division_start [list {Modules}]
    foreach m [lsort -dict [array names mods]] {
	Tag+ division_start [list $m]
	foreach item [lsort -dict -index 0 [Sortable $mods($m) name maxf maxl]] {
	    foreach {label file} $item break
	    Tag+ item \
		[FmtR maxf $file] \
		[FmtR maxl $label] \
		[list $title($file)]
	}
	Tag+ division_end
    }
    Tag+ division_end
    Tag+ division_end
    Tag+ toc_end

    fileutil::writeFile [toc] [join $lines \n]
    return
}

proc ::sak::doc::auto::saveSimpleTableOfContents1 {tv nv dv fname} {
    upvar 1 $tv title $nv name $dv data
    # title: file     -> description
    # name:  file     -> label
    # data:  list(file...)

    TagsBegin
    Tag+ toc_begin [list {Table Of Contents} {}]

    # The man pages are sorted in several ways for the toc.
    # Subsections are the modules or apps, whatever is in data.

    # Not handled: 'no applications'
    Tag+ division_start [list {Applications}]
    foreach item [lsort -dict -index 0 [Sortable $data name maxf maxl]] {
	foreach {label file} $item break
	Tag+ item \
	    [FmtR maxf $file] \
	    [FmtR maxl $label] \
	    [list $title($file)]
    }
    Tag+ division_end
    Tag+ toc_end

    fileutil::writeFile [toc $fname] [join $lines \n]
    return
}

proc ::sak::doc::auto::saveSimpleTableOfContents2 {tv nv dv fname} {
    upvar 1 $tv title $nv name $dv data
    # title: file     -> description
    # name:  file     -> label
    # data:  module -> list (file...)

    TagsBegin
    Tag+ toc_begin [list {Table Of Contents} {}]

    # The man pages are sorted in several ways for the toc.
    # Subsections are the modules or apps, whatever is in data.

    # Not handled: 'no modules'
    Tag+ division_start [list {Modules}]
    foreach m [lsort -dict [array names data]] {
	Tag+ division_start [list $m]
	foreach item [lsort -dict -index 0 [Sortable $data($m) name maxf maxl]] {
	    foreach {label file} $item break
	    Tag+ item \
		[FmtR maxf $file] \
		[FmtR maxl $label] \
		[list $title($file)]
	}
	Tag+ division_end
    }
    Tag+ division_end
    Tag+ toc_end

    fileutil::writeFile [toc $fname] [join $lines \n]
    return
}

proc ::sak::doc::auto::saveSimpleTableOfContents3 {tv nv cv fname} {
    upvar 1 $tv title $nv name $cv cat
    # title: file     -> description
    # name:  file     -> label
    # cat:   category -> list (file...)

    TagsBegin
    Tag+ toc_begin [list {Table Of Contents} {}]

    Tag+ division_start [list {By Categories}]
    foreach c [lsort -dict [array names cat]] {
	Tag+ division_start [list $c]
	foreach item [lsort -dict -index 0 [Sortable $cat($c) name maxf maxl]] {
	    foreach {label file} $item break
	    Tag+ item \
		[FmtR maxf $file] \
		[FmtR maxl $label] \
		[list $title($file)]
	}
	Tag+ division_end
    }
    Tag+ division_end
    Tag+ toc_end

    fileutil::writeFile [toc $fname] [join $lines \n]
    return
}

proc ::sak::doc::auto::Sortable {files nv mfv mnv} {
    upvar 1 $nv name $mfv maxf $mnv maxn
    # Generate a list of files sortable by name, and also find the
    # max length of all relevant names.
    set maxf 0
    set maxn 0
    set tmp {}
    foreach file $files {
	lappend tmp [list $name($file) $file]
	Max maxf $file
	Max maxn $name($file)
    }
    return $tmp
}

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

proc ::sak::doc::auto::Max {v str} {
    upvar 1 $v max
    set x [string length $str]
    if {$x <= $max} return
    set max $x
    return
}

proc ::sak::doc::auto::FmtR {v str} {
    upvar 1 $v max
    return [list $str][textutil::repeat::blank \
	    [expr {$max - [string length [list $str]]}]]
}

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

proc ::sak::doc::auto::Tag {n args} {
    if {[llength $args]} {
	return "\[$n [join $args]\]"
    } else {
	return "\[$n\]"
    }
    #return \[[linsert $args 0 $n]\]
}

proc ::sak::doc::auto::Tag+ {n args} {
    upvar 1 lines lines
    lappend lines [eval [linsert $args 0 ::sak::doc::auto::Tag $n]]
    return
}

proc ::sak::doc::auto::TagsBegin {} {
    upvar 1 lines lines
    set lines {}
    return
}

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

package provide sak::doc::auto 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/doc/help.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

    doc -- Generate and/or validate documentation

    sak doc ?format? ?module...?

        Convert the documentation for the specified module into the
        given format. Modules can be specified by their plain name, or
        as relative path.

	The special format 'validate' causes the tool to syntax check
        of the input without generating actual output. When output is
        generated it is written into the sub-directory 'doc'/format of
        the current working directory.

	The special format 'imake' scans the checkout for manpages and
	saves the list of found files into a file in the support
	directory. This files will be put into CVS. The special format
	'ishow' will dump the contents of this list to stdout. Both
	have been added to make it easy to verify that a checkout has
	all manpages it should have. These two formats ignore any
	module information they are given.

	The format is actually a glob and output is generated for all
	known formats matching it. It is implicitly padded with a * to
	allow the use of prefixes.

        The known output formats (beyond 'validate') are

        - dvi     See latex, + conversion to dvi (via 'latex' application)
        - html    HTML pages
        - latex   LaTeX pages
        - list    A list of manpages
        - nroff   Manpages
        - ps      See dvi, + conversion to PostScript (via 'dvips' application)
	- pdf     See ps, + conversion to PDF (via 'ps2pdf' application)
        - text    Plain text
        - tmml    TMML (Tcl Manpage Markup Language)
        - wiki    Wiki markup (Tcler's Wiki)

	- validate     Validate syntax, no output
	- imake	       Make list of all manpages and save in checkout, no output.
	- ishow	       Print list of manpages saved in checkout to stdout.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































Deleted support/devel/sak/doc/kwic.txt.

1
2
3
[index_begin {Keyword Index} {}]
[key {Core}]
[index_end]
<
<
<






Deleted support/devel/sak/doc/manpages.txt.

Deleted support/devel/sak/doc/pkgIndex.tcl.

1
2
3
4
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::doc       1.0 [list source [file join $dir doc.tcl]]
package ifneeded sak::doc::auto 1.0 [list source [file join $dir doc_auto.tcl]]

<
<
<
<








Deleted support/devel/sak/doc/toc.txt.

1
2
[toc_begin {Table Of Contents} {}]
[toc_end]
<
<




Deleted support/devel/sak/doc/toc_apps.txt.

1
2
[toc_begin {Table Of Contents} {}]
[toc_end]
<
<




Deleted support/devel/sak/doc/toc_cats.txt.

1
2
[toc_begin {Table Of Contents} {}]
[toc_end]
<
<




Deleted support/devel/sak/doc/toc_mods.txt.

1
2
[toc_begin {Table Of Contents} {}]
[toc_end]
<
<




Deleted support/devel/sak/doc/topic.txt.

1
doc		Generate documentation in various formats, and/or validate it.
<


Deleted support/devel/sak/help/cmd.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
# -*- tcl -*-
# Implementation of 'help'.

# Available variables
# * argv  - Cmdline arguments

if {[llength $argv] > 2} {
    puts stderr "Usage: $argv0 help ?topic?"
    exit 1
}

package require sak::help

if {[llength $argv] == 1} {
    # Argument is a topic.
    # Locate text for the topic.

    sak::help::print [sak::help::on [lindex $argv 0]]
    return
}

sak::help::print [sak::help::alltopics]

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted support/devel/sak/help/help.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

namespace eval ::sak::help {}

# ###

proc ::sak::help::print {text} {
    global critcldefault
    puts stdout [string map \
	    [list @@ $critcldefault] $text]
    return
}

proc ::sak::help::on {topic} {
    variable base

    # Look for static text and dynamic, i.e. generated help.
    # Static is prefered.

    set ht [file join $base $topic help.txt]
    if {[file exists $ht]} {
	return [get_input $ht]
    }

    set ht [file join $base $topic help.tcl]
    if {[file exists $ht]} {
	source $ht
	return [sak::help::on::$topic]
    }

    set    help ""
    append help \n
    append help "    The topic \"$topic\" is not known." \n
    append help "    The known topics are:" \n\n

    append help [topics]

    return $help
}

proc ::sak::help::alltopics {} {
    # Locate the quick-help for all topics and combine it with a
    # general header.

    set    help "\n"
    append help "    SAK - Swiss Army Knife\n\n"
    append help "    sak is a tool to ease the work"
    append help " of developers and release managers. Try:\n\n"
    append help [topics]

    return $help
}

proc ::sak::help::topics {} {
    variable base
    set help ""
    foreach f [lsort [glob -nocomplain -directory $base */topic.txt]] {
	append help \tsak\ help\ [get_input $f]
    }
    return $help
}

# ###

namespace eval ::sak::help {
    variable base [file join $::distribution support devel sak]
}

##
# ###

package provide sak::help 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































































Deleted support/devel/sak/help/help.txt.

1
2
3
4
5
6
7
8

    help -- Print help message

    sak help ?topic?

        Print a help message about the specified topic. If no topic
        was given then print a general help message about SAK itself,
        and provide a list of the available topics.
<
<
<
<
<
<
<
<
















Deleted support/devel/sak/help/pkgIndex.tcl.

1
2
3
4
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::help 1.0 [list source [file join $dir help.tcl]]


<
<
<
<








Deleted support/devel/sak/help/topic.txt.

1
help		How to use help.
<


Deleted support/devel/sak/localdoc/cmd.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
# -*- tcl -*-
# Implementation of 'localdoc'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

# ###

package require sak::localdoc

if {[llength $argv]} {
    sak::localdoc::usage
}

sak::localdoc::run

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































Deleted support/devel/sak/localdoc/help.txt.

1
2
3
4
5
6
7
8

    localdoc -- Generate documentation for website and installer.

    sak localdoc

        Convert all documentation into html and nroff, for use by the
        installer, and the website. For the latter the results of the
        conversion are stored in the repository itself.
<
<
<
<
<
<
<
<
















Deleted support/devel/sak/localdoc/localdoc.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
# -*- tcl -*-
# sak::doc - Documentation facilities

package require sak::util
package require sak::doc

namespace eval ::sak::localdoc {}

# ###
# API commands

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

proc ::sak::localdoc::usage {} {
    package require sak::help
    puts stdout \n[sak::help::on localdoc]
    exit 1
}

proc ::sak::localdoc::run {} {
    package require cmdline
    package require fileutil
    package require textutil::repeat
    package require doctools      1
    package require doctools::toc 1
    package require doctools::idx 1
    package require dtplite

    set nav ../../../../home

    puts "Reindex the documentation..."
    sak::doc::imake __dummy__
    sak::doc::index __dummy__

    puts "Removing old documentation..."
    file delete -force embedded
    file mkdir embedded/man
    file mkdir embedded/www

    puts "Generating manpages..."
    dtplite::do \
	[list \
	     -exclude {*/doctools/tests/*} \
	     -exclude {*/support/*} \
	     -ext n \
	     -o embedded/man \
	     nroff .]

    # Note: Might be better to run them separately.
    # Note @: Or we shuffle the results a bit more in the post processing stage.

    set map  {
	.man     .html
	modules/ taolib/files/modules/
	apps/    taolib/files/apps/
    }

    set toc  [string map $map [fileutil::cat support/devel/sak/doc/toc.txt]]
    set apps [string map $map [fileutil::cat support/devel/sak/doc/toc_apps.txt]]
    set mods [string map $map [fileutil::cat support/devel/sak/doc/toc_mods.txt]]
    set cats [string map $map [fileutil::cat support/devel/sak/doc/toc_cats.txt]]

    puts "Generating HTML... Pass 1, draft..."
    dtplite::do \
	[list \
	     -toc $toc \
	     -nav {TaoLib Home} $nav \
	     -post+toc Categories $cats \
	     -post+toc Modules $mods \
	     -post+toc Applications $apps \
	     -exclude {*/doctools/tests/*} \
	     -exclude {*/support/*} \
	     -merge \
	     -o embedded/www \
	     html .]

    puts "Generating HTML... Pass 2, resolving cross-references..."
    dtplite::do \
	[list \
	     -toc $toc \
	     -nav {Taolib Home} $nav \
	     -post+toc Categories $cats \
	     -post+toc Modules $mods \
	     -post+toc Applications $apps \
	     -exclude {*/doctools/tests/*} \
	     -exclude {*/support/*} \
	     -merge \
	     -o embedded/www \
	     html .]

    return
}

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

package provide sak::localdoc 1.0

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































Deleted support/devel/sak/localdoc/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::localdoc 1.0 [list source [file join $dir localdoc.tcl]]
<
<




Deleted support/devel/sak/localdoc/topic.txt.

1
2
localdoc	Generate html & nroff documentation for display
				from the website, and the installer.
<
<




Deleted support/devel/sak/old/help.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
        Commands available through the swiss army knife aka SAK:

        help     - This help

        /Configuration
        /===========================================================

        version  - Return the bundle's version number
        major    - Return the bundle's major version number
        minor    - Return the bundle's minor version number
        name     - Return the bundle's package name

        /Development
        /===========================================================

        modules          - Return list of modules.
        contributors     - Print a list of contributors to the bundle.
        lmodules         - See above, however one module per line
        imodules         - Return list of modules known to the installer.
        critcl-modules   - Return a list of modules with critcl enhancements.

        packages         - Return indexed packages in the bundle, plus versions,
                           one package per line. Extracted from the
                           package indices found in the modules.

        provided         - Return list and versions of provided packages
                           (in contrast to indexed).

        critcl ?module?  - Build a critcl module [default is @@].

        bench ?opt? ?module..?
                         - Run benchmark scripts (*.bench).

                Options: -throwerrors 0|1  Propagate errors if set.
                         -match   pattern  Exclude benchmarks not matching the
                                           glob pattern.
                         -rmatch  pattern  S.a, but a regexp pattern.
                         -iters   integer  Max #iterations for all benchmarks.
                         -threads integer  #Threads to use for threaded shells.
                         -o       path     File to write the results too.
                         -format  text|csv|raw Format to use for the results.
                         -norm    column   Normalize results using the specified
                                           column as reference.
                         -verbose          Informational output during the run.
                         -debug            Internal output during the run.

        bench/show ?-o path? ?-format f? ?-norm col? file...

                         Reads the files, merges the data, then
                         writes the result back in the specified
                         format, to the specified file, possibly
                         normalizing to a column. Without a file
                         the result is written to stdout.

        bench/edit ?-o path? ?-format f? file col newvalue

                         Reads the file, changes the interpreter
                         path in the column to a new value. For
                         merging of data from the same interpreter,
                         but possibly different versions of the
                         benchmarked package, like Tcllib.

        bench/del ?-o path? ?-format f? file col...

                         Reads the file and removes the specified
                         columns. To delete unnecessary data in merged
                         results.

        oldvalidate ?module..?     - Check listed modules for problems.
                                  For all modules if none specified.

        oldvalidate_v ?module..?   - Check listed modules for for version
                                  problems. For all modules if none
                                  specified.

        test ?module...?        - Run testsuite for listed modules.
                                  For all modules if none specified.

        docstrip/users             - List modules using docstrip
        docstrip/regen ?module...? - Regenerate the sources of all
                                     or the listed modules from their
                                     docstrip sources.

        /Documentation
        /===========================================================

        desc  ?module...?    - Module/Package descriptions
        desc/2 ?module...?   - Module/Package descriptions, alternate format.

        /Release engineering
        /===========================================================

        gendist  - Generate distribution from CVS snapshot

        rpmspec  - Generate a RPM spec file for the bundle.
        gentip55 - Generate a TIP55-style DESCRIPTION.txt file.
        yml      - Generate a YAML description file.

        release name sf-user-id
                 - Marks the current state of all files as a new
                   release. This updates all ChangeLog's, and
                   regenerates the contents of PACKAGES
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































Deleted support/devel/sak/old/topic.txt.

1
old		Help for the existing command set.
<


Deleted support/devel/sak/readme/cmd.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
# -*- tcl -*-
# Implementation of 'readme'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

package require sak::util
package require sak::readme

set raw  0
set log  0
set stem {}
set tclv {}

if {[llength $argv]} {
    sak::readme::usage
}

sak::readme::run

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted support/devel/sak/readme/help.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14

    readme -- Generate a readme listing changes to modules and packages.

    sak readme

    	This command compares the current state of the modules and
    	packages and against information from the last release
    	(support/releases/PACKAGES) and generates a README.txt listing
    	the relevant changes (new modules/packages, package version
    	changes, unchanged packages).

	The generated README is written to stdout.

	This is a support command for the release manager.
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























Deleted support/devel/sak/readme/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::readme 1.0 [list source [file join $dir readme.tcl]]
<
<




Deleted support/devel/sak/readme/readme.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
# -*- tcl -*-
# (C) 2009 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require sak::color

namespace eval ::sak::readme {
    namespace import ::sak::color::*
}

# ###

proc ::sak::readme::usage {} {
    package require sak::help
    puts stdout \n[sak::help::on readme]
    exit 1
}

proc ::sak::readme::run {} {
    global package_name package_version

    getpackage struct::set      struct/sets.tcl
    getpackage struct::matrix   struct/matrix.tcl
    getpackage textutil::adjust textutil/adjust.tcl

    set issues {}

    # package -> list(version)
    set old_version    [loadoldv [location_PACKAGES]]
    array set releasep [loadpkglist [location_PACKAGES]]
    array set currentp [ipackages]

    # Determine which packages are potentially changed, from the set
    # of modules touched since the last release, as per their
    # changelog ... (future: md5sum of files in a module, and
    # file/package association).

    set modifiedm [modified-modules]
    array set changed {}
    foreach p [array names currentp] {
	foreach {vlist module} $currentp($p) break
	set currentp($p) $vlist
	set changed($p) [struct::set contains $modifiedm $module]
    }

    LoadNotes

    # Containers for results
    struct::matrix NEW ; NEW add columns 4 ; # module, package, version, notes
    struct::matrix CHG ; CHG add columns 5 ; # module, package, old/new version, notes
    struct::matrix ICH ; ICH add columns 5 ; # module, package, old/new version, notes
    struct::matrix CNT ; CNT add columns 5;
    set UCH {}

    NEW add row {Module Package {New Version} Comments}

    CHG add row [list {} {} "$package_name $old_version" "$package_name $package_version" {}]
    CHG add row {Module Package {Old Version} {New Version} Comments}

    ICH add row [list {} {} "$package_name $old_version" "$package_name $package_version" {}]
    ICH add row {Module Package {Old Version} {New Version} Comments}

    set newp {} ; set chgp {} ; set ichp {}
    set newm {} ; set chgm {} ; set ichm {} ; set uchm {}
    set nm 0
    set np 0

    # Process all packages in all modules ...
    foreach m [lsort -dict [modules]] {
	puts stderr ...$m
	incr nm

	foreach name [lsort -dict [Provided $m]] {
	    #puts stderr ......$p
	    incr np

	    # Define list of versions, if undefined so far.
	    if {![info exists currentp($name)]} {
		set currentp($name) {}
	    }

	    # Detect and process new packages.

	    if {![info exists releasep($name)]} {
		# New package.
		foreach v $currentp($name) {
		    puts stderr .........NEW
		    NEW add row [list $m $name $v [Note $m $name]]
		    lappend newm $m
		    lappend newp $name
		}
		continue
	    }

	    # The package is not new, but possibly changed. And even
	    # if the version has not changed it may have been, this is
	    # indicated by changed(), which is based on the ChangeLog.

	    set vequal [struct::set equal $releasep($name) $currentp($name)]
	    set note   [Note $m $name]

	    if {$vequal && ($note ne {})} {
		if {$note eq "---"} {
		    # The note declares the package as unchanged.
		    puts stderr .........UNCHANGED/1
		    lappend uchm $m
		    lappend UCH $name
		} else {
		    # Note for package without version changes => must be invisible
		    puts stderr .........INVISIBLE-CHANGE
		    Enter $m $name $note ICH
		    lappend ichm $m
		    lappend ichp $name
		}
		continue
	    }

	    if {!$changed($name) && $vequal} {
		# Versions are unchanged, changelog also indicates no
		# change. No particular attention here.
		
		puts stderr .........UNCHANGED/2
		lappend uchm $m
		lappend UCH $name
		continue
	    }

	    if {$changed($name) && !$vequal} {
		# Both changelog and version number indicate a
		# change. Small alert, have to classify the order of
		# changes. But not if there is a note, this is assumed
		# to be the classification.

		if {$note eq {}} {
		    set note "\t=== Classify changes."
		    lappend issues [list $m $name "Classify changes"]
		}
		Enter $m $name $note

		lappend chgm $m
		lappend chgp $name
		continue
	    }

	    #     Changed according to ChangeLog, Version is not. ALERT.
	    # or: Versions changed, but according to changelog nothing
	    #     in the code. ALERT.

	    # Suppress the alert if we have a note, and dispatch per
	    # the note's contents (some tags are special, instructions
	    # to us here).

	    if {($note eq {})} {
		if {$changed($name)} {
		    # Changed according to ChangeLog, Version is not. ALERT.
		    set note "\t<<< MISMATCH. Version ==, ChangeLog ++"
		} else {
		    set note "\t<<< MISMATCH. ChangeLog ==, Version ++"
		}

		lappend issues [list $m $name [string range $note 5 end]]
	    }

	    Enter $m $name $note
	    lappend chgm $m
	    lappend chgp $name
	}
    }

    # .... process the matrices and others results, make them presentable ...

    set newp [llength [lsort -uniq $newp]]
    set newm [llength [lsort -uniq $newm]]
    if {$newp} {
	CNT add row [list $newp {new packages} in $newm modules]
    }

    set chgp [llength [lsort -uniq $chgp]]
    set chgm [llength [lsort -uniq $chgm]]
    if {$chgp} {
	CNT add row [list $chgp {changed packages} in $chgm modules]
    }

    set ichp [llength [lsort -uniq $ichp]]
    set ichm [llength [lsort -uniq $ichm]]
    if {$ichp} {
	CNT add row [list $ichp {internally changed packages} in $ichm modules]
    }

    set uchp [llength [lsort -uniq $UCH]]
    set uchm [llength [lsort -uniq $uchm]]
    if {$uchp} {
	CNT add row [list $uchp {unchanged packages} in $uchm modules]
    }

    CNT add row [list $np {packages, total} in $nm {modules, total}]

    Header Overview
    puts ""
    if {[CNT rows] > 0} {
	puts [Indent "    " [Detrail [CNT format 2string]]]
    }
    puts ""

    if {[NEW rows] > 1} {
	Header "New in $package_name $package_version"
	puts ""
	Sep NEW - [Clean NEW 1 0]
	puts [Indent "    " [Detrail [NEW format 2string]]]
	puts ""
    }

    if {[CHG rows] > 2} {
	Header "Changes from $package_name $old_version to $package_version"
	puts ""
	Sep CHG - [Clean CHG 2 0]
	puts [Indent "    " [Detrail [CHG format 2string]]]
	puts ""
    }

    if {[ICH rows] > 2} {
	Header "Invisible changes (documentation, testsuites)"
	puts ""
	Sep ICH - [Clean ICH 2 0]
	puts [Indent "    " [Detrail [ICH format 2string]]]
	puts ""
    }

    if {[llength $UCH]} {
	Header Unchanged
	puts ""
	puts [Indent "    " [textutil::adjust::adjust \
				 [join [lsort -dict $UCH] {, }] -length 64]]
    }

    variable legend
    puts $legend

    if {![llength $issues]} return

    puts stderr [=red "Issues found ([llength $issues])"]
    puts stderr "  Please run \"./sak.tcl review\" to resolve,"
    puts stderr "  then run \"./sak.tcl readme\" again."
    puts stderr Details:

    struct::matrix ISS ; ISS add columns 3
    foreach issue $issues {
	foreach {m p w} $issue break
	set m "  $m"
	ISS add row [list $m $p $w]
    }

    puts stderr [ISS format 2string]


    puts stderr [=red "Issues found ([llength $issues])"]
    puts stderr "  Please run \"./sak.tcl review\" to resolve,"
    puts stderr "  then run \"./sak.tcl readme\" again."
    return
}

proc ::sak::readme::Header {s {sep =}} {
    puts $s
    puts [string repeat $sep [string length $s]]
    return
}

proc ::sak::readme::Enter {m name note {mat CHG}} {
    upvar 1 currentp currentp releasep releasep

    # To handle multiple versions we match the found versions up by
    # major version. We assume that we have only one version per major
    # version. This allows us to detect changes within each major
    # version, new major versions, etc.

    array set om {} ; foreach v $releasep($name) {set om([lindex [split $v .] 0]) $v}
    array set cm {} ; foreach v $currentp($name) {set cm([lindex [split $v .] 0]) $v}

    set all [lsort -dict [struct::set union [array names om] [array names cm]]]

    sakdebug {
	puts @@@@@@@@@@@@@@@@
	parray om
	parray cm
	puts all\ $all
	puts @@@@@@@@@@@@@@@@
    }

    foreach v $all {
	if {[info exists om($v)]} {set ov $om($v)} else {set ov ""}
	if {[info exists cm($v)]} {set cv $cm($v)} else {set cv ""}
	$mat add row [list $m $name $ov $cv $note]
    }
    return
}

proc ::sak::readme::Clean {m start col} {
    set n [$m rows]
    set marks [list $start]
    set last {}
    set lastm -1
    set sq 0

    for {set i $start} {$i < $n} {incr i} {
	set str [$m get cell $col $i]

	if {$str eq $last} {
	    set sq 1
	    $m set cell $col $i {}
	    if {$lastm >= 0} {
		#puts stderr "@ $i / <$last> / <$str> / ++ $lastm"
		lappend marks $lastm
		set lastm -1
	    } else {
		#puts stderr "@ $i / <$last> / <$str> /"
	    }
	} else {
	    set last $str
	    set lastm $i
	    if {$sq} {
		#puts stderr "@ $i / <$last> / <$str> / ++ $i /saved"
		lappend marks $i
		set sq 0
	    } else {
		#puts stderr "@ $i / <$last> / <$str> / saved"
	    }
	}
    }
    return [lsort -uniq -increasing -integer $marks]
}

proc ::sak::readme::Sep {m char marks} {

    #puts stderr "$m = $marks"

    set n [$m columns]
    set sep {}
    for {set i 0} {$i < $n} {incr i} {
	lappend sep [string repeat $char [expr {2+[$m columnwidth $i]}]]
    }

    foreach k [linsert [lsort -decreasing -integer -uniq $marks] 0 end] {
	$m insert row $k $sep
    }
    return
}

proc ::sak::readme::Indent {pfx text} {
    return ${pfx}[join [split $text \n] \n$pfx]
}

proc ::sak::readme::Detrail {text} {
    set res {}
    foreach line [split $text \n] {
	lappend res [string trimright $line]
    }
    return [join $res \n]
}

proc ::sak::readme::Note {m p} {
    # Look for a note, and present to caller, if any.
    variable notes
    #parray notes
    set k [list $m $p]
    #puts <$k>
    if {[info exists notes($k)]} {
	return [join $notes($k) { }]
    }
    return ""
}

proc ::sak::readme::Provided {m} {
    set result {}
    foreach {p ___} [ppackages $m] {
	lappend result $p
    }
    return $result
}

proc ::sak::readme::LoadNotes {} {
    global distribution
    variable  notes
    array set notes {}

    catch {
	set f [file join $distribution .NOTE]
	set f [open $f r]
	while {![eof $f]} {
	    if {[gets $f line] < 0} continue
	    set line [string trim $line]
	    if {$line == {}} continue
	    foreach {k t} $line break
	    set notes($k) $t
	}
	close $f
    } msg
    return
}

proc ::sak::readme::loadoldv {fname} {
    set f [open $fname r]
    foreach line [split [read $f] \n] {
	set line [string trim $line]
	if {[string match @* $line]} {
	    foreach {__ __ v} $line break
	    close $f
	    return $v
	}
    }
    close $f
    return -code error {Version not found}
}

##
# ###

namespace eval ::sak::readme {
    variable legend {
Legend  Change  Details Comments
        ------  ------- ---------
        Major   API:    ** incompatible ** API changes.

        Minor   EF :    Extended functionality, API.
                I  :    Major rewrite, but no API change

        Patch   B  :    Bug fixes.
                EX :    New examples.
                P  :    Performance enhancement.

        None    T  :    Testsuite changes.
                D  :    Documentation updates.
    }

    variable review {}
}

package provide sak::readme 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/readme/topic.txt.

1
2
readme		Generate a README listing the changes to modules and packages
				since the last release.
<
<




Deleted support/devel/sak/registry/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.3]} return
package ifneeded pregistry 0.1 [list source [file join $dir registry.tcl]]
<
<




Deleted support/devel/sak/registry/registry.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
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin pregistry n 0.1]
[keywords {data store}]
[keywords registry]
[keywords tree]
[copyright {2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[moddesc   {Registry like data store}]
[titledesc {Registry like data store}]
[require Tcl 8.3]
[require pregistry [opt 0.1]]
[description]
[para]

This package provides a class for the creation of registry-like data
storage objects. The contents of each storage are organized in a tree,
with each node managing a set of children and attributes, each
possibly empty. Stores are not persistent by default, but can be made
so through configuring them with a tie backend to talk to.

[section {Class API}]

The package exports a single command, the class command, enabling the
creation of registry instances. Its API is:

[list_begin definitions]

[call [cmd ::pregistry] [arg object] [arg options]...]

This command creates a new registry object with the name [arg object],
initializes it, and returns the fully qualified name of the object
command as its result.

[para]

The recognized options are explained in section [sectref OPTIONS].

[list_end]

[section {Object API}]

The objects created by the class command provide the methods listed below:

[list_begin definitions]
[call [arg object] [method delete] [arg key] [opt [arg attr]]]

If the optional [arg attr] argument is present, the specified
attribute under [arg key] will be deleted from the object.

If the optional [arg attr] is omitted, the specified [arg key] and any
subkeys or attributes beneath it in the hierarchy will be deleted. If
the key could not be deleted then an error is generated. If the key
did not exist, the command has no effect.

The command returns the empty string as its result.

[call [arg object] [method mtime] [arg key] [opt [arg attr]]]

If the optional [arg attr] argument is present, the time of the last
modification of the specified attribute under [arg key] will be
returned, in seconds since the epoch.

If the optional [arg attr] is omitted, the time of the last
modification of the specified [arg key] will be returned.

If the key did not exist, the command will generate an error.

[call [arg object] [method exists] [arg key] [opt [arg attr]]]

If the optional [arg attr] argument is present, the method checks
whether the specified attribute under [arg key] is present or not.

If the optional [arg attr] is omitted, the method checks whether the
specified [arg key] is present or not.

In both cases the result returned is boolean value, [const True] if
the checked entity exists, and [const False] otherwise.

[call [arg object] [method get] [arg key] [arg attr]]

Returns the data associated with the attribute [arg attr] under the
[arg key]. If either the key or the attribute does not exist, then an
error is generated.

[call [arg object] [method get||default] [arg key] [arg attr] [arg default]]

Like method [method get], except that the [arg default] is returned if
either the key or the attribute does not exist, instead of generating
an error.

[call [arg object] [method keys] [arg key] [opt [arg pattern]]]

If [arg pattern] isn't specified, the command returns a list of names
of all the subkeys of [arg key]. If [arg pattern] is specified, only
those names matching the pattern are returned. Matching is determined
using the same rules as for [cmd {string match}]. If the specified
[arg key] does not exist, then an error is generated.

[call [arg object] [method set] [arg key] [opt "[arg attr] [arg value]"]]

If [arg attr] isn't specified, creates the [arg key] if it doesn't
already exist. If [arg attr] is specified, creates the [arg key]
keyName and attribute [arg attr] if necessary.

The contents of [arg attr] are set to [arg value]. The command returns
the [arg value] as its result.

[call [arg object] [method attrs] [arg key] [opt [arg pattern]]]

If [arg pattern] isn't specified, returns a list of names of all the
attributes of [arg key]. If [arg pattern] is specified, only those
names matching the pattern are returned. Matching is determined using
the same rules as for [cmd {string match}].

[call [arg object] [method configure]]

Returns a dictionary mapping the option of the object to their
currently configured values.

[call [arg object] [method configure] [arg option] [arg newvalue]...]

This invokation sets the configured value of option [arg option] to
[arg newvalue]. Nothing will be done if current and new value are
identical. Returns the empty string.

[call [arg object] [method configure] [arg option]]
[call [arg object] [method cget] [arg option]]

Returns the value configured for the specified option [arg option].

[list_end]

[section KEYS]

All elements in the registry are identified by a unique key, which is
a list of strings. This identifies the path from the root of the tree
to the requested element. The root itself is identified by the empty
list. Each child C of an element E have to have unique name, which
will be the last element of the key identifying this child. The head
of the key will be the key of E.

[section OPTIONS]

The registry object recognize a single option,

[list_begin options]
[opt_def -tie tiedefinition]

See the documentation of command [cmd ::tie::tie], in the package
[package tie]. The value of the option is a list of words equivalent
to the arguments "[arg dstype] [arg dsname]..." of [cmd ::tie::tie].
I.e. the identity of the tie backend to use, followed by the
specification of the location to use, per the chosen backend.

Example:
[example {
    set r [pregistry %AUTO% -tie [list file $path]]
}]

[list_end]
[manpage_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































Deleted support/devel/sak/registry/registry.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require Tcl 8.3
package require snit
package require tie

# ###

snit::type pregistry {

    # API
    # delete key ?attribute?
    # mtime  key ?attribute?
    # get    key attribute
    # keys   key ?pattern?/*
    # set    key ?attribute value?
    # attrs  key ?pattern?

    option -tie -default {} -configuremethod TIE ; # Persistence

    constructor {args} {
	$self configurelist $args
	$self INIT
	return
    }

    # ###

    method delete {key args} {
	#puts DEL|$key|

	if {[llength $args] > 1} {return -code error "wrong\#args"}

	if {[catch {NODE $key} n]} return
	if {[llength $args]} {
	    # Delete attribute

	    set attr    [lindex $args 0]
	    set pattern [list A $n $attr *]
	    set km      [list N $n M]

	    array unset data $pattern
	    set         data($km) [clock seconds]
	} else {
	    # Delete key and children.
	    #puts N|$n|

	    if {![llength $key]} {
		return -code error "cannot delete root"
	    }

	    # Children first
	    foreach c [array names data [list C $n *]] {
		set c [lindex $c end]
		#puts _|$c|
		$self delete [linsert $key end $c]
	    }

	    # And now the node itself. Modify the parent as well,
	    # remove this node as a child.

	    set self [lindex $key end]
	    set pidx [list N $n P]
	    set npat [list N $n *]
	    set apat [list A $n * *]

	    set pid  $data($pidx)
	    set cidx [list C $pid $self]
	    set midx [list N $pid M]

	    array unset data $apat
	    array unset data $npat
	    unset -nocomplain data($cidx)
	    set data($midx) [clock seconds]

	    unset -nocomplain ncache($key)
	}
	return
    }

    method mtime {key args} {
	if {[llength $args] > 1} {return -code error "wrong\#args"}
	set n [NODE $key]
	if {[llength $args]} {
	    set attr [lindex $args 0]
	    set idx  [list A $n $attr M]
	    if {![info exists data($idx)]} {
		return -code error "Unknown attribute \"$attr\" in key \"$key\""
	    }
	} else {
	    set idx [list N $n M]
	}
	return $data($idx)
    }

    method exists {key args} {
	if {[llength $args] > 1} {
	    return -code error "wrong\#args"
	} elseif {[catch {NODE $key} n]} {
	    return 0
	} elseif {![llength $args]} {
	    return 1
	}

	set attr [lindex $args 0]
	set idx  [list A $n $attr V]
	return   [info exist data($idx)]
    }

    method get {key attr} {
	set n   [NODE $key]
	set idx [list A $n $attr V]
	if {![info exists data($idx)]} {
	    return -code error "Unknown attribute \"$attr\" in key \"$key\""
	}
	return $data($idx)
    }

    method get||default {key attr default} {
	if {[catch {NODE $key} n]} {
	    return $default
	}
	set idx [list A $n $attr V]
	if {![info exists data($idx)]} {
	    return $default
	}
	return $data($idx)
    }

    method keys {key {pattern *}} {
	set n       [NODE $key]
	set pattern [list C $n $pattern]
	set res {}
	foreach c [array names data $pattern] {
	    lappend res [linsert $key end $c]
	}
	return $res
    }

    method attrs {key {pattern *}} {
	set n       [NODE $key]
	set pattern [list A $n $pattern V]
	set res {}
	foreach c [array names data $pattern] {
	    lappend res [lindex $c end-1]
	}
	return $res
    }

    method lappend {key attr value} {
	set     list [$self get||default $key $attr {}]
	lappend list $value
	$self set $key $attr $list
	return
    }

    method set {key args} {
	set n [NODE $key 1]
	if {![llength $args]} return
	if {[llength  $args] != 2} {return -code error "wrong\#args"}
	foreach {attr value} $args break

	# Ignore calls which do not change the contents of the
	# database.

	set aidx [list A $n $attr V]
	if {
	    [info exists   data($aidx)] &&
	    [string equal $data($aidx) $value]
	} return ; # {}

	#puts stderr "$n $attr | $key | ($value)"

	set aids [list A $n $attr M]
	set data($aidx) $value
	set data($aids) [clock seconds]
	return
    }

    # ### state

    variable data -array {}

    # Tree of keys. Each keys can have multiple attributes.
    # Each key, and attribute, have a modification timestamp.

    # Each node in the tree is identified by a numeric id. Children
    # refer to their parents. Parent id + name refers to unique child.

    # Array contents

    # (I)           -> number		id counter
    # (C id name)   -> id		parent id x name => child id
    # (N id P)      -> id		node id => parent id, empty for root
    # (N id M)      -> timestamp	node id => last modification
    # (A id name V) -> string		node id x attribute name => value
    # (A id name M) -> timestamp	s.a => last modification

    # This structure is less memory/space intensive than the setup of
    # 1registry. It is also more difficult to query as it is less
    # tabular, less redundant.

    # Another thing becoming more complex is the deletion of a
    # subtree. It is now necessary to walk the the tree, instead of
    # just deleting all keys in the array matching a certain
    # pattern. That at least can be done at the C level (array unset).

    # The conversion from key list to node is also linear in key
    # length, and an operation done often. Better cache it. However
    # only internally, or the space savingsare gone too as the space
    # is then taken by the conversion cache. Hm. Still less than
    # before, as each key is listed at most once. In 1registry it was
    # repeated for each of its attributes as well. This would regain
    # speed for searches, as the conversion cache now is a tabular
    # representation of the tree, and easily globbed.

    # ### configure -tie (persistence)

    method TIE {option value} {
	if {[string equal $options(-tie) $value]} return
	tie::untie [myvar data]
	# 8.5 - tie::tie [myvar data] {expand}$value
	eval [linsert $value 0 tie::tie [myvar data]]
	set options(-tie) $value
	return
    }

    method INIT {} {
	if {![info exists data(I)]} {
	    set anchor {C {} {}}
	    set rootp  {N 0 P}
	    set roots  {N 0 M}

	    set data(I) 0
	    set data($anchor) 0
	    set data($rootp)  {}
	    set data($roots)  [clock seconds]
	}
	return
    }

    variable ncache -array {}

    proc NODE {key {create 0}} {
	upvar 1 ncache ncache data data
	if {[info exist ncache($key)]} {
	    # Cached, shortcut
	    return $ncache($key)
	}
	if {![llength $key]} {
	    # Root, shortcut
	    set id 0
	} else {
	    # Recursively convert, possibly create
	    set parent [lrange $key 0 end-1]
	    set self   [lindex $key end]
	    set pid    [NODE $parent $create]
	    set idx    [list C $pid $self]

	    if {[info exists data($idx)]} {
		set id $data($idx)
	    } elseif {!$create} {
		return -code error "Unknown key \"$key\""
	    } else {
		set id   [incr data(I)]
		set idxp [list N $id P]
		set idxm [list N $id M]

		set data($idx)  $id
		set data($idxp) $pid
		set data($idxm) [clock seconds]
	    }
	}
	set ncache($key) $id
	return $id
    }

    # ###
}

##
# ###

package provide pregistry 0.1
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































Deleted support/devel/sak/registry/registry.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
# -*- tcl -*-
# registry.test:  tests for the registry structure.
#
# Copyright (c) 2006 by Andreas Kupries <a.kupries@westend.com>
# All rights reserved.
#
# RCS: @(#) $Id: registry.test,v 1.1 2006/09/06 06:07:09 andreas_kupries Exp $

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

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

testsNeedTcl     8.3
testsNeedTcltest 2.2

support {
    use snit/snit.tcl snit
    use tie/tie.tcl   tie
}
testing {
    useLocal registry.tcl pregistry
}

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

proc dump/ {r {root {}} {rv {}}} {
    if {$rv != {}} {upvar 1 $rv res} else {set res {}}
    lappend res $root/
    foreach a [$r attrs $root] {
	lappend res [list $root/ :$a [$r get $root $a]]
    }
    foreach c [$r keys $root] {
	dump/ $r $c res
    }
    return $res
}

proc dump {r root} {
    lappend res $root/
    foreach a [$r attrs $root] {
	lappend res [list $root/ :$a [$r get $root $a]]
    }
    return $res
}

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

test registry-1.0 {base state} {
    pregistry myreg
    set res [dump/ myreg]
    myreg destroy
    set res
} /

# -------------------------------------------------------------------------
# Attribute manipulation, root, in-tree, and leaf

set n 0
foreach {key prekey structure} {
    {}              {}              /
    {sub tree leaf} {}              {/ sub/ {sub tree/} {sub tree leaf/}}
    {sub tree}      {sub tree leaf} {/ sub/ {sub tree/} {sub tree leaf/}}
} {
    test registry-2.$n {structure} {
	pregistry myreg
	myreg set $prekey
	myreg set $key
	set res [dump/ myreg]
	myreg destroy
	set res
    } $structure

    test registry-3.1.$n {no attributes, node creation} {
	pregistry myreg
	myreg set $prekey
	myreg set $key
	set res [dump myreg $key]
	myreg destroy
	set res
    } [list $key/]

    test registry-3.2.$n {bad node creation} {
	pregistry myreg
	catch {myreg set} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodset type selfns win self key args"}

    test registry-3.3.$n {bad node creation} {
	pregistry myreg
	catch {myreg set a b c d} res
	myreg destroy
	set res
    } {wrong#args}

    test registry-3.4.$n {bad node creation} {
	pregistry myreg
	catch {myreg set a b} res
	myreg destroy
	set res
    } {wrong#args}

    test registry-4.1.$n {set attribute, ok} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [dump myreg $key]
	myreg destroy
	set res
    } [list $key/ [list $key/ :foo bar]]

    test registry-4.2.$n {set attribute, change} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res     [myreg get $key foo]
	myreg set $key foo bold
	lappend res [myreg get $key foo]
	myreg destroy
	set res
    } {bar bold}

    test registry-5.1.$n {get attribute, ok} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [myreg get $key foo]
	myreg destroy
	set res
    } bar

    test registry-5.2.$n {get attribute, missing attribute} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get $key alpha} res
	myreg destroy
	set res
    } "Unknown attribute \"alpha\" in key \"$key\""

    test registry-5.3.$n {get attribute, missing key} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get TEST x} res
	myreg destroy
	set res
    } {Unknown key "TEST"}

    test registry-5.4.$n {get attribute, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget type selfns win self key attr"}

    test registry-5.5.$n {get attribute, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get x} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget type selfns win self key attr"}

    test registry-5.6.$n {get attribute, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get x y z} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget type selfns win self key attr"}

    test registry-6.1.$n {get||default, ok} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [myreg get||default $key foo DEF]
	myreg destroy
	set res
    } bar

    test registry-6.2.$n {get||default, missing attribute} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [myreg get||default $key alpha DEF]
	myreg destroy
	set res
    } DEF

    test registry-6.3.$n {get||default, missing key} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [myreg get||default TEST x DEF]
	myreg destroy
	set res
    } DEF

    test registry-6.4.$n {get||default, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get||default} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"}

    test registry-6.5.$n {get||default, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get||default x} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"}

    test registry-6.6.$n {get||default, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get||default x y} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"}

    test registry-6.7.$n {get||default, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg get||default x y z a} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodget||default type selfns win self key attr default"}

    test registry-7.1.$n {attribute matching, total} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	myreg set $key alpha omega
	set res [lsort [myreg attrs $key]]
	myreg destroy
	set res
    } {alpha foo}

    test registry-7.2.$n {attribute matching, partial} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	myreg set $key alpha omega
	set res [lsort [myreg attrs $key a*]]
	myreg destroy
	set res
    } alpha

    test registry-7.3.$n {attribute matching, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	catch {myreg attrs} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodattrs type selfns win self key ?pattern?"}

    test registry-7.4.$n {attribute matching, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	catch {myreg attrs x y z} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodattrs type selfns win self key ?pattern?"}

    test registry-8.1.$n {attribute existence, ok} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	set res [myreg exists $key foo]
	myreg destroy
	set res
    } 1

    test registry-8.2.$n {attribute existence, missing} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	set res [myreg exists $key alpha]
	myreg destroy
	set res
    } 0

    test registry-8.3.$n {attribute existence, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg exists} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodexists type selfns win self key args"}

    test registry-8.4.$n {attribute existence, wrong#args} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	catch {myreg exists x y z} res
	myreg destroy
	set res
    } {wrong#args}

    test registry-9.1.$n {key existence, ok} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [myreg exists $key]
	myreg destroy
	set res
    } 1

    test registry-9.2.$n {key existence, missing} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo bar
	set res [myreg exists alpha]
	myreg destroy
	set res
    } 0

    # key existence, wrong args, see attribute existence

    test registry-10.1.$n {key matching, total} {
	pregistry myreg
	myreg set $key
	myreg set [linsert $key end alpha]
	myreg set [linsert $key end omega]
	set res [lsort [myreg keys $key]]
	myreg destroy
	set res
    } [list [linsert $key end alpha] [linsert $key end omega]]

    test registry-10.2.$n {key matching, partial} {
	pregistry myreg
	myreg set $key
	myreg set [linsert $key end alpha]
	myreg set [linsert $key end omega]
	set res [lsort [myreg keys $key a*]]
	myreg destroy
	set res
    } [list [linsert $key end alpha]]

    test registry-10.3.$n {key matching, wrong#args} {
	pregistry myreg
	myreg set $key
	catch {myreg keys} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodkeys type selfns win self key ?pattern?"}

    test registry-10.4.$n {key matching, wrong#args} {
	pregistry myreg
	myreg set $key
	catch {myreg keys x y z} res
	myreg destroy
	set res
    } {wrong # args: should be "::pregistry::Snit_methodkeys type selfns win self key ?pattern?"}

    test registry-11.1.$n {attribute deletion, ok} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	myreg set $key alpha omega
	myreg delete $key foo
	set res [dump myreg $key]
	myreg destroy
	set res
    } [list $key/ [list $key/ :alpha omega]]

    test registry-11.2.$n {attribute deletion, missing} {
	pregistry myreg
	myreg set $prekey
	myreg set $key foo   bar
	myreg set $key alpha omega
	set code [catch {myreg delete $key fox} res]
	myreg destroy
	list $code $res
    } {0 {}}

    incr n
}

set n 0
foreach {par key structure} {
    {foo fox fool} {foo fox fool bar soom}
    {{/ foo/ {foo fox/} {foo fox fool/} {foo fox fool bar/} {foo fox fool bar soom/} {{foo fox fool bar soom/} :foo bar}} {/ foo/ {foo fox/}}}

    foo foo
    {{/ foo/ {foo/ :foo bar}} /}
} {
    test registry-12.1.$n {deletion} {
	set res {}
	pregistry myreg
	myreg set $par
	myreg set $key foo bar
	lappend res [dump/ myreg]
	myreg delete $par
	lappend res [dump/ myreg]
	myreg destroy
	set res
    } $structure

    test registry-12.2.$n {deletion of non-existing key} {
	pregistry myreg
	myreg set $par
	catch {myreg delete FOO} res
	myreg destroy
	set res
    } {}

    incr n
}

test registry-13.1 {deletion of root} {
    pregistry myreg
    catch {myreg delete {}} res
    myreg destroy
    set res
} {cannot delete root}

test registry-13.2 {wrong#args} {
    pregistry myreg
    catch {myreg delete} res
    myreg destroy
    set res
} {wrong # args: should be "::pregistry::Snit_methoddelete type selfns win self key args"}

test registry-13.3 {wrong#args} {
    pregistry myreg
    catch {myreg delete a b c} res
    myreg destroy
    set res
} {wrong#args}

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

::tcltest::cleanupTests
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/review/cmd.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
# -*- tcl -*-
# Implementation of 'review'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

package require sak::util
package require sak::review

set raw  0
set log  0
set stem {}
set tclv {}

if {[llength $argv]} {
    sak::review::usage
}

sak::review::run

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































Deleted support/devel/sak/review/help.txt.

1
2
3
4
5
6
7
8
9
10

    review -- Interactively review changed modules and packages

    sak review

    	This command scans the system for changes and then enters
	a sub-shell where the caller can interactively review and
	tag these changes.

	This is a support command for the release manager.
<
<
<
<
<
<
<
<
<
<




















Deleted support/devel/sak/review/pkgIndex.tcl.

1
2
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::review 1.0 [list source [file join $dir review.tcl]]
<
<




Deleted support/devel/sak/review/review.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
# -*- tcl -*-
# # ## ### ##### ######## ############# ##################### 
# (C) 2013 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require linenoise
package require sak::color

getpackage fileutil                 fileutil/fileutil.tcl
getpackage doctools::changelog      doctools/changelog.tcl
getpackage struct::set              struct/sets.tcl
getpackage term::ansi::send         term/ansi/send.tcl

namespace eval ::sak::review {
    namespace import ::sak::color::*
}

# ###

proc ::sak::review::usage {} {
    package require sak::help
    puts stdout \n[sak::help::on review]
    exit 1
}

proc ::sak::review::run {} {
    Scan ; Review
    return
}

# # ## ### ##### ######## ############# ##################### 
## Phase I. Determine which modules require a review.
## A derivative of the code in ::sak::readme.

proc ::sak::review::Scan {} {
    global distribution
    variable review

    Banner "Scan for modules and packages to review..."

    # Determine which packages are potentially changed and therefore
    # in need of review, from the set of modules touched since the
    # last release, as per their changelog ... (future: md5sum of
    # files in a module, and file/package association).

    array set review {}

    # package -> list(version)
    set old_version    [loadoldv [location_PACKAGES]]
    array set releasep [loadpkglist [location_PACKAGES]]
    array set currentp [ipackages]

    set modifiedm [modified-modules]
    array set changed {}
    foreach p [array names currentp] {
	foreach {vlist module} $currentp($p) break
	set currentp($p) $vlist
	set changed($p) [struct::set contains $modifiedm $module]
    }

    LoadNotes

    set np 0
    # Process all packages in all modules ...
    foreach m [lsort -dict [modules]] {
	Next ; Progress " $m"
	foreach name [lsort -dict [Provided $m]] {
	    #Next ; Progress "... $m/$name"
	    # Define list of versions, if undefined so far.
	    if {![info exists currentp($name)]} {
		set currentp($name) {}
	    }

	    # Detect new packages. Ignore them.

	    if {![info exists releasep($name)]} {
		#Progress " /new"
		continue
	    }

	    # The package is not new, but possibly changed. And even
	    # if the version has not changed it may have been, this is
	    # indicated by changed(), which is based on the ChangeLog.

	    set vequal [struct::set equal $releasep($name) $currentp($name)]
	    set note   [Note $m $name]

	    # Detect packages whose versions are unchanged, and whose
	    # changelog also indicates no change. Ignore these too.

	    if {!$changed($name) && $vequal} {
		#Progress " /not changed"
		continue
	    }

	    # Now look for packages where both changelog and version
	    # number indicate a change. These we have to review.

	    if {$changed($name) && !$vequal} {
		lappend review($m) [list $name classify $note]
		#Progress " [=cya classify]"
		incr np
		continue
	    }

	    # What remains are packages which are changed according to
	    # their changelog, but their version disagrees. Or the
	    # reverse. These need a big review to see who is right.
	    # We may have to bump their version information, not just
	    # classify changes. Of course, in modules with multiple
	    # packages it is quite possible to be unchanged and the
	    # changelog refers to the siblings.

	    lappend review($m) [list $name mismatch $note]
	    #Progress " [=cya mismatch]"
	    incr np
	}
    }

    Close

    # Postprocessing phase, pull in all relevant changelogs.

    foreach m [array names review] {
	set clog [fileutil::cat $distribution/modules/$m/ChangeLog]
	set entries {}
	foreach e [doctools::changelog::scan $clog] {
	    if {[string match -nocase "*Released and tagged*" $e]} break
	    lappend entries $e
	}
	set entries [doctools::changelog::flatten $entries]

	set review($m) [list $review($m) [join $entries \n\n]]
    }

    set review() $np
    return
}

# see also readme
proc ::sak::review::Provided {m} {
    set result {}
    foreach {p ___} [ppackages $m] {
	lappend result $p
    }
    return $result
}

# see also readme
proc ::sak::review::loadoldv {fname} {
    set f [open $fname r]
    foreach line [split [read $f] \n] {
	set line [string trim $line]
	if {[string match @* $line]} {
	    foreach {__ __ v} $line break
	    close $f
	    return $v
	}
    }
    close $f
    return -code error {Version not found}
}

proc ::sak::review::Progress {text} {
    puts -nonewline stdout $text
    flush stdout
    return
}

proc ::sak::review::Next {} {
    # erase to end of line, then move back to start of line.
    term::ansi::send::eeol
    puts -nonewline stdout \r
    flush stdout
    return
}

proc ::sak::review::Close {} {
    puts stdout ""
    return
}

proc ::sak::review::Clear {} {
    term::ansi::send::clear
    return
}

proc ::sak::review::Banner {text} {
    Clear
    puts stdout "\n <<SAK Tcllib: $text>>\n"
    return
}

proc ::sak::review::Note {m p} {
    # Look for a note, and present to caller, if any.
    variable notes
    #parray notes
    set k [list $m $p]
    #puts <$k>
    if {[info exists notes($k)]} {
	return $notes($k)
    }
    return ""
}

proc ::sak::review::SaveNote {at t} {
    global distribution
    set    f [open [file join $distribution .NOTE] a]
    puts  $f [list $at $t]
    close $f
    return
}

proc ::sak::review::LoadNotes {} {
    global distribution
    variable  notes
    array set notes {}

    catch {
	set f [file join $distribution .NOTE]
	set f [open $f r]
	while {![eof $f]} {
	    if {[gets $f line] < 0} continue
	    set line [string trim $line]
	    if {$line == {}} continue
	    foreach {k t} $line break
	    set notes($k) $t
	}
	close $f
    }

    return
}

# # ## ### ##### ######## ############# ##################### 
## Phase II. Interactively review the changes packages.

# Namespace variables
#
# review      : array, database of all modules, keyed by name
# nm          : number of modules
# modules     : list of module names, keys to --> review
# current     : index in -> modules, current module
# np          : number of packages in current module
# packages    : list of packages in current module
# currentp    : index in --> packages
# im          : 1+current  | indices for display
# ip          : 1+currentp |
# end         : array : module (name) --> index of last package
# stop        : repl exit flag
# map         : array : text -> module/package index
# commands    : proper commands
# allcommands : commands + namesof(map)
# 

proc ::sak::review::Review {} {
    variable review   ;# table of everything to review
    variable nm       ;# number of modules
    variable modules  ;# list of module names, sorted
    variable stop 0   ;# repl exit flag
    variable end      ;# last module/package index.

    variable navcommands
    variable allcommands ;# list of all commands, sorted
    variable commands    ;# list of proper commands, sorted
    variable map         ;# map from package names to module/package indices.
    variable prefix

    Banner "Packages to review: $review()"
    unset   review()

    set nm [array size review]
    if {!$nm} return

    set modules [lsort -dict [array names review]]

    # Map package name --> module/package index.
    set im 0
    foreach m $modules {
	foreach {packages clog} $review($m) break
	set ip 0
	foreach p $packages {
	    set end($im) $ip
	    set end($m) $ip
	    set end() [list $im $ip]
	    foreach {name what tags} $p break
	    lappend map(@$name)    [list $im $ip]
	    lappend map(@$name/$m) [list $im $ip]
	    incr ip
	}
	incr im
    }

    # Drop amibigous mappings, and fill the list of commands.
    foreach k [array names map] {
	# Skip already dropped keys (extended forms).
	if {![info exists map($k)]} continue
	if {[llength $map($k)] < 2} {
	    set map($k) [lindex $map($k) 0]
	    # Drop extended form, not needed.
	    array unset map $k/*
	} else {
	    unset map($k)
	}
    }

    # Map module name --> module/package index
    # If not preempted by package mapping.
    set im -1
    foreach m $modules {
	incr im
	if {[info exists map(@$m)]} continue
	set map(@$m) [list $im 0]
    }

    # Map command prefix -> full command.

    array set prefix {}
    foreach c [info commands ::sak::review::C_*] {
	set c [string range [namespace tail $c] 2 end]
	lappend commands    $c
	lappend allcommands $c
	set buf {}
	foreach ch [split $c {}] {
	    append buf $ch
	    lappend prefix($buf) $c
	}
    }

    foreach c [array names map] {
	lappend allcommands $c
	set buf {}
	foreach ch [split $c {}] {
	    append buf $ch
	    lappend prefix($buf) $c
	}
    }

    set commands    [lsort -dict $commands]
    set allcommands [lsort -dict $allcommands]
    set navcommands [lsort -dict [array names map]]

    # Enter the REPL
    Goto {0 0} 1
    linenoise::cmdloop \
	-history   1 \
	-exit      ::sak::review::Exit \
	-continued ::sak::review::Continued \
	-prompt1   ::sak::review::Prompt \
	-complete  ::sak::review::Complete \
	-dispatch  ::sak::review::Dispatch
    return
}

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

proc ::sak::review::RefreshDisplay {} {
    variable m
    variable im
    variable nm
    variable clog
    variable what

    Banner "\[$im/$nm\] [=cya [string totitle $what]] [=green $m]"
    puts "| [join [split $clog \n] \n|]\n"
    return
}

proc ::sak::review::Exit {} {
    variable stop
    return  $stop
}

proc ::sak::review::Continued {buffer} {
    return 0
}

proc ::sak::review::Prompt {} {
    variable ip
    variable np
    variable name
    variable tags

    return "\[$ip/$np\] $name ($tags): "
}

proc ::sak::review::Complete {line} {
    variable allcommands
    if {$line eq {}} {
	return $allcommands
    } elseif {[llength $line] == 1} {
	set r {}
	foreach c $allcommands {
	    if {![string match ${line}* $c]} continue
	    lappend r $c
	}
	return $r
    } else {
	return {}
    }
}

proc ::sak::review::Dispatch {line} {
    variable prefix
    variable map

    if {$line == ""} { set line next }

    set cmd [lindex $line 0]

    if {![info exists prefix($cmd)]} {
	return -code error "Unknown command $cmd, use help or ? to list them"
    } elseif {[llength $prefix($cmd)] > 1} {
	return -code error "Ambigous prefix \"$cmd\", expected [join $prefix($cmd) {, }]"
    }

    # Map prefix to actual command
    set line [lreplace $line 0 0 $prefix($cmd)]

    # Run command.
    if {[info exists map($cmd)]} {
	Goto $map($cmd)
	return
    }
    eval C_$line
}

proc ::sak::review::Goto {loc {skip 0}} {
    variable review
    variable modules
    variable packages
    variable clog
    variable current
    variable currentp
    variable nm
    variable np
    variable at
    variable tags
    variable what
    variable name

    variable m
    variable p
    variable ip
    variable im

    foreach {current currentp} $loc break

    puts "Goto ($current/$currentp)"

    set m [lindex $modules $current]
    foreach {packages clog} $review($m) break

    set np [llength $packages]
    set p  [lindex  $packages $currentp]

    foreach {name what tags} $p break
    set at [list $m $name]

    set im [expr {1+$current}]
    set ip [expr {1+$currentp}]

    if {$skip && ([llength $tags] ||
		  ($tags == "---"))} {
	C_next
    } else {
	RefreshDisplay
    }
    return
}

proc ::sak::review::C_exit {} { variable stop 1 }
proc ::sak::review::C_quit {} { variable stop 1 }

proc ::sak::review::C_? {} { C_help }
proc ::sak::review::C_help {} {
    variable commands
    return [join $commands {, }]
}

proc ::sak::review::C_@? {} { C_@help }
proc ::sak::review::C_@help {} {
    variable navcommands
    return [join $navcommands {, }]
}

proc ::sak::review::C_@start {} { Goto {0 0} }
proc ::sak::review::C_@0     {} { Goto {0 0} }
proc ::sak::review::C_@end   {} { variable end ; Goto $end() }

proc ::sak::review::C_next {} {
    variable tags
    variable current
    variable currentp

    C_step 0

    set stop @$current/$currentp
    while {[llength $tags] ||
	   ($tags == "---")} {
	C_step 0
	if {"@$current/$currentp" == "$stop"} break
    }

    RefreshDisplay
    return
}

proc ::sak::review::C_step {{refresh 1}} {
    variable nm
    variable np
    variable current
    variable currentp
    variable packages

    incr currentp
    if {$currentp >= $np} {
	# skip to next module, first package
	incr current
	if {$current >= $nm} {
	    # skip to first module
	    set current 0
	}
	set currentp 0

    }
    Goto [list $current $currentp]
    return
}

proc ::sak::review::C_prev {} {
    variable end
    variable nm
    variable np
    variable current
    variable currentp
    variable packages

    incr currentp -1
    if {$currentp < 0} {
	# skip to previous module, last package
	incr current -1
	if {$current < 0} {
	    # skip to back to last module
	    set current [expr {$nm - 1}]
	}
	set currentp $end($current)
    }
    Goto [list $current $currentp]
    return
}

# Commands to add/remove tags, clear set, replace set

proc ::sak::review::C_feature {} { +T EF }
proc ::sak::review::C_test    {} { +T T }
proc ::sak::review::C_doc     {} { +T D }
proc ::sak::review::C_bug     {} { +T B }
proc ::sak::review::C_perf    {} { +T P }
proc ::sak::review::C_example {} { +T EX }
proc ::sak::review::C_api     {} { +T API }
proc ::sak::review::C_impl    {} { +T I }

proc ::sak::review::C_-feature {} { -T EF }
proc ::sak::review::C_-test    {} { -T T }
proc ::sak::review::C_-doc     {} { -T D }
proc ::sak::review::C_-bug     {} { -T B }
proc ::sak::review::C_-perf    {} { -T P }
proc ::sak::review::C_-example {} { -T EX }
proc ::sak::review::C_-api     {} { -T API }
proc ::sak::review::C_-impl    {} { -T I }

proc ::sak::review::C_---   {} { =T --- }
proc ::sak::review::C_clear {} { =T --- }
#proc ::sak::review::C_cn {} { C_clear ; C_next }

proc ::sak::review::+T {tag} {
    variable tags
    if {[lsearch -exact $tags $tag] >= 0} {
	RefreshDisplay
	return
    }
    =T [linsert $tags end $tag]
    return
}

proc ::sak::review::-T {tag} {
    variable tags
    set pos [lsearch -exact $tags $tag]
    if {$pos < 0} {
	RefreshDisplay
	return
    }
    =T [lreplace $tags $pos $pos]
    return
}

proc ::sak::review::=T {newtags} {
    variable review
    variable clog
    variable packages
    variable currentp
    variable p
    variable m
    variable at
    variable name
    variable what
    variable tags

    if {([llength $newtags] > 1) &&
	([set pos [lsearch -exact $newtags ---]] >= 0)} {
	# Drop --- if there are other tags.
	set newtags [lreplace $newtags $pos $pos]
    }

    set tags       [lsort -dict $newtags]
    set p          [list $name $what $newtags]
    set packages   [lreplace $packages $currentp $currentp $p]
    set review($m) [list $packages $clog]

    SaveNote $at $tags
    RefreshDisplay
    return
}

proc ::sak::review::?T {} {
    variable tags
    return $tags
}

##
# ###

namespace eval ::sak::review {}

package provide sak::review 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/review/topic.txt.

1
review		Interactively review changes since the last release.
<


Deleted support/devel/sak/test/cmd.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
# -*- tcl -*-
# Implementation of 'doc'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

package require sak::util
package require sak::test

if {![llength $argv]} {
    sak::test::usage Command missing
}

set cmd  [lindex $argv 0]
set argv [lrange $argv 1 end]

if {[catch {package require sak::test::$cmd} msg]} {
    sak::test::usage Unknown command \"$cmd\" : \
	    \n $::errorInfo
}

sak::test::$cmd $argv

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































Deleted support/devel/sak/test/help.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

    test -- Execute testsuites

    sak test run ?-s|--shell PATH? ?-l|--log STEM? ?-g|--valgrind? ?-v? ?MODULE ...?

        Run the testsuites of the specified modules, using the shell
        running SAK for the testsuites as well. If no modules are
        specified the testsuites of all modules are run.

        If --valgrind is specified the testsuites are run under the
        valgrind memory checker. NOTE. This feature is not available
        on the windows platform. Requests for it will be ignored.

        If one or more --shell's are specified the testsuites are run
        against them. If none are specified the shells registered with
        'shell add' (see below) are used instead. If none are
        specified the shell executing the sak is used instead.

        By default the output from a run is animated feedback of the
        progress made. If -v is specified the actual log is returned
        instead.

        If a log STEM is specified the extended log normally activated
        via -v is written to STEM.log while the user is provided with
        the regular feedback during execution. In addition the
        summaries from the feedback are written to STEM.summary as
        well, and also sorted into STEM.failures, STEM.skipped, and
        STEM.none. The -l switch overides -v.

    sak test shells

        Returns a list of the registered shells, one per line, used to
        execute the testsuites.

    sak test shell add PATH...

        Adds the specified paths to the list of shells to use when
        executing testsuites.

    sak test shell delete PATH...

        Removes the specified paths from the list of shells to use
        when executing testsuites.

    NOTE: The list of registered shells is a per-user configuration
          setting and is saved in the file "$HOME/.Tcllib/Registry".
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































Deleted support/devel/sak/test/pkgIndex.tcl.

1
2
3
4
5
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::test         1.0 [list source [file join $dir test.tcl]]
package ifneeded sak::test::run    1.0 [list source [file join $dir run.tcl]]
package ifneeded sak::test::shells 1.0 [list source [file join $dir shells.tcl]]
package ifneeded sak::test::shell  1.0 [list source [file join $dir shell.tcl]]
<
<
<
<
<










Deleted support/devel/sak/test/run.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require  sak::test::shell
package require  sak::registry
package require  sak::animate
package require  sak::color
# TODO: Rework this package to use the sak::feedback package

getpackage textutil::repeat textutil/repeat.tcl
getpackage fileutil         fileutil/fileutil.tcl
getpackage struct::matrix   struct/matrix.tcl

namespace eval ::sak::test::run {
    namespace import ::textutil::repeat::blank
    namespace import ::sak::color::*
}

# ###

proc ::sak::test::run {argv} {
    variable run::valgrind
    array set config {
	valgrind 0 raw 0 shells {} stem {} log 0
    }

    while {[string match -* [set opt [lindex $argv 0]]]} {
	switch -exact -- $opt {
	    -s - --shell {
		set sh [lindex $argv 1]
		if {![fileutil::test $sh efrx msg "Shell"]} {
		    sak::test::usage $msg
		}
		lappend config(shells) $sh
		set argv [lrange $argv 2 end]
	    }
	    -g - --valgrind {
		if {![llength $valgrind]} {
		    sak::test::usage valgrind not found in the PATH
		}
		incr config(valgrind)
		set argv [lrange $argv 1 end]
	    }
	    -v {
		set config(raw) 1
		set argv [lrange $argv 1 end]
	    }
	    -l - --log {
		set config(log) 1
		set config(stem) [lindex $argv 1]
		set argv         [lrange $argv 2 end]
	    }
	    default {
		sak::test::usage Unknown option "\"$opt\""
	    }
	}
    }

    if {$config(log)} {set config(raw) 0}

    if {![sak::util::checkModules argv]} return

    run::Do config $argv
    return
}

# ###

proc ::sak::test::run::Do {cv modules} {
    upvar 1 $cv config
    variable valgrind
    variable araw     $config(raw)
    variable alog     $config(log)
    # alog => !araw

    set shells $config(shells)
    if {![llength $shells]} {
	catch {set shells [sak::test::shell::list]}
    }
    if {![llength $shells]} {
	set shells [list [info nameofexecutable]]
    }

    if {$alog} {
	variable logext [open $config(stem).log         w]
	variable logsum [open $config(stem).summary     w]
	variable logfai [open $config(stem).failures    w]
	variable logski [open $config(stem).skipped     w]
	variable lognon [open $config(stem).none        w]
	variable logerd [open $config(stem).errdetails  w]
	variable logfad [open $config(stem).faildetails w]
	variable logtim [open $config(stem).timings     w]
    } else {
	variable logext stdout
    }

    # Preprocessing of module names and shell versions to allows
    # better formatting of the progress output, i.e. vertically
    # aligned columns

    if {!$araw} {
	variable maxml 0
	variable maxvl 0
	sak::animate::init
	foreach m $modules {
	    = "M  $m"
	    set l [string length $m]
	    if {$l > $maxml} {set maxml $l}
	}
	foreach sh $shells {
	    = "SH $sh"
	    set v [exec $sh << {puts [info patchlevel]; exit}]
	    set l [string length $v]
	    if {$l > $maxvl} {set maxvl $l}
	}
	=| "Starting ..."
    }

    set total 0
    set pass  0
    set fail  0
    set skip  0
    set err   0

    foreach sh $shells {
	foreach m $modules {
	    set cmd [Command config $m $sh]
	    sak::animate::init
	    if {$alog || $araw} {
		puts  $logext ============================================================
		flush $logext
	    }
	    if {[catch {Close [Process [open |$cmd r+]]} msg]} {
		incr err
		=| "~~ [mag]ERR   ${msg}[rst]"
		if {$alog || $araw} {
		    puts  $logext [mag]$msg[rst]
		    flush $logext
		}
	    }
	    #sak::animate::last Ok
	}
    }

    puts $logext "Passed  [format %6d $pass] of [format %6d $total]"
    puts $logext "Skipped [format %6d $skip] of [format %6d $total]"

    if {$fail} {
	puts $logext "Failed  [red][format %6d $fail][rst] of [format %6d $total]"
    } else {
	puts $logext "Failed  [format %6d $fail] of [format %6d $total]"
    }
    if {$err} {
	puts $logext "#Errors [mag][format %6d $err][rst]"
    } else {
	puts $logext "#Errors [format %6d $err]"
    }

    if {$alog} {
	variable xtimes
	array set times $xtimes

	struct::matrix M
	M add columns 6
	foreach k [lsort -dict [array names times]] {
	    #foreach {shell module testfile} $k break
	    foreach {testnum delta score} $times($k) break
	    M add row [linsert $k end $testnum $delta $score]
	}
	M sort rows -decreasing 5

	M insert row 0 {Shell Module Testsuite Tests Seconds uSec/Test}
	M insert row 1 {===== ====== ========= ===== ======= =========}
	M add    row   {===== ====== ========= ===== ======= =========}

	puts $logsum \nTimings...
	puts $logsum [M format 2string]
    }

    exit [expr {($err || $fail) ? 1 : 0}]
    return
}

# ###

if {$::tcl_platform(platform) == "windows"} {

    proc ::sak::test::run::Command {cv m sh} {
	variable valgrind
	upvar 1 $cv config

	# Windows. Construction of the pipe to run a specific
	# testsuite against a single shell. There is no valgrind to
	# accomodate, and neither can we expect to have unix commands
	# like 'echo' and 'cat' available. 'echo' we can go without. A
	# 'cat' however is needed to merge stdout and stderr of the
	# testsuite for processing here. We use an emuluation written
	# in Tcl.

	set catfile cat[pid].tcl
	fileutil::writeFile $catfile {
	    catch {wm withdraw .}
	    while {![eof stdin]} {puts stdout [gets stdin]}
	    exit
	}

	set     cmd ""
	lappend cmd $sh
	lappend cmd [Driver] -modules [list $m]
	lappend cmd |& $sh $catfile
	#puts <<$cmd>>

	return $cmd
    }

    proc ::sak::test::run::Close {pipe} {
	close $pipe
	file delete cat[pid].tcl
	return
    }
} else {
    proc ::sak::test::run::Command {cv m sh} {
	variable valgrind
	upvar 1 $cv config

	# Unix. Construction of the pipe to run a specific testsuite
	# against a single shell. The command is constructed to work
	# when using valgrind, and works when not using it as well.

	set     script {}
	lappend script [list set argv [list -modules [list $m]]]
	lappend script {set argc 2}
	lappend script [list source [Driver]]
	lappend script exit

	set     cmd ""
	lappend cmd echo [join $script \n]
	lappend cmd |

	if {$config(valgrind)} {
	    foreach e $valgrind {lappend cmd $e}
	    if {$config(valgrind) > 1} {
		lappend cmd --num-callers=8
		lappend cmd --leak-resolution=high
		lappend cmd -v --leak-check=yes
		lappend cmd --show-reachable=yes
	    }
	}
	lappend cmd $sh
	#lappend cmd >@ stdout 2>@ stderr
	lappend cmd |& cat
	#puts <<$cmd>>

	return $cmd
    }

    proc ::sak::test::run::Close {pipe} {
	close $pipe
	return
    }
}

# ###

proc ::sak::test::run::Process {pipe} {
    variable araw
    variable alog
    variable logext
    while {1} {
	if {[eof  $pipe]} break
	if {[gets $pipe line] < 0} break
	if {$alog || $araw} {puts $logext $line ; flush $logext}
	set rline $line
	set line [string trim $line]
	if {[string equal $line ""]} continue
	Host;	Platform
	Cwd;	Shell
	Tcl
	Start;	End ; StartFile ; EndFile
	Module;	Testsuite
	NoTestsuite
	Support;Testing;Other
	Summary
	CaptureFailureSync            ; # xcollect 1 => 2
	CaptureFailureCollectBody     ; # xcollect 2 => 3 => 5
	CaptureFailureCollectActual   ; # xcollect 3 => 4
	CaptureFailureCollectExpected ; # xcollect 4 => 0
	CaptureFailureCollectError    ; # xcollect 5 => 0
	CaptureStackStart
	CaptureStack

	TestStart
	TestSkipped
	TestPassed
	TestFailed                    ; # xcollect => 1

	SetupError
	Aborted
	AbortCause

	Match||Skip||Sourced
	# Unknown lines are printed
	if {!$araw} {puts !$line}
    }
    return $pipe
}

# ###

proc ::sak::test::run::Driver {} {
    variable base
    return [file join $base all.tcl]
}

# ###

proc ::sak::test::run::Host {} {
    upvar 1 line line ; variable xhost
    if {![regexp "^@@ Host (.*)$" $line -> xhost]} return
    # += $xhost
    set xhost [list Tests Results $xhost]
    #sak::registry::local set $xhost
    return -code continue
}

proc ::sak::test::run::Platform {} {
    upvar 1 line line ; variable xplatform
    if {![regexp "^@@ Platform (.*)$" $line -> xplatform]} return
    # += ($xplatform)
    variable xhost
    #sak::registry::local set $xhost Platform $xplatform
    return -code continue
}

proc ::sak::test::run::Cwd {} {
    upvar 1 line line ; variable xcwd
    if {![regexp "^@@ CWD (.*)$" $line -> xcwd]} return
    variable xhost
    set xcwd [linsert $xhost end $xcwd]
    #sak::registry::local set $xcwd
    return -code continue
}

proc ::sak::test::run::Shell {} {
    upvar 1 line line ; variable xshell
    if {![regexp "^@@ Shell (.*)$" $line -> xshell]} return
    # += [file tail $xshell]
    variable xcwd
    set xshell [linsert $xcwd end $xshell]
    #sak::registry::local set $xshell
    return -code continue
}

proc ::sak::test::run::Tcl {} {
    upvar 1 line line ; variable xtcl
    if {![regexp "^@@ Tcl (.*)$" $line -> xtcl]} return
    variable xshell
    variable maxvl
    += \[$xtcl\][blank [expr {$maxvl - [string length $xtcl]}]]
    #sak::registry::local set $xshell Tcl $xtcl
    return -code continue
}

proc ::sak::test::run::Match||Skip||Sourced {} {
    upvar 1 line line
    if {[string match "@@ Skip*"                  $line]} {return -code continue}
    if {[string match "@@ Match*"                 $line]} {return -code continue}
    if {[string match "Sourced * Test Files."     $line]} {return -code continue}
    if {[string match "Files with failing tests*" $line]} {return -code continue}
    if {[string match "Number of tests skipped*"  $line]} {return -code continue}
    if {[string match "\[0-9\]*"                  $line]} {return -code continue}
    return
}

proc ::sak::test::run::Start {} {
    upvar 1 line line
    if {![regexp "^@@ Start (.*)$" $line -> start]} return
    variable xshell
    #sak::registry::local set $xshell Start $start
    return -code continue
}

proc ::sak::test::run::End {} {
    upvar 1 line line
    if {![regexp "^@@ End (.*)$" $line -> end]} return
    variable xshell
    #sak::registry::local set $xshell End $end
    return -code continue
}

proc ::sak::test::run::StartFile {} {
    upvar 1 line line
    if {![regexp "^@@ StartFile (.*)$" $line -> start]} return
    variable xstartfile $start
    variable xtestnum 0
    #sak::registry::local set $xshell Start $start
    return -code continue
}

proc ::sak::test::run::EndFile {} {
    upvar 1 line line
    if {![regexp "^@@ EndFile (.*)$" $line -> end]} return
    variable xfile
    variable xstartfile
    variable xtimes
    variable xtestnum

    set k [lreplace $xfile 0 3]
    set k [lreplace $k 2 2 [file tail [lindex $k 2]]]
    set delta [expr {$end - $xstartfile}]

    if {$xtestnum == 0} {
	set score $delta
    } else {
	# average number of microseconds per test.
	set score [expr {int(($delta/double($xtestnum))*1000000)}]
	#set score [expr {$delta/double($xtestnum)}]
    }

    lappend xtimes $k [list $xtestnum $delta $score]

    variable alog
    if {$alog} {
	variable logtim
	puts $logtim [linsert [linsert $k end $xtestnum $delta $score] 0 TIME]
    }

    #sak::registry::local set $xshell End $end
    return -code continue
}

proc ::sak::test::run::Module {} {
    upvar 1 line line ; variable xmodule
    if {![regexp "^@@ Module (.*)$" $line -> xmodule]} return
    variable xshell
    variable xstatus ok
    variable maxml
    += ${xmodule}[blank [expr {$maxml - [string length $xmodule]}]]
    set xmodule [linsert $xshell end $xmodule]
    #sak::registry::local set $xmodule
    return -code continue
}

proc ::sak::test::run::Testsuite {} {
    upvar 1 line line ; variable xfile
    if {![regexp "^@@ Testsuite (.*)$" $line -> xfile]} return
    = <[file tail $xfile]>
    variable xmodule
    set xfile [linsert $xmodule end $xfile]
    #sak::registry::local set $xfile Aborted 0
    return -code continue
}

proc ::sak::test::run::NoTestsuite {} {
    upvar 1 line line
    if {![string match "Error:  No test files remain after*" $line]} return
    variable xstatus none
    = {No tests}
    return -code continue
}

proc ::sak::test::run::Support {} {
    upvar 1 line line
    if {![regexp "^- (.*)$" $line -> package]} return
    #= "S $package"
    foreach {pn pv} $package break
    variable xfile
    #sak::registry::local set [linsert $xfile end Support] $pn $pv
    return -code continue
}

proc ::sak::test::run::Testing {} {
    upvar 1 line line
    if {![regexp "^\\* (.*)$" $line -> package]} return
    #= "T $package"
    foreach {pn pv} $package break
    variable xfile
    #sak::registry::local set [linsert $xfile end Testing] $pn $pv
    return -code continue
}

proc ::sak::test::run::Other {} {
    upvar 1 line line
    if {![string match ">*" $line]} return
    return -code continue
}

proc ::sak::test::run::Summary {} {
    upvar 1 line line
    if {![regexp "^all\\.tcl:(.*)$" $line -> line]} return
    variable xmodule
    variable xstatus
    variable xvstatus
    foreach {_ t _ p _ s _ f} [split [string trim $line]] break
    #sak::registry::local set $xmodule Total   $t ; set t [format %5d $t]
    #sak::registry::local set $xmodule Passed  $p ; set p [format %5d $p]
    #sak::registry::local set $xmodule Skipped $s ; set s [format %5d $s]
    #sak::registry::local set $xmodule Failed  $f ; set f [format %5d $f]

    upvar 2 total _total ; incr _total $t
    upvar 2 pass  _pass  ; incr _pass  $p
    upvar 2 skip  _skip  ; incr _skip  $s
    upvar 2 fail  _fail  ; incr _fail  $f
    upvar 2 err   _err

    set t [format %5d $t]
    set p [format %5d $p]
    set s [format %5d $s]
    set f [format %5d $f]

    if {$xstatus == "ok" && $t == 0} {
	set xstatus none
    }

    set st $xvstatus($xstatus)

    if {$xstatus == "ok"} {
	# Quick return for ok suite.
	=| "~~ $st T $t P $p S $s F $f"
	return -code continue
    }

    # Clean out progress display using a non-highlighted
    # string. Prevents the char couint from being off. This is
    # followed by construction and display of the highlighted version.

    = "   $st T $t P $p S $s F $f"
    switch -exact -- $xstatus {
	none    {=| "~~ [yel]$st T $t[rst] P $p S $s F $f"}
	aborted {=| "~~ [whi]$st[rst] T $t P $p S $s F $f"}
	error   {
	    =| "~~ [mag]$st[rst] T $t P $p S $s F $f"
	    incr _err
	}
	fail    {=| "~~ [red]$st[rst] T $t P $p S $s [red]F $f[rst]"}
    }
    return -code continue
}

proc ::sak::test::run::TestStart {} {
    upvar 1 line line
    if {![string match {---- * start} $line]} return
    set testname [string range $line 5 end-6]
    = "---- $testname"
    variable xfile
    variable xtest [linsert $xfile end $testname]
    variable xtestnum
    incr     xtestnum
    return -code continue
}

proc ::sak::test::run::TestSkipped {} {
    upvar 1 line line
    if {![string match {++++ * SKIPPED:*} $line]} return
    regexp {^[^ ]* (.*)SKIPPED:.*$} $line -> testname
    set              testname [string trim $testname]
    variable xtest
    = "SKIP $testname"
    if {$xtest == {}} {
	variable xfile
	set xtest [linsert $xfile end $testname]
    }
    #sak::registry::local set $xtest Status Skip
    set xtest {}
    return -code continue
}

proc ::sak::test::run::TestPassed {} {
    upvar 1 line line
    if {![string match {++++ * PASSED} $line]} return
    set             testname [string range $line 5 end-7]
    variable xtest
    = "PASS $testname"
    if {$xtest == {}} {
	variable xfile
	set xtest [linsert $xfile end $testname]
    }
    #sak::registry::local set $xtest Status Pass
    set xtest {}
    return -code continue
}

proc ::sak::test::run::TestFailed {} {
    upvar 1 line line
    if {![string match {==== * FAILED} $line]} return
    set        testname [lindex [split [string range $line 5 end-7]] 0]
    = "FAIL $testname"
    variable xtest
    if {$xtest == {}} {
	variable xfile
	set xtest [linsert $xfile end $testname]
    }
    #sak::registry::local set $xtest Status Fail
    ## CAPTURE INIT
    variable xcollect  1
    variable xbody     ""
    variable xactual   ""
    variable xexpected ""
    variable xstatus   fail
    # Ignore failed status if we already have it, or an error
    # status. The latter is more important to show. We do override
    # status 'aborted'.
    if {$xstatus == "ok"}      {set xstatus fail}
    if {$xstatus == "aborted"} {set xstatus fail}
    return -code continue
}

proc ::sak::test::run::CaptureFailureSync {} {
    variable xcollect
    if {$xcollect != 1} return
    upvar 1 line line
    if {![string match {==== Contents*} $line]} return
    set xcollect 2
    return -code continue
}

proc ::sak::test::run::CaptureFailureCollectBody {} {
    variable xcollect
    if {$xcollect != 2} return
    upvar 1 rline line
    variable xbody
    if {[string match {---- Result was*} $line]} {
	set xcollect 3
	return -code continue
    } elseif {[string match {---- Test generated error*} $line]} {
	set xcollect 5
	return -code continue
    }

    variable xbody
    append   xbody $line \n
    return -code continue
}

proc ::sak::test::run::CaptureFailureCollectActual {} {
    variable xcollect
    if {$xcollect != 3} return
    upvar 1 rline line
    if {![string match {---- Result should*} $line]} {
	variable xactual
	append   xactual $line \n
    } else {
	set xcollect 4
    }
    return -code continue
}

proc ::sak::test::run::CaptureFailureCollectExpected {} {
    variable xcollect
    if {$xcollect != 4} return
    upvar 1 rline line
    if {![string match {==== *} $line]} {
	variable xexpected
	append   xexpected $line \n
    } else {
	variable alog
	if {$alog} {
	    variable logfad
	    variable xtest
	    variable xbody
	    variable xactual
	    variable xexpected

	    puts  $logfad "==== [lrange $xtest end-1 end] FAILED ========="
	    puts  $logfad "==== Contents of test case:\n"
	    puts  $logfad $xbody

	    puts  $logfad "---- Result was:"
	    puts  $logfad [string range $xactual 0 end-1]

	    puts  $logfad "---- Result should have been:"
	    puts  $logfad [string range $xexpected 0 end-1]

	    puts  $logfad "==== [lrange $xtest end-1 end] ====\n\n"
	    flush $logfad
	}
	set xcollect 0
	#sak::registry::local set $xtest Body     $xbody
	#sak::registry::local set $xtest Actual   $xactual
	#sak::registry::local set $xtest Expected $xexpected
	set xtest {}
    }
    return -code continue
}

proc ::sak::test::run::CaptureFailureCollectError {} {
    variable xcollect
    if {$xcollect != 5} return
    upvar 1 rline line
    variable xbody
    if {[string match {---- errorCode*} $line]} {
	set xcollect 4
	return -code continue
    }

    variable xactual
    append   xactual $line \n
    return -code continue
}

proc ::sak::test::run::Aborted {} {
    upvar 1 line line
    if {![string match {Aborting the tests found *} $line]} return
    variable xfile
    variable xstatus
    # Ignore aborted status if we already have it, or some other error
    # status (like error, or fail). These are more important to show.
    if {$xstatus == "ok"} {set xstatus aborted}
    = Aborted
    #sak::registry::local set $xfile Aborted {}
    return -code continue
}

proc ::sak::test::run::AbortCause {} {
    upvar 1 line line
    if {
	![string match {Requiring *} $line] &&
	![string match {Error in *} $line]
    } return ; # {}
    variable xfile
    = $line
    #sak::registry::local set $xfile Aborted $line
    return -code continue
}

proc ::sak::test::run::CaptureStackStart {} {
    upvar 1 line line
    if {![string match {@+*} $line]} return
    variable xstackcollect 1
    variable xstack        {}
    variable xstatus       error
    = {Error, capturing stacktrace}
    return -code continue
}

proc ::sak::test::run::CaptureStack {} {
    variable xstackcollect
    if {!$xstackcollect} return
    upvar 1 line line
    variable xstack
    if {![string match {@-*} $line]} {
	append xstack [string range $line 2 end] \n
    } else {
	set xstackcollect 0
	variable xfile
	variable alog
	#sak::registry::local set $xfile Stacktrace $xstack
	if {$alog} {
	    variable logerd
	    puts  $logerd "[lindex $xfile end] StackTrace"
	    puts  $logerd "========================================"
	    puts  $logerd $xstack
	    puts  $logerd "========================================\n\n"
	    flush $logerd
	}
    }
    return -code continue
}

proc ::sak::test::run::SetupError {} {
    upvar 1 line line
    if {![string match {SETUP Error*} $line]} return
    variable xstatus error
    = {Setup error}
    return -code continue
}

# ###

proc ::sak::test::run::+= {string} {
    variable araw
    if {$araw} return
    variable aprefix
    append   aprefix " " $string
    sak::animate::next $aprefix
    return
}

proc ::sak::test::run::= {string} {
    variable araw
    if {$araw} return
    variable aprefix
    sak::animate::next "$aprefix $string"
    return
}

proc ::sak::test::run::=| {string} {
    variable araw
    if {$araw} return
    variable aprefix
    sak::animate::last "$aprefix $string"
    variable alog
    if {$alog} {
	variable logsum
	variable logfai
	variable logski
	variable lognon
	variable xstatus
	puts $logsum "$aprefix $string" ; flush $logsum
	switch -exact -- $xstatus {
	    error   -
	    fail    {puts $logfai "$aprefix $string" ; flush $logfai}
	    none    {puts $lognon "$aprefix $string" ; flush $lognon}
	    aborted {puts $logski "$aprefix $string" ; flush $logski}
	}
    }
    set aprefix ""
    return
}

# ###

namespace eval ::sak::test::run {
    variable base     [file join $::distribution support devel]
    variable valgrind [auto_execok valgrind]

    # State of test processing.

    variable xstackcollect 0
    variable xstack    {}
    variable xcollect  0
    variable xbody     {}
    variable xactual   {}
    variable xexpected {}
    variable xhost     {}
    variable xplatform {}
    variable xcwd      {}
    variable xshell    {}
    variable xmodule   {}
    variable xfile     {}
    variable xtest     {}
    variable xstartfile {}
    variable xtimes     {}

    variable xstatus ok

    # Animation prefix of test processing, and flag controlling the
    # nature of logging (raw vs animation).

    variable aprefix   {}
    variable araw      0

    # Max length of module names and patchlevel information.

    variable maxml 0
    variable maxvl 0

    # Map from internal stati to the displayed human readable
    # strings. This includes the trailing whitespace needed for
    # vertical alignment.

    variable  xvstatus
    array set xvstatus {
	ok      {     }
	none    {None }
	aborted {Skip }
	error   {ERR  }
	fail    {FAILS}
    }
}

##
# ###

package provide sak::test::run 1.0

if 0 {
    # Bad valgrind, ok no valgrind
    if {$config(valgrind)} {
	foreach e $valgrind {lappend cmd $e}
	lappend cmd --num-callers=8
	lappend cmd --leak-resolution=high
	lappend cmd -v --leak-check=yes
	lappend cmd --show-reachable=yes
    }
    lappend cmd $sh
    lappend cmd [Driver] -modules $modules
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/test/shell.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

getpackage fileutil fileutil/fileutil.tcl

package require  sak::test
package require  sak::registry
namespace eval ::sak::test::shell {}

# ###

proc ::sak::test::shell {argv} {
    if {![llength $argv]} {Usage Sub command missing}

    set cmd  [lindex $argv 0]
    set argv [lrange $argv 1 end]

    switch -exact -- $cmd {
	add {
	    sak::test::shell::add $argv
	}
	delete {
	    sak::test::shell::delete $argv
	}
	default {
	    sak::test::usage Unknown command "\"shell $cmd\""
	}
    }
    return
}

proc ::sak::test::shell::list {} {
    return [sak::registry::local \
	    get||default Tests Shells {}]
}

proc ::sak::test::shell::add {paths} {
    foreach p $paths {
	if {![fileutil::test $p efrx msg "Shell"]} {
	    sak::test::usage $msg
	}
    }

    set shells [sak::registry::local \
	    get||default Tests Shells {}]
    array set known {}
    foreach sh $shells {set known($sh) .}

    set changed 0
    foreach p $paths {
	if {[info exists known($p)]} continue
	lappend shells $p
	set changed 1
    }

    if {$changed} {
	sak::registry::local \
		set Tests Shells [lsort -dict $shells]
    }
    return
}

proc ::sak::test::shell::delete {paths} {
    set shells [sak::registry::local \
	    get||default Tests Shells {}]
    array set known {}
    foreach sh $shells {set known($sh) .}

    set changed 0
    foreach p $paths {
	if {![info exists known($p)]} continue
	unset known($p)
	set changed 1
    }

    if {$changed} {
	sak::registry::local \
		set Tests Shells [lsort -dict \
		[array names known]]
    }
    return
}

# ###

namespace eval ::sak::test::shell {
}

##
# ###

package provide sak::test::shell 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































Deleted support/devel/sak/test/shells.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require  sak::test
package require  sak::test::shell
namespace eval ::sak::test::shells {}

# ###

proc ::sak::test::shells {argv} {
    if {[llength $argv]} {
	sak::test::usage Wrong # args
    }

    puts stdout [join [sak::test::shell::list] \n]
    return
}

##
# ###

package provide sak::test::shells 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































Deleted support/devel/sak/test/test.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

namespace eval ::sak::test {}

# ###

proc ::sak::test::usage {args} {
    package require sak::help
    puts stdout [join $args { }]\n[sak::help::on test]
    exit 1
}

##
# ###

package provide sak::test 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































Deleted support/devel/sak/test/topic.txt.

1
test		Execute testsuites
<


Deleted support/devel/sak/util/anim.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
# -*- tcl -*-
# (C) 2006-2013 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

namespace eval ::sak::animate {
    # EL (Erase Line)
    #    Sequence: ESC [ n K
    # ** Effect: if n is 0 or missing, clear from cursor to end of line
    #    Effect: if n is 1, clear from beginning of line to cursor
    #    Effect: if n is 2, clear entire line

    variable eeol \033\[K
}

# ###

proc ::sak::animate::init {} {
    variable prefix
    variable n      0
    variable max    [llength $prefix]
}

proc ::sak::animate::next {string} {
    variable prefix
    variable n
    variable max
    variable eeol

    puts -nonewline stdout \r\[[lindex $prefix $n]\]\ $string$eeol
    flush           stdout

    incr n ; if {$n >= $max} {set n 0}
    return
}

proc ::sak::animate::last {string} {
    variable clear

    puts  stdout \r\[$clear\]\ $string
    flush stdout
    return
}

# ###

namespace eval ::sak::animate {
    namespace export init next last

    variable  prefix {
	{*   }	{*   }	{*   }	{*   }	{*   }
	{ *  }	{ *  }	{ *  }	{ *  }	{ *  }
	{  * }	{  * }	{  * }	{  * }	{  * }
	{   *}	{   *}	{   *}	{   *}	{   *}
	{  * }	{  * }	{  * }	{  * }	{  * }
	{ *  }	{ *  }	{ *  }	{ *  }	{ *  }
    }
    variable clear {    }
}

##
# ###

package provide sak::animate 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































Deleted support/devel/sak/util/color.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

namespace eval ::sak::color {}

# ###

if {$::tcl_platform(platform) == "windows"} {
    # No ansi colorization on windows
    namespace eval ::sak::color {
	variable n
	foreach n {cya yel whi mag red green rst} {
	    proc $n {} {return ""}
	    namespace export $n

	    proc =$n {s} {return $s}
	    namespace export =$n
	}
	unset n
    }
} else {
    getpackage term::ansi::code::attr term/ansi/code/attr.tcl
    getpackage term::ansi::code::ctrl term/ansi/code/ctrl.tcl

    ::term::ansi::code::ctrl::import ::sak::color sda_bg* sda_reset

    namespace eval ::sak::color {
	variable s
	variable n
	foreach {s n} {
	    sda_bgcyan    cya
	    sda_bgyellow  yel
	    sda_bgwhite   whi
	    sda_bgmagenta mag
	    sda_bgred     red
	    sda_bggreen   green
	    sda_reset     rst
	} {
	    rename $s $n
	    namespace export $n

	    proc =$n {s} "return \[$n\]\$s\[rst\]"
	    namespace export =$n
	}
	unset s n
    }
}

##
# ###

package provide sak::color 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































Deleted support/devel/sak/util/feedback.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

# Feedback modes
#
# [short]   Animated short feedback on stdout, no logging
# [log]     Animated short feedback on stdout, logging to multiple files.
# [verbose] Logging to stdout
#
# Output commands for various destinations:
#
# <v> Verbose Log
# <s> Short Log
#
# Handling of the destinations per mode
#
#           <s>        <v>
# [short]   stdout,    /dev/null
# [log]     stdout,    file
# [verbose] /dev/null, stdout

# Log files for different things are opened on demand, i.e. on the
# first write to them. We can configure (per possible log) a string to
# be written before the first write. Reconfiguring that string for a
# log clears the flag for that log and causes the string to be
# rewritten on the next write.

package require sak::animate

namespace eval ::sak::feedback {
    namespace import ::sak::animate::next ; rename next aNext
    namespace import ::sak::animate::last ; rename last aLast
}

# ###

proc ::sak::feedback::init {mode stem} {
    variable  prefix  ""
    variable  short   [expr {$mode ne "verbose"}]
    variable  verbose [expr {$mode ne "short"}]
    variable  tofile  [expr {$mode eq "log"}]
    variable  lstem   $stem
    variable  dst     ""
    variable  lfirst
    unset     lfirst
    array set lfirst {}
    # Note: lchan is _not_ reset. We keep channels, allowing us to
    #       merge output from different modules, if they are run as
    #       one unit (Example: validate and its various parts, which
    #       can be run separately, and together).
    return
}

proc ::sak::feedback::first {dst string} {
    variable lfirst
    set lfirst($dst) $string
    return
}

###

proc ::sak::feedback::summary {text} {
    #=|  $text
    #log $text

    variable short
    variable verbose
    if {$short}   { puts                $text }
    if {$verbose} { puts [_channel log] $text }
    return
}


proc ::sak::feedback::log {text {ext log}} {
    variable verbose
    if {!$verbose} return
    set    c [_channel $ext]
    puts  $c $text
    flush $c
    return
}

###

proc ::sak::feedback::! {} {
    variable short
    if {!$short} return
    variable prefix ""
    sak::animate::init
    return
}

proc ::sak::feedback::+= {string} {
    variable short
    if {!$short} return
    variable prefix
    append   prefix " " $string
    aNext               $prefix
    return
}

proc ::sak::feedback::= {string} {
    variable short
    if {!$short} return
    variable prefix
    aNext  "$prefix $string"
    return
}

proc ::sak::feedback::=| {string} {
    variable short
    if {!$short} return

    variable prefix
    aLast  "$prefix $string"

    variable verbose
    if {$verbose} {
	variable dst
	if {[string length $dst]} {
	    # inlined 'log'
	    set    c [_channel $dst]
	    puts  $c "$prefix $string"
	    flush $c
	    set dst ""
	}
    }

    set prefix ""
    return
}

proc ::sak::feedback::>> {string} {
    variable dst $string
    return
}

# ###

proc ::sak::feedback::_channel {dst} {
    variable tofile
    if {!$tofile} { return stdout }
    variable lchan
    if {[info exists lchan($dst)]} {
	set c $lchan($dst)
    } else {
	variable lstem
	set c [open ${lstem}.$dst w]
	set lchan($dst) $c
    }
    variable lfirst
    if {[info exists lfirst($dst)]} {
	puts $c $lfirst($dst)
	unset lfirst($dst)
    }
    return $c
}

# ###

namespace eval ::sak::feedback {
    namespace export >> ! += = =| init log summary

    variable  dst      ""
    variable  prefix   ""
    variable  short    ""
    variable  verbose  ""
    variable  tofile   ""
    variable  lstem    ""
    variable  lchan
    array set lchan {}

    variable  lfirst
    array set lfirst {}
}

##
# ###

package provide sak::feedback 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































































































































































































































































Deleted support/devel/sak/util/pkgIndex.tcl.

1
2
3
4
5
6
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::util     1.0 [list source [file join $dir util.tcl]]
package ifneeded sak::registry 1.0 [list source [file join $dir registry.tcl]]
package ifneeded sak::animate  1.0 [list source [file join $dir anim.tcl]]
package ifneeded sak::color    1.0 [list source [file join $dir color.tcl]]
package ifneeded sak::feedback 1.0 [list source [file join $dir feedback.tcl]]
<
<
<
<
<
<












Deleted support/devel/sak/util/registry.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

getpackage pregistry registry/registry.tcl

namespace eval ::sak::registry {}

proc ::sak::registry::local {args} {
    return [uplevel 1 [linsert $args 0 [Setup]]]
    # return <$_local {expand}$args>
}

proc ::sak::registry::Setup {} {
    variable _local
    variable state
    variable statedir

    if {![file exists $statedir]} {
	file mkdir $statedir
    }

    if {$_local == {}} {
	set _local [pregistry %AUTO% \
		-tie [list file $state]]
    }

    return $_local
}

proc ::sak::registry::Refresh {} {
    variable _local
    $_local destroy
    set _local {}
    Setup
    return
}

namespace eval ::sak::registry {
    variable _here    [file dirname [info script]]

    variable statedir [file join ~ .Tcllib]
    variable state    [file join $statedir Registry]
    variable _local   {}
}

##
# ###

package provide sak::registry 1.0

# ###
## Data structures
#
## Core is a tree (struct::tree), keys are lists, mapping to a node,
## starting from the root. Attributes are node attributes. A prefix is
## used to distinguish them from the attributes used for internal
## purposes.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






















































































































Deleted support/devel/sak/util/util.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
# -*- tcl -*-
# (C) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

namespace eval ::sak::util {}

# ###

proc ::sak::util::path2modules {paths} {
    set modules {}
    foreach p $paths {
	if {[file exists $p]} {set p [file tail $p]}
	lappend modules $p
    }
    return $modules
}

proc ::sak::util::modules2path {modules} {
    global distribution
    set modbase [file join $distribution modules]

    set paths {}
    foreach m $modules {
	lappend paths [file join $modbase $m]
    }
    return $paths
}

proc ::sak::util::module2path {module} {
    global distribution
    set modbase [file join $distribution modules]
    return [file join $modbase $module]
}

proc ::sak::util::checkModules {modvar} {
    upvar 1 $modvar modules

    if {![llength $modules]} {
	# Default to all if none are specified. This information does
	# not require validation.

	set modules [modules]
	return 1
    }

    set modules [path2modules $modules]

    set fail 0
    foreach m $modules {
	if {[modules_mod $m]} {
	    lappend results $m
	    continue
	}

	puts "  Unknown module: $m"
	set fail 1
    }

    if {$fail} {
	puts "  Stop."
	return 0
    }

    set modules $results
    return 1
}

##
# ###

package provide sak::util 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
















































































































































Deleted support/devel/sak/validate/cmd.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
# -*- tcl -*-
# Implementation of 'validate'.

# Available variables
# * argv  - Cmdline arguments
# * base  - Location of sak.tcl = Top directory of Tcllib distribution
# * cbase - Location of all files relevant to this command.
# * sbase - Location of all files supporting the SAK.

package require sak::util
package require sak::validate

set raw  0
set log  0
set stem {}
set tclv {}

if {[llength $argv]} {
    # First argument may be a command.
    set cmd [lindex $argv 0]
    if {![catch {
	package require sak::validate::$cmd
    } msg]} {
	set argv [lrange $argv 1 end]
    } else {
	set cmd all
    }

    # Now process any possible options (-v, -l, --log).

    while {[string match -* [set opt [lindex $argv 0]]]} {
	switch -exact -- $opt {
	    -v {
		set raw 1
		set argv [lrange $argv 1 end]
	    }
	    -l - --log {
		set log 1
		set stem [lindex $argv 1]
		set argv [lrange $argv 2 end]
	    }
	    -t - --tcl {
		set tclv [lindex $argv 1]
		set argv [lrange $argv 2 end]
	    }
	    default {
		sak::validate::usage Unknown option "\"$opt\""
	    }
	}
    }
} else {
    set cmd all
}

# At last now handle all remaining arguments as module specifications.
if {![sak::util::checkModules argv]} return

if {$log} { set raw 0 }

array set mode {
    00 short
    01 log
    10 verbose
    11 _impossible_
}

sak::validate::$cmd $argv $mode($raw$log) $stem $tclv

##
# ###
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<












































































































































Deleted support/devel/sak/validate/help.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

    validate -- Validate modules and packages

    sak validate            ?-v? ?-l|--log STEM? ?MODULE ...?
    sak validate manpages   ?-v? ?-l|--log STEM? ?MODULE ...?
    sak validate versions   ?-v? ?-l|--log STEM? ?MODULE ...?
    sak validate testsuites ?-v? ?-l|--log STEM? ?MODULE ...?
    sak validate syntax     ?-v? ?-l|--log STEM? ?MODULE ...?

    	Validate one or more aspects of the specified modules and the
    	packages they contain. If no module is specified all modules
    	are validated. If no aspect was specified all possible aspects
    	are validated.

        By default the output from a validation run is animated
        feedback of the progress made, plus summarized color-coded
        results. If -v is specified the actual log is returned
        instead.

        If a log STEM is specified the extended log normally activated
        via -v is written to STEM.log while the user is provided with
        the regular feedback during execution. Usage of the -l switch
        overides -v.

	The system is currently able to validate the following aspects
	of the module and package sources:

	manpages
		Reports modules/packages without documentation, and
		modules/packages which have syntactically flawed
		documentation. The second part is identical to

			sak doc validate
			
	versions
		Reports modules and packages with mismatches between
		'package ifneeded' and 'package provided' commands.

	testsuites
		Report modules and packages without testsuites.

		Note that this command is _not_ actually executing the
		testsuites. That is done via

			sak test run ...

		See its documentation (sak help test) for more
		information.

	syntax
		Scan modules and packages using various tools
		statically checking Tcl syntax, and report their
		outputs.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































Deleted support/devel/sak/validate/manpages.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require  sak::animate
package require  sak::feedback
package require  sak::color

getpackage textutil::repeat textutil/repeat.tcl
getpackage doctools         doctools/doctools.tcl

namespace eval ::sak::validate::manpages {
    namespace import ::textutil::repeat::blank
    namespace import ::sak::color::*
    namespace import ::sak::feedback::!
    namespace import ::sak::feedback::>>
    namespace import ::sak::feedback::+=
    namespace import ::sak::feedback::=
    namespace import ::sak::feedback::=|
    namespace import ::sak::feedback::log
    namespace import ::sak::feedback::summary
    rename summary sum
}

# ###

proc ::sak::validate::manpages {modules mode stem tclv} {
    manpages::run $modules $mode $stem $tclv
    manpages::summary
    return
}

proc ::sak::validate::manpages::run {modules mode stem tclv} {
    sak::feedback::init $mode $stem
    sak::feedback::first log  "\[ Documentation \] ==============================================="
    sak::feedback::first unc  "\[ Documentation \] ==============================================="
    sak::feedback::first fail "\[ Documentation \] ==============================================="
    sak::feedback::first warn "\[ Documentation \] ==============================================="
    sak::feedback::first miss "\[ Documentation \] ==============================================="
    sak::feedback::first none "\[ Documentation \] ==============================================="

    # Preprocessing of module names to allow better formatting of the
    # progress output, i.e. vertically aligned columns

    # Per module we can distinguish the following levels of
    # documentation completeness and validity

    # Completeness:
    # - No package has documentation
    # - Some, but not all packages have documentation
    # - All packages have documentation.
    #
    # Validity, restricted to the set packages which have documentation:
    # - Documentation has errors and warnings
    # - Documentation has errors, but no warnings.
    # - Documentation has no errors, but warnings.
    # - Documentation has neither errors nor warnings.

    # Progress report per module: Packages it is working on.
    # Summary at module level:
    # - Number of packages, number of packages with documentation,
    # - Number of errors, number of warnings.

    # Full log:
    # - Lists packages without documentation.
    # - Lists packages with errors/warnings.
    # - Lists the exact errors/warnings per package, and location.

    # Global preparation: Pull information about all packages and the
    # modules they belong to.

    ::doctools::new dt -format desc -deprecated 1

    Count $modules
    MapPackages

    InitCounters
    foreach m $modules {
	# Skip tcllibc shared library, not a module.
	if {[string equal $m tcllibc]} continue

	InitModuleCounters
	!
	log "@@ Module $m"
	Head $m

	# Per module: Find all doctools manpages inside and process
	# them. We get errors, warnings, and determine the package(s)
	# they may belong to.

	# Per package: Have they doc files claiming them? After that,
	# are doc files left over (i.e. without a package)?

	ProcessPages    $m
	ProcessPackages $m
	ProcessUnclaimed
	ModuleSummary
    }

    dt destroy
    return
}

proc ::sak::validate::manpages::summary {} {
    Summary
    return
}

# ###

proc ::sak::validate::manpages::ProcessPages {m} {
    !claims
    dt configure -module $m
    foreach f [glob -nocomplain [file join [At $m] *.man]] {
	ProcessManpage $f
    }
    return
}

proc ::sak::validate::manpages::ProcessManpage {f} {
    =file              $f
    dt configure -file $f

    if {[catch {
	dt format [get_input $f]
    } msg]} {
	+e $msg
    } else {
	foreach {pkg _ _} $msg { +claim $pkg }
    }

    set warnings [dt warnings]
    if {![llength $warnings]} return

    foreach msg $warnings { +w $msg }
    return
}

proc ::sak::validate::manpages::ProcessPackages {m} {
    !used
    if {![HasPackages $m]} return

    foreach p [ThePackages $m] {
	+pkg $p
	if {[claimants $p]} {
	    +doc $p
	} else {
	    nodoc $p
	}
    }
    return
}

proc ::sak::validate::manpages::ProcessUnclaimed {} {
    variable claims
    if {![array size claims]} return
    foreach p [lsort -dict [array names claims]] {
	foreach fx $claims($p) { +u $fx }
    }
    return
}

###

proc ::sak::validate::manpages::=file {f} {
    variable current [file tail $f]
    = "$current ..."
    return
}

###

proc ::sak::validate::manpages::!claims {} {
    variable    claims
    array unset claims *
    return
}

proc ::sak::validate::manpages::+claim {pkg} {
    variable current
    variable claims
    lappend  claims($pkg) $current
    return
}

proc ::sak::validate::manpages::claimants {pkg} {
    variable claims
    expr { [info exists claims($pkg)] && [llength $claims($pkg)] }
}


###

proc ::sak::validate::manpages::!used {} {
    variable    used
    array unset used *
    return
}

proc ::sak::validate::manpages::+use {pkg} {
    variable used
    variable claims
    foreach fx $claims($pkg) { set used($fx) . }
    unset claims($pkg)
    return
}

###

proc ::sak::validate::manpages::MapPackages {} {
    variable    pkg
    array unset pkg *

    !
    += Package
    foreach {pname pdata} [ipackages] {
	= "$pname ..."
	foreach {pver pmodule} $pdata break
	lappend pkg($pmodule) $pname
    }
    !
    =| {Packages mapped ...}
    return
}

proc ::sak::validate::manpages::HasPackages {m} {
    variable pkg
    expr { [info exists pkg($m)] && [llength $pkg($m)] }
}

proc ::sak::validate::manpages::ThePackages {m} {
    variable pkg
    return [lsort -dict $pkg($m)]
}

###

proc ::sak::validate::manpages::+pkg {pkg} {
    variable mtotal ; incr mtotal
    variable total  ; incr total
    return
}

proc ::sak::validate::manpages::+doc {pkg} {
    variable mhavedoc ; incr mhavedoc
    variable havedoc  ; incr havedoc
    = "$pkg Ok"
    +use $pkg
    return
}

proc ::sak::validate::manpages::nodoc {pkg} {
    = "$pkg Bad"
    log "@@ WARN  No documentation: $pkg"
    return
}

###

proc ::sak::validate::manpages::+w {msg} {
    variable mwarnings ; incr mwarnings
    variable warnings  ; incr warnings
    variable current
    foreach {a b c} [split $msg \n] break
    log "@@ WARN  $current: [Trim $a] [Trim $b] [Trim $c]"
    return
}

proc ::sak::validate::manpages::+e {msg} {
    variable merrors ; incr merrors
    variable errors  ; incr errors
    variable current
    log "@@ ERROR $current $msg"
    return
}

proc ::sak::validate::manpages::+u {f} {
    variable used
    if {[info exists used($f)]} return
    variable munclaimed ; incr munclaimed
    variable unclaimed  ; incr unclaimed
    set used($f) .
    log "@@ WARN  Unclaimed documentation file: $f"
    return
}

###

proc ::sak::validate::manpages::Count {modules} {
    variable maxml 0
    !
    foreach m [linsert $modules 0 Module] {
	= "M $m"
	set l [string length $m]
	if {$l > $maxml} {set maxml $l}
    }
    =| "Validate documentation (existence, errors, warnings) ..."
    return
}

proc ::sak::validate::manpages::Head {m} {
    variable maxml
    += ${m}[blank [expr {$maxml - [string length $m]}]]
    return
}

###

proc ::sak::validate::manpages::InitModuleCounters {} {
    variable mtotal     0
    variable mhavedoc   0
    variable munclaimed 0
    variable merrors    0
    variable mwarnings  0
    return
}

proc ::sak::validate::manpages::ModuleSummary {} {
    variable mtotal
    variable mhavedoc
    variable munclaimed
    variable merrors
    variable mwarnings

    set complete [F $mhavedoc]/[F $mtotal]
    set not      "! [F [expr {$mtotal - $mhavedoc}]]"
    set err      "E [F $merrors]"
    set warn     "W [F $mwarnings]"
    set unc      "U [F $munclaimed]"

    if {$munclaimed} {
	set unc [=cya $unc]
	>> unc
    }
    if {!$mhavedoc && $mtotal} {
	set complete [=red $complete]
	set not      [=red $not]
	>> none
    } elseif {$mhavedoc < $mtotal} {
	set complete [=yel $complete]
	set not      [=yel $not]
	>> miss
    }
    if {$merrors} {
	set err  [=red $err]
	set warn [=yel $warn]
	>> fail
    } elseif {$mwarnings} {
	set warn [=yel $warn]
	>> warn
    }

    =| "~~ $complete $not $unc $err $warn"
    return
}

###

proc ::sak::validate::manpages::InitCounters {} {
    variable total     0
    variable havedoc   0
    variable unclaimed 0
    variable errors    0
    variable warnings  0
    return
}

proc ::sak::validate::manpages::Summary {} {
    variable total
    variable havedoc
    variable unclaimed
    variable errors
    variable warnings

    set tot   [F $total]
    set doc   [F $havedoc]
    set udc   [F [expr {$total - $havedoc}]]

    set unc   [F $unclaimed]
    set per   [format %6.2f [expr {$havedoc*100./$total}]]
    set uper  [format %6.2f [expr {($total - $havedoc)*100./$total}]]
    set err   [F $errors]
    set wrn   [F $warnings]

    if {$errors}    { set err [=red $err] }
    if {$warnings}  { set wrn [=yel $wrn] }
    if {$unclaimed} { set unc [=cya $unc] }

    if {!$havedoc && $total} {
	set doc [=red $doc]
	set udc [=red $udc]
    } elseif {$havedoc < $total} {
	set doc [=yel $doc]
	set udc [=yel $udc]
    }

    sum ""
    sum "Documentation statistics"
    sum "#Packages:     $tot"
    sum "#Documented:   $doc (${per}%)"
    sum "#Undocumented: $udc (${uper}%)"
    sum "#Unclaimed:    $unc"
    sum "#Errors:       $err"
    sum "#Warnings:     $wrn"
    return
}

###

proc ::sak::validate::manpages::F {n} { format %6d $n }

proc ::sak::validate::manpages::Trim {text} {
    regsub {^[^:]*:} $text {} text
    return [string trim $text]
}

###

proc ::sak::validate::manpages::At {m} {
    global distribution
    return [file join $distribution modules $m]
}

# ###

namespace eval ::sak::validate::manpages {
    # Max length of module names and patchlevel information.
    variable maxml 0

    # Counters across all modules
    variable total     0 ; # Number of packages overall.
    variable havedoc   0 ; # Number of packages with documentation.
    variable unclaimed 0 ; # Number of manpages not claimed by a specific package.
    variable errors    0 ; # Number of errors found in all documentation.
    variable warnings  0 ; # Number of warnings found in all documentation.

    # Same counters, per module.
    variable mtotal     0
    variable mhavedoc   0
    variable munclaimed 0
    variable merrors    0
    variable mwarnings  0

    # Name of currently processed manpage
    variable current ""

    # Map from packages to files claiming to document them.
    variable  claims
    array set claims {}

    # Set of files taken by packages, as array
    variable  used
    array set used {}

    # Map from modules to packages contained in them
    variable  pkg
    array set pkg {}
}

##
# ###

package provide sak::validate::manpages 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/validate/pkgIndex.tcl.

1
2
3
4
5
6
if {![package vsatisfies [package provide Tcl] 8.2]} return
package ifneeded sak::validate             1.0 [list source [file join $dir validate.tcl]]
package ifneeded sak::validate::manpages   1.0 [list source [file join $dir manpages.tcl]]
package ifneeded sak::validate::versions   1.0 [list source [file join $dir versions.tcl]]
package ifneeded sak::validate::testsuites 1.0 [list source [file join $dir testsuites.tcl]]
package ifneeded sak::validate::syntax     1.0 [list source [file join $dir syntax.tcl]]
<
<
<
<
<
<












Deleted support/devel/sak/validate/syntax.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require  sak::animate
package require  sak::feedback
package require  sak::color

getpackage textutil::repeat textutil/repeat.tcl
getpackage doctools         doctools/doctools.tcl

namespace eval ::sak::validate::syntax {
    namespace import ::textutil::repeat::blank
    namespace import ::sak::color::*
    namespace import ::sak::feedback::!
    namespace import ::sak::feedback::>>
    namespace import ::sak::feedback::+=
    namespace import ::sak::feedback::=
    namespace import ::sak::feedback::=|
    namespace import ::sak::feedback::log
    namespace import ::sak::feedback::summary
    rename summary sum
}

# ###

proc ::sak::validate::syntax {modules mode stem tclv} {
    syntax::run $modules $mode $stem $tclv
    syntax::summary
    return
}

proc ::sak::validate::syntax::run {modules mode stem tclv} {
    sak::feedback::init $mode $stem
    sak::feedback::first log  "\[ Syntax \] ======================================================"
    sak::feedback::first unc  "\[ Syntax \] ======================================================"
    sak::feedback::first fail "\[ Syntax \] ======================================================"
    sak::feedback::first warn "\[ Syntax \] ======================================================"
    sak::feedback::first miss "\[ Syntax \] ======================================================"
    sak::feedback::first none "\[ Syntax \] ======================================================"

    # Preprocessing of module names to allow better formatting of the
    # progress output, i.e. vertically aligned columns

    # Per module we can distinguish the following levels of
    # syntactic completeness and validity.

    # Rule completeness
    # - No package has pcx rules
    # - Some, but not all packages have pcx rules
    # - All packages have pcx rules
    #
    # Validity. Not of the pcx rules, but of the files in the
    # packages.
    # - Package has errors and warnings
    # - Package has errors, but no warnings.
    # - Package has no errors, but warnings.
    # - Package has neither errors nor warnings.

    # Progress report per module: Modules and packages it is working on.
    # Summary at module level:
    # - Number of packages, number of packages with pcx rules
    # - Number of errors, number of warnings.

    # Full log:
    # - Lists packages without pcx rules.
    # - Lists packages with errors/warnings.
    # - Lists the exact errors/warnings per package, and location.

    # Global preparation: Pull information about all packages and the
    # modules they belong to.

    Setup
    Count $modules
    MapPackages

    InitCounters
    foreach m $modules {
	# Skip tcllibc shared library, not a module.
	if {[string equal $m tcllibc]} continue

	InitModuleCounters
	!
	log "@@ Module $m"
	Head $m

	# Per module: Find all syntax definition (pcx) files inside
	# and process them. Further find all the Tcl files and process
	# them as well. We get errors, warnings, and determine the
	# package(s) they may belong to.

	# Per package: Have they pcx files claiming them? After that,
	# are pcx files left over (i.e. without a package)?

	ProcessAllPCX     $m
	ProcessPackages   $m
	ProcessUnclaimed
	ProcessTclSources $m $tclv
	ModuleSummary
    }

    Shutdown
    return
}

proc ::sak::validate::syntax::summary {} {
    Summary
    return
}

# ###

proc ::sak::validate::syntax::ProcessAllPCX {m} {
    !claims
    foreach f [glob -nocomplain [file join [At $m] *.pcx]] {
	ProcessOnePCX $f
    }
    return
}

proc ::sak::validate::syntax::ProcessOnePCX {f} {
    =file $f

    if {[catch {
	Scan [get_input $f]
    } msg]} {
	+e $msg
    } else {
        +claim $msg
    }

    return
}

proc ::sak::validate::syntax::ProcessPackages {m} {
    !used
    if {![HasPackages $m]} return

    foreach p [ThePackages $m] {
	+pkg $p
	if {[claimants $p]} {
	    +pcx $p
	} else {
	    nopcx $p
	}
    }
    return
}

proc ::sak::validate::syntax::ProcessUnclaimed {} {
    variable claims
    if {![array size claims]} return
    foreach p [lsort -dict [array names claims]] {
	foreach fx $claims($p) { +u $fx }
    }
    return
}

proc ::sak::validate::syntax::ProcessTclSources {m tclv} {
    variable tclchecker
    if {![llength $tclchecker]} return

    foreach t [modtclfiles $m] {
	# Ignore TeX files.
	if {[string equal [file extension $t] .tex]} continue

	=file $t
	set cmd [Command $t $tclv]
	if {[catch {Close [Process [open |$cmd r+]]} msg]} {
	    if {[string match {*child process exited abnormally*} $msg]} continue
	    +e $msg
	}
    }
    return
}

###

proc ::sak::validate::syntax::Setup {} {
    variable ip [interp create]

    # Make it mostly empty (We keep the 'set' command).

    foreach n [interp eval $ip [list ::namespace children ::]] {
	if {[string equal $n ::tcl]} continue
	interp eval $ip [list namespace delete $n]
    }
    foreach c [interp eval $ip [list ::info commands]] {
	if {[string equal $c set]}       continue
	if {[string equal $c if]}        continue
	if {[string equal $c rename]}    continue
	if {[string equal $c namespace]} continue
	interp eval $ip [list ::rename $c {}]
    }

    if {![package vsatisfies [package present Tcl] 8.6]} {
	interp eval $ip [list ::namespace delete ::tcl]
    }
    interp eval $ip [list ::rename namespace {}]
    interp eval $ip [list ::rename rename    {}]

    foreach m {
	pcx::register unknown
    } {
	interp alias $ip $m {} ::sak::validate::syntax::PCX/[string map {:: _} $m] $ip
    }
    return
}

proc ::sak::validate::syntax::Shutdown {} {
    variable ip
    interp delete $ip
    return
}

proc ::sak::validate::syntax::Scan {data} {
    variable ip
    variable pcxpackage
    while {1} {
	if {[catch {
	    $ip eval $data
	} msg]} {
	    if {[string match {can't read "*": no such variable} $msg]} {
		regexp  {can't read "(.*)": no such variable} $msg -> var
		log "@@ + variable \"$var\""
		$ip eval [list set $var {}]
		continue
	    }
	    return -code error $msg
	}
	break
    }
    return $pcxpackage
}

proc ::sak::validate::syntax::PCX/pcx_register {ip pkg} {
    variable pcxpackage $pkg
    return
}

proc ::sak::validate::syntax::PCX/unknown {ip args} {
    return 0
}

###

proc ::sak::validate::syntax::Process {pipe} {
    variable current
    set dst log
    while {1} {
	if {[eof  $pipe]} break
	if {[gets $pipe line] < 0} break

	set tline [string trim $line]
	if {[string equal $tline ""]} continue

	if {[string match scanning:* $tline]} {
	    log $line
	    continue
	}
	if {[string match checking:* $tline]} {
	    log $line
	    continue
	}
	if {[regexp {^([^:]*):(\d+) \(([^)]*)\) (.*)$} $tline -> path at code detail]} {
	    = "$current $at $code"
	    set dst code,$code
	    if {[IsError $code]} {
		+e $line
	    } else {
		+w $line
	    }
	}
	log $line $dst
    }
    return $pipe
}

proc ::sak::validate::syntax::IsError {code} {
    variable codetype
    variable codec
    if {[info exists codec($code)]} {
	return $codec($code)
    }

    foreach {p t} $codetype {
	if {![string match $p $code]} continue
	set codec($code) $t
	return $t
    }

    # We assume that codetype contains a default * pattern as the last
    # entry, capturing all unknown codes.
    +e INTERNAL
    exit
}

proc ::sak::validate::syntax::Command {t tclv} {
    # Unix. Construction of the pipe to run the tclchecker against a
    # single tcl file.

    set     cmd [Driver $tclv]
    lappend cmd $t

    #lappend cmd >@ stdout 2>@ stderr
    #puts <<$cmd>>

    return $cmd
}

proc ::sak::validate::syntax::Close {pipe} {
    close $pipe
    return
}

proc ::sak::validate::syntax::Driver {tclv} {
    variable tclchecker
    set cmd $tclchecker

    if {$tclv ne {}} { lappend cmd -use Tcl-$tclv }

    # Make all syntax definition files we may have available to the
    # checker for higher accuracy of its output.
    foreach m [modules] { lappend cmd -pcx [At $m] }

    # Memoize
    proc ::sak::validate::syntax::Driver {tclv} [list return $cmd]
    return $cmd
}

###

proc ::sak::validate::syntax::=file {f} {
    variable current [file tail $f]
    = "$current ..."
    return
}

###

proc ::sak::validate::syntax::!claims {} {
    variable    claims
    array unset claims *
    return
}

proc ::sak::validate::syntax::+claim {pkg} {
    variable current
    variable claims
    lappend  claims($pkg) $current
    return
}

proc ::sak::validate::syntax::claimants {pkg} {
    variable claims
    expr { [info exists claims($pkg)] && [llength $claims($pkg)] }
}


###

proc ::sak::validate::syntax::!used {} {
    variable    used
    array unset used *
    return
}

proc ::sak::validate::syntax::+use {pkg} {
    variable used
    variable claims
    foreach fx $claims($pkg) { set used($fx) . }
    unset claims($pkg)
    return
}

###

proc ::sak::validate::syntax::MapPackages {} {
    variable    pkg
    array unset pkg *

    !
    += Package
    foreach {pname pdata} [ipackages] {
	= "$pname ..."
	foreach {pver pmodule} $pdata break
	lappend pkg($pmodule) $pname
    }
    !
    =| {Packages mapped ...}
    return
}

proc ::sak::validate::syntax::HasPackages {m} {
    variable pkg
    expr { [info exists pkg($m)] && [llength $pkg($m)] }
}

proc ::sak::validate::syntax::ThePackages {m} {
    variable pkg
    return [lsort -dict $pkg($m)]
}

###

proc ::sak::validate::syntax::+pkg {pkg} {
    variable mtotal ; incr mtotal
    variable total  ; incr total
    return
}

proc ::sak::validate::syntax::+pcx {pkg} {
    variable mhavepcx ; incr mhavepcx
    variable havepcx  ; incr havepcx
    = "$pkg Ok"
    +use $pkg
    return
}

proc ::sak::validate::syntax::nopcx {pkg} {
    = "$pkg Bad"
    log "@@ WARN  No syntax definition: $pkg"
    return
}

###

proc ::sak::validate::syntax::+w {msg} {
    variable mwarnings ; incr mwarnings
    variable warnings  ; incr warnings
    variable current
    foreach {a b c} [split $msg \n] break
    log "@@ WARN  $current: [Trim $a] [Trim $b] [Trim $c]"
    return
}

proc ::sak::validate::syntax::+e {msg} {
    variable merrors ; incr merrors
    variable errors  ; incr errors
    variable current
    log "@@ ERROR $current $msg"
    return
}

proc ::sak::validate::syntax::+u {f} {
    variable used
    if {[info exists used($f)]} return
    variable munclaimed ; incr munclaimed
    variable unclaimed  ; incr unclaimed
    set used($f) .
    log "@@ WARN  Unclaimed syntax definition file: $f"
    return
}

###

proc ::sak::validate::syntax::Count {modules} {
    variable maxml 0
    !
    foreach m [linsert $modules 0 Module] {
	= "M $m"
	set l [string length $m]
	if {$l > $maxml} {set maxml $l}
    }
    =| "Validate syntax (code, and API definitions) ..."
    return
}

proc ::sak::validate::syntax::Head {m} {
    variable maxml
    += ${m}[blank [expr {$maxml - [string length $m]}]]
    return
}

###

proc ::sak::validate::syntax::InitModuleCounters {} {
    variable mtotal     0
    variable mhavepcx   0
    variable munclaimed 0
    variable merrors    0
    variable mwarnings  0
    return
}

proc ::sak::validate::syntax::ModuleSummary {} {
    variable mtotal
    variable mhavepcx
    variable munclaimed
    variable merrors
    variable mwarnings
    variable tclchecker

    set complete [F $mhavepcx]/[F $mtotal]
    set not      "! [F [expr {$mtotal - $mhavepcx}]]"
    set err      "E [F $merrors]"
    set warn     "W [F $mwarnings]"
    set unc      "U [F $munclaimed]"

    if {$munclaimed} {
	set unc [=cya $unc]
	>> unc
    }
    if {!$mhavepcx && $mtotal} {
	set complete [=red $complete]
	set not      [=red $not]
	>> none
    } elseif {$mhavepcx < $mtotal} {
	set complete [=yel $complete]
	set not      [=yel $not]
	>> miss
    }
    if {[llength $tclchecker]} {
	if {$merrors} {
	    set err  " [=red $err]"
	    set warn " [=yel $warn]"
	    >> fail
	} elseif {$mwarnings} {
	    set err " $err"
	    set warn " [=yel $warn]"
	    >> warn
	} else {
	    set err  " $err"
	    set warn " $warn"
	}
    } else {
	set err  ""
	set warn ""
    }

    =| "~~ $complete $not $unc$err$warn"
    return
}

###

proc ::sak::validate::syntax::InitCounters {} {
    variable total     0
    variable havepcx   0
    variable unclaimed 0
    variable errors    0
    variable warnings  0
    return
}

proc ::sak::validate::syntax::Summary {} {
    variable total
    variable havepcx
    variable unclaimed
    variable errors
    variable warnings
    variable tclchecker

    set tot   [F $total]
    set doc   [F $havepcx]
    set udc   [F [expr {$total - $havepcx}]]

    set unc   [F $unclaimed]
    set per   [format %6.2f [expr {$havepcx*100./$total}]]
    set uper  [format %6.2f [expr {($total - $havepcx)*100./$total}]]
    set err   [F $errors]
    set wrn   [F $warnings]

    if {$errors}    { set err [=red $err] }
    if {$warnings}  { set wrn [=yel $wrn] }
    if {$unclaimed} { set unc [=cya $unc] }

    if {!$havepcx && $total} {
	set doc [=red $doc]
	set udc [=red $udc]
    } elseif {$havepcx < $total} {
	set doc [=yel $doc]
	set udc [=yel $udc]
    }

    if {[llength $tclchecker]} {
	set sfx " ($tclchecker)"
    } else {
	set sfx " ([=cya {No tclchecker available}])"
    }

    sum ""
    sum "Syntax statistics$sfx"
    sum "#Packages:     $tot"
    sum "#Syntax def:   $doc (${per}%)"
    sum "#No syntax:    $udc (${uper}%)"
    sum "#Unclaimed:    $unc"
    if {[llength $tclchecker]} {
	sum "#Errors:       $err"
	sum "#Warnings:     $wrn"
    }
    return
}

###

proc ::sak::validate::syntax::F {n} { format %6d $n }

proc ::sak::validate::syntax::Trim {text} {
    regsub {^[^:]*:} $text {} text
    return [string trim $text]
}

###

proc ::sak::validate::syntax::At {m} {
    global distribution
    return [file join $distribution modules $m]
}

# ###

namespace eval ::sak::validate::syntax {
    # Max length of module names and patchlevel information.
    variable maxml 0

    # Counters across all modules
    variable total     0 ; # Number of packages overall.
    variable havepcx   0 ; # Number of packages with syntax definition (pcx) files.
    variable unclaimed 0 ; # Number of PCX files not claimed by a specific package.
    variable errors    0 ; # Number of errors found in all code.
    variable warnings  0 ; # Number of warnings found in all code.

    # Same counters, per module.
    variable mtotal     0
    variable mhavepcx   0
    variable munclaimed 0
    variable merrors    0
    variable mwarnings  0

    # Name of currently processed syntax definition or code file
    variable current ""

    # Map from packages to files claiming to define the syntax of their API.
    variable  claims
    array set claims {}

    # Set of files taken by packages, as array
    variable  used
    array set used {}

    # Map from modules to packages contained in them
    variable  pkg
    array set pkg {}

    # Transient storage used while collecting packages per syntax definition.
    variable pcxpackage {}
    variable ip         {}

    # Location of the tclchecker used to perform syntactic validation.
    variable tclchecker [auto_execok tclchecker]

    # Patterns for separation of errors from warnings
    variable codetype {
	warn*        0
	nonPort*     0
	pkgUnchecked 0
	pkgVConflict 0
	*            1
    }
    variable codec ; array  set codec {}
}

##
# ###

package provide sak::validate::syntax 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/validate/testsuites.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require  sak::animate
package require  sak::feedback
package require  sak::color

getpackage textutil::repeat textutil/repeat.tcl
getpackage interp interp/interp.tcl

namespace eval ::sak::validate::testsuites {
    namespace import ::textutil::repeat::blank
    namespace import ::sak::color::*
    namespace import ::sak::feedback::!
    namespace import ::sak::feedback::>>
    namespace import ::sak::feedback::+=
    namespace import ::sak::feedback::=
    namespace import ::sak::feedback::=|
    namespace import ::sak::feedback::log
    namespace import ::sak::feedback::summary
    rename summary sum
}

# ###

proc ::sak::validate::testsuites {modules mode stem tclv} {
    testsuites::run $modules $mode $stem $tclv
    testsuites::summary
    return
}

proc ::sak::validate::testsuites::run {modules mode stem tclv} {
    sak::feedback::init $mode $stem
    sak::feedback::first log  "\[ Testsuites \] =================================================="
    sak::feedback::first unc  "\[ Testsuites \] =================================================="
    sak::feedback::first fail "\[ Testsuites \] =================================================="
    sak::feedback::first miss "\[ Testsuites \] =================================================="
    sak::feedback::first none "\[ Testsuites \] =================================================="

    # Preprocessing of module names to allow better formatting of the
    # progress output, i.e. vertically aligned columns

    # Per module we can distinguish the following levels of
    # testsuite completeness:
    # - No package has a testsuite
    # - Some, but not all packages have a testsuite
    # - All packages have a testsuite.
    #
    # Validity of the testsuites is not done here. It requires
    # execution, see 'sak test run ...'.

    # Progress report per module: Packages it is working on.
    # Summary at module level:
    # - Number of packages, number of packages with testsuites,

    # Full log:
    # - Lists packages without testsuites.

    # Global preparation: Pull information about all packages and the
    # modules they belong to.

    Setup
    Count $modules
    MapPackages

    InitCounters
    foreach m $modules {
	# Skip tcllibc shared library, not a module.
	if {[string equal $m tcllibc]} continue

	InitModuleCounters
	!
	log "@@ Module $m"
	Head $m

	# Per module: Find all testsuites in the module and process
	# them. We determine the package(s) they may belong to.

	# Per package: Have they .test files claiming them? After
	# that, are .test files left over (i.e. without a package)?

	ProcessTestsuites $m
	ProcessPackages   $m
	ProcessUnclaimed
	ModuleSummary
    }

    Shutdown
    return
}

proc ::sak::validate::testsuites::summary {} {
    Summary
    return
}

# ###

proc ::sak::validate::testsuites::ProcessTestsuites {m} {
    !claims
    foreach f [glob -nocomplain [file join [At $m] *.test]] {
	ProcessTestsuite $f
    }
    return
}

proc ::sak::validate::testsuites::ProcessTestsuite {f} {
    variable testing
    =file $f

    if {[catch {
	Scan [get_input $f]
    } msg]} {
	+e $msg
    } else {
	foreach p $testing { +claim $p }
    }


    return
}

proc ::sak::validate::testsuites::Setup {} {
    variable ip [interp create]

    # Make it mostly empty (We keep the 'set' command).

    foreach n [interp eval $ip [list ::namespace children ::]] {
	if {[string equal $n ::tcl]} continue
	interp eval $ip [list namespace delete $n]
    }
    foreach c [interp eval $ip [list ::info commands]] {
	if {[string equal $c set]}       continue
	if {[string equal $c if]}        continue
	if {[string equal $c rename]}    continue
	if {[string equal $c namespace]} continue
	interp eval $ip [list ::rename $c {}]
    }

    if {![package vsatisfies [package present Tcl] 8.6]} {
	interp eval $ip [list ::namespace delete ::tcl]
    }
    interp eval $ip [list ::rename namespace {}]
    interp eval $ip [list ::rename rename    {}]

    foreach m {
	testing unknown useLocal useLocalKeep useAccel
    } {
	interp alias $ip $m {} ::sak::validate::testsuites::Process/$m $ip
    }
    return
}

proc ::sak::validate::testsuites::Shutdown {} {
    variable ip
    interp delete $ip
    return
}

proc ::sak::validate::testsuites::Scan {data} {
    variable ip
    while {1} {
	if {[catch {
	    $ip eval $data
	} msg]} {
	    if {[string match {can't read "*": no such variable} $msg]} {
		regexp  {can't read "(.*)": no such variable} $msg -> var
		log "@@ + variable \"$var\""
		$ip eval [list set $var {}]
		continue
	    }
	    return -code error $msg
	}
	break
    }
    return
}

proc ::sak::validate::testsuites::Process/useTcllibC {ip args} {
    return 0
}

proc ::sak::validate::testsuites::Process/unknown {ip args} {
    return 0
}

proc ::sak::validate::testsuites::Process/testing {ip script} {
    variable testing {}
    $ip eval $script
    return -code return
}

proc ::sak::validate::testsuites::Process/useLocal {ip f p args} {
    variable testing
    lappend  testing $p
    return
}

proc ::sak::validate::testsuites::Process/useLocalKeep {ip f p args} {
    variable testing
    lappend  testing $p
    return
}

proc ::sak::validate::testsuites::Process/useAccel {ip _ f p} {
    variable testing
    lappend  testing $p
    return
}

proc ::sak::validate::testsuites::ProcessPackages {m} {
    !used
    if {![HasPackages $m]} return

    foreach p [ThePackages $m] {
	+pkg $p
	if {[claimants $p]} {
	    +tests $p
	} else {
	    notests $p
	}
    }
    return
}

proc ::sak::validate::testsuites::ProcessUnclaimed {} {
    variable claims
    if {![array size claims]} return
    foreach p [lsort -dict [array names claims]] {
	foreach fx $claims($p) { +u $fx }
    }
    return
}

###

proc ::sak::validate::testsuites::=file {f} {
    variable current [file tail $f]
    = "$current ..."
    return
}

###

proc ::sak::validate::testsuites::!claims {} {
    variable    claims
    array unset claims *
    return
}

proc ::sak::validate::testsuites::+claim {pkg} {
    variable current
    variable claims
    lappend  claims($pkg) $current
    return
}

proc ::sak::validate::testsuites::claimants {pkg} {
    variable claims
    expr { [info exists claims($pkg)] && [llength $claims($pkg)] }
}


###

proc ::sak::validate::testsuites::!used {} {
    variable    used
    array unset used *
    return
}

proc ::sak::validate::testsuites::+use {pkg} {
    variable used
    variable claims
    foreach fx $claims($pkg) { set used($fx) . }
    unset claims($pkg)
    return
}

###

proc ::sak::validate::testsuites::MapPackages {} {
    variable    pkg
    array unset pkg *

    !
    += Package
    foreach {pname pdata} [ipackages] {
	= "$pname ..."
	foreach {pver pmodule} $pdata break
	lappend pkg($pmodule) $pname
    }
    !
    =| {Packages mapped ...}
    return
}

proc ::sak::validate::testsuites::HasPackages {m} {
    variable pkg
    expr { [info exists pkg($m)] && [llength $pkg($m)] }
}

proc ::sak::validate::testsuites::ThePackages {m} {
    variable pkg
    return [lsort -dict $pkg($m)]
}

###

proc ::sak::validate::testsuites::+pkg {pkg} {
    variable mtotal ; incr mtotal
    variable total  ; incr total
    return
}

proc ::sak::validate::testsuites::+tests {pkg} {
    variable mhavetests ; incr mhavetests
    variable havetests  ; incr havetests
    = "$pkg Ok"
    +use $pkg
    return
}

proc ::sak::validate::testsuites::notests {pkg} {
    = "$pkg Bad"
    log "@@ WARN  No testsuite: $pkg"
    return
}

###

proc ::sak::validate::testsuites::+e {msg} {
    variable merrors ; incr merrors
    variable errors  ; incr errors
    variable current
    log "@@ ERROR $current $msg"
    return
}

proc ::sak::validate::testsuites::+u {f} {
    variable used
    if {[info exists used($f)]} return
    variable munclaimed ; incr munclaimed
    variable unclaimed  ; incr unclaimed
    set used($f) .
    log "@@ NOTE  Unclaimed testsuite $f"
    return
}

###

proc ::sak::validate::testsuites::Count {modules} {
    variable maxml 0
    !
    foreach m [linsert $modules 0 Module] {
	= "M $m"
	set l [string length $m]
	if {$l > $maxml} {set maxml $l}
    }
    =| "Validate testsuites (existence) ..."
    return
}

proc ::sak::validate::testsuites::Head {m} {
    variable maxml
    += ${m}[blank [expr {$maxml - [string length $m]}]]
    return
}

###

proc ::sak::validate::testsuites::InitModuleCounters {} {
    variable mtotal     0
    variable mhavetests 0
    variable munclaimed 0
    variable merrors    0
    return
}

proc ::sak::validate::testsuites::ModuleSummary {} {
    variable mtotal
    variable mhavetests
    variable munclaimed
    variable merrors

    set complete [F $mhavetests]/[F $mtotal]
    set not      "! [F [expr {$mtotal - $mhavetests}]]"
    set err      "E [F $merrors]"
    set unc      "U [F $munclaimed]"

    if {$munclaimed} {
	set unc [=cya $unc]
	>> unc
    }
    if {!$mhavetests && $mtotal} {
	set complete [=red $complete]
	set not      [=red $not]
	>> none
    } elseif {$mhavetests < $mtotal} {
	set complete [=yel $complete]
	set not      [=yel $not]
	>> miss
    }
    if {$merrors} {
	set err [red]$err[rst]
	>> fail
    }

    =| "~~ $complete $not $unc $err"
    return
}

###

proc ::sak::validate::testsuites::InitCounters {} {
    variable total     0
    variable havetests 0
    variable unclaimed 0
    variable errors    0
    return
}

proc ::sak::validate::testsuites::Summary {} {
    variable total
    variable havetests
    variable unclaimed
    variable errors

    set tot   [F $total]
    set tst   [F $havetests]
    set uts   [F [expr {$total - $havetests}]]
    set unc   [F $unclaimed]
    set per   [format %6.2f [expr {$havetests*100./$total}]]
    set uper  [format %6.2f [expr {($total - $havetests)*100./$total}]]
    set err   [F $errors]

    if {$errors}    { set err [=red $err] }
    if {$unclaimed} { set unc [=cya $unc] }

    if {!$havetests && $total} {
	set tst [=red $tst]
	set uts [=red $uts]
    } elseif {$havetests < $total} {
	set tst [=yel $tst]
	set uts [=yel $uts]
    }

    sum ""
    sum "Testsuite statistics"
    sum "#Packages:     $tot"
    sum "#Tested:       $tst (${per}%)"
    sum "#Untested:     $uts (${uper}%)"
    sum "#Unclaimed:    $unc"
    sum "#Errors:       $err"
    return
}

###

proc ::sak::validate::testsuites::F {n} { format %6d $n }

###

proc ::sak::validate::testsuites::At {m} {
    global distribution
    return [file join $distribution modules $m]
}

# ###

namespace eval ::sak::validate::testsuites {
    # Max length of module names and patchlevel information.
    variable maxml 0

    # Counters across all modules
    variable total     0 ; # Number of packages overall.
    variable havetests 0 ; # Number of packages with testsuites.
    variable unclaimed 0 ; # Number of testsuites not claimed by a specific package.
    variable errors    0 ; # Number of errors found with all testsuites.

    # Same counters, per module.
    variable mtotal     0
    variable mhavetests 0
    variable munclaimed 0
    variable merrors    0

    # Name of currently processed testsuite
    variable current ""

    # Map from packages to files claiming to test them.
    variable  claims
    array set claims {}

    # Set of files taken by packages, as array
    variable  used
    array set used {}

    # Map from modules to packages contained in them
    variable  pkg
    array set pkg {}

    # Transient storage used while collecting packages per testsuite.
    variable testing {}
    variable ip      {}
}

##
# ###

package provide sak::validate::testsuites 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted support/devel/sak/validate/topic.txt.

1
validate	Validate modules and packages
<


Deleted support/devel/sak/validate/validate.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

namespace eval ::sak::validate {}

# ###

proc ::sak::validate::usage {args} {
    package require sak::help
    puts stdout [join $args { }]\n[sak::help::on validate]
    exit 1
}

proc ::sak::validate::all {modules mode stem tclv} {
    package require sak::validate::versions
    package require sak::validate::manpages
    package require sak::validate::testsuites
    package require sak::validate::syntax

    sak::validate::versions::run   $modules $mode $stem $tclv
    sak::validate::manpages::run   $modules $mode $stem $tclv
    sak::validate::testsuites::run $modules $mode $stem $tclv
    sak::validate::syntax::run     $modules $mode $stem $tclv

    sak::validate::versions::summary
    sak::validate::manpages::summary
    sak::validate::testsuites::summary
    sak::validate::syntax::summary
    return
}

##
# ###

package provide sak::validate 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Deleted support/devel/sak/validate/versions.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
# -*- tcl -*-
# (C) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
##
# ###

package require  sak::animate
package require  sak::feedback
package require  sak::color

getpackage textutil::repeat textutil/repeat.tcl
getpackage interp           interp/interp.tcl
getpackage struct::set      struct/sets.tcl
getpackage struct::list     struct/list.tcl

namespace eval ::sak::validate::versions {
    namespace import ::textutil::repeat::blank
    namespace import ::sak::color::*
    namespace import ::sak::feedback::!
    namespace import ::sak::feedback::>>
    namespace import ::sak::feedback::+=
    namespace import ::sak::feedback::=
    namespace import ::sak::feedback::=|
    namespace import ::sak::feedback::log
    namespace import ::sak::feedback::summary
    rename summary sum
}

# ###

proc ::sak::validate::versions {modules mode stem tclv} {
    versions::run $modules $mode $stem $tclv
    versions::summary
    return
}

proc ::sak::validate::versions::run {modules mode stem tclv} {
    sak::feedback::init $mode $stem
    sak::feedback::first log  "\[ Versions \] ===================================================="
    sak::feedback::first warn "\[ Versions \] ===================================================="
    sak::feedback::first fail "\[ Versions \] ===================================================="

    # Preprocessing of module names to allow better formatting of the
    # progress output, i.e. vertically aligned columns

    # Per module
    # - List modules without package index (error)
    # - List packages provided missing from pkgIndex.tcl
    # - List packages in the pkgIndex.tcl, but not provided.
    # - List packages where provided and indexed versions differ.

    Count $modules
    MapPackages

    InitCounters
    foreach m $modules {
	# Skip tcllibc shared library, not a module.
	if {[string equal $m tcllibc]} continue

	InitModuleCounters
	!
	log "@@ Module $m"
	Head $m

	if {![llength [glob -nocomplain [file join [At $m] pkgIndex.tcl]]]} {
	    +e "No package index"
	} else {
	    # Compare package provided to ifneeded.

	    struct::list assign \
		[struct::set intersect3 [Indexed $m] [Provided $m]] \
		compare only_indexed only_provided

	    foreach p [lsort -dict $only_indexed ] { +w "Indexed/No Provider:  $p" }
	    foreach p [lsort -dict $only_provided] { +w "Provided/Not Indexed: $p" }

	    foreach p [lsort -dict $compare] {
		set iv [IndexedVersions  $m $p]
		set pv [ProvidedVersions $m $p]
		if {[struct::set equal $iv $pv]} continue

		struct::list assign \
		    [struct::set intersect3 $pv $iv] \
		    __ pmi imp

		+w "Indexed </> Provided: $p \[<$imp </> $pmi\]"
	    }
	}
	ModuleSummary
    }
    return
}

proc ::sak::validate::versions::summary {} {
    Summary
    return
}

# ###

proc ::sak::validate::versions::MapPackages {} {
    variable    pkg
    array unset pkg *

    !
    += Package
    foreach {pname pdata} [ipackages] {
	= "$pname ..."
	foreach {pvlist pmodule} $pdata break
	lappend pkg(mi,$pmodule) $pname
	lappend pkg(vi,$pmodule,$pname) $pvlist

	foreach {pname pvlist} [ppackages $pmodule] {
	    lappend pkg(mp,$pmodule) $pname
	    lappend pkg(vp,$pmodule,$pname) $pvlist
	}
    }
    !
    =| {Packages mapped ...}
    return
}

proc ::sak::validate::versions::Provided {m} {
    variable pkg
    if {![info exists pkg(mp,$m)]} { return {} }
    return [lsort -dict $pkg(mp,$m)]
}

proc ::sak::validate::versions::Indexed {m} {
    variable pkg
    if {![info exists pkg(mi,$m)]} { return {} }
    return [lsort -dict $pkg(mi,$m)]
}

proc ::sak::validate::versions::ProvidedVersions {m p} {
    variable pkg
    return [lsort -dict $pkg(vp,$m,$p)]
}

proc ::sak::validate::versions::IndexedVersions {m p} {
    variable pkg
    return [lsort -dict $pkg(vi,$m,$p)]
}

###

proc ::sak::validate::versions::+e {msg} {
    variable merrors ; incr merrors
    variable errors  ; incr errors
    log "@@ ERROR $msg"
    return
}

proc ::sak::validate::versions::+w {msg} {
    variable mwarnings ; incr mwarnings
    variable warnings  ; incr warnings
    log "@@ WARN  $msg"
    return
}

proc ::sak::validate::versions::Count {modules} {
    variable maxml 0
    !
    foreach m [linsert $modules 0 Module] {
	= "M $m"
	set l [string length $m]
	if {$l > $maxml} {set maxml $l}
    }
    =| "Validate versions (indexed vs. provided) ..."
    return
}

proc ::sak::validate::versions::Head {m} {
    variable maxml
    += ${m}[blank [expr {$maxml - [string length $m]}]]
    return
}

###

proc ::sak::validate::versions::InitModuleCounters {} {
    variable merrors    0
    variable mwarnings  0
    return
}

proc ::sak::validate::versions::ModuleSummary {} {
    variable merrors
    variable mwarnings

    set err "E [F $merrors]"
    set wrn "W [F $mwarnings]"

    if {$mwarnings} { set wrn [=yel $wrn] ; >> warn }
    if {$merrors}   { set err [=red $err] ; >> fail }

    =| "~~ $err $wrn"
    return
}

###

proc ::sak::validate::versions::InitCounters {} {
    variable errors    0
    variable warnings  0
    return
}

proc ::sak::validate::versions::Summary {} {
    variable errors
    variable warnings

    set err   [F $errors]
    set wrn   [F $warnings]

    if {$errors}    { set err [=red $err] }
    if {$warnings}  { set wrn [=yel $wrn] }

    sum ""
    sum "Versions statistics"
    sum "#Errors:       $err"
    sum "#Warnings:     $wrn"
    return
}

###

proc ::sak::validate::versions::F {n} { format %6d $n }

###

proc ::sak::validate::versions::At {m} {
    global distribution
    return [file join $distribution modules $m]
}

# ###

namespace eval ::sak::validate::versions {
    # Max length of module names and patchlevel information.
    variable maxml 0

    # Counters across all modules
    variable errors    0 ; # Number of errors found (= modules without pkg index)
    variable warnings  0 ; # Number of warings

    # Same counters, per module.
    variable merrors    0
    variable mwarnings  0

    # Map from modules to packages and their versions.
    variable  pkg
    array set pkg {}
}

##
# ###

package provide sak::validate::versions 1.0
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































































































































































































































































































































Deleted support/installation/actions.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 -*-

# This file holds the commands determining the files to install. They
# are used by the installer to actually perform the installation, and
# by 'sak' to get the per-module lists of relevant files. The
# different purposes are handled through the redefinition of the
# commands [xcopy] and [xcopyf] used by the commands here.

proc _null {args} {}

proc _tao {module libdir} {
    global distribution
    
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    1 *
    return
}


proc _tcl {module libdir} {
    global distribution
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    0 *.tcl
    return
}

proc _tclm {module libdir} {
    global distribution
    _tcl $module $libdir
    xcopy \
	[file join $distribution modules $module] \
	[file join $libdir $module] \
	0 *.msg
    return
}

proc _tcr {module libdir} {
    global distribution
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    1 *.tcl
    return
}

proc _tab {module libdir} {
    global distribution

    _tcl $module $libdir

    xcopy \
	    [file join $distribution modules $module scripts] \
	    [file join $libdir $module scripts] \
	    0 *.tcl

    xcopyfile \
	[file join $distribution modules $module scripts tclIndex] \
	[file join $libdir $module scripts]

    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 _ctxt {module libdir} {
    global distribution
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    0 ctext.tcl
    xcopy \
	    [file join $distribution modules $module] \
	    [file join $libdir $module] \
	    0 pkgIndex.tcl
    return
}

proc _msg {module libdir} {
    global distribution

    _tcl $module $libdir
    xcopy \
	    [file join $distribution modules $module msgs] \
	    [file join $libdir $module msgs] \
	    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
    xcopyfile [file join $distribution modules $module tclIndex] \
	    [file join $libdir $module]
    return
}


proc _manfile {f format ext docdir} { return }
proc _man {module format ext docdir} { return }

proc _exa {module exadir} {
    global distribution
    xcopy \
	    [file join $distribution examples $module] \
	    [file join $exadir $module] \
	    1
    return
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































Deleted support/installation/main.tcl.

1
2
3
4
5
# -*- tcl -*-
# Entrypoint for starkit and -pack based distributions

# Delegate to the installer application
source [file join [file dirname [info script]] installer.tcl]
<
<
<
<
<










Deleted support/installation/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 2009/02/07 05:18:22 andreas_kupries Exp $
'\"
'\"	# Set up traps and other miscellaneous stuff for Tcl/Tk man pages.
.if t .wh -1.3i ^B
.nr ^l \n(.l
.ad b
'\"	# Start an argument description
.de AP
.ie !"\\$4"" .TP \\$4
.el \{\
.   ie !"\\$2"" .TP \\n()Cu
.   el          .TP 15
.\}
.ta \\n()Au \\n()Bu
.ie !"\\$3"" \{\
\&\\$1	\\fI\\$2\\fP	(\\$3)
.\".b
.\}
.el \{\
.br
.ie !"\\$2"" \{\
\&\\$1	\\fI\\$2\\fP
.\}
.el \{\
\&\\fI\\$1\\fP
.\}
.\}
..
'\"	# define tabbing values for .AP
.de AS
.nr )A 10n
.if !"\\$1"" .nr )A \\w'\\$1'u+3n
.nr )B \\n()Au+15n
.\"
.if !"\\$2"" .nr )B \\w'\\$2'u+\\n()Au+3n
.nr )C \\n()Bu+\\w'(in/out)'u+2n
..
.AS Tcl_Interp Tcl_CreateInterp in/out
'\"	# BS - start boxed text
'\"	# ^y = starting y location
'\"	# ^b = 1
.de BS
.br
.mk ^y
.nr ^b 1u
.if n .nf
.if n .ti 0
.if n \l'\\n(.lu\(ul'
.if n .fi
..
'\"	# BE - end boxed text (draw box now)
.de BE
.nf
.ti 0
.mk ^t
.ie n \l'\\n(^lu\(ul'
.el \{\
.\"	Draw four-sided box normally, but don't draw top of
.\"	box if the box started on an earlier page.
.ie !\\n(^b-1 \{\
\h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.el \}\
\h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\l'|0u-1.5n\(ul'
.\}
.\}
.fi
.br
.nr ^b 0
..
'\"	# VS - start vertical sidebar
'\"	# ^Y = starting y location
'\"	# ^v = 1 (for troff;  for nroff this doesn't matter)
.de VS
.if !"\\$2"" .br
.mk ^Y
.ie n 'mc \s12\(br\s0
.el .nr ^v 1u
..
'\"	# VE - end of vertical sidebar
.de VE
.ie n 'mc
.el \{\
.ev 2
.nf
.ti 0
.mk ^t
\h'|\\n(^lu+3n'\L'|\\n(^Yu-1v\(bv'\v'\\n(^tu+1v-\\n(^Yu'\h'-|\\n(^lu+3n'
.sp -1
.fi
.ev
.\}
.nr ^v 0
..
'\"	# Special macro to handle page bottom:  finish off current
'\"	# box/sidebar if in box/sidebar mode, then invoked standard
'\"	# page bottom macro.
.de ^B
.ev 2
'ti 0
'nf
.mk ^t
.if \\n(^b \{\
.\"	Draw three-sided box if this is the box's first page,
.\"	draw two sides but no top otherwise.
.ie !\\n(^b-1 \h'-1.5n'\L'|\\n(^yu-1v'\l'\\n(^lu+3n\(ul'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.el \h'-1.5n'\L'|\\n(^yu-1v'\h'\\n(^lu+3n'\L'\\n(^tu+1v-\\n(^yu'\h'|0u'\c
.\}
.if \\n(^v \{\
.nr ^x \\n(^tu+1v-\\n(^Yu
\kx\h'-\\nxu'\h'|\\n(^lu+3n'\ky\L'-\\n(^xu'\v'\\n(^xu'\h'|0u'\c
.\}
.bp
'fi
.ev
.if \\n(^b \{\
.mk ^y
.nr ^b 2
.\}
.if \\n(^v \{\
.mk ^Y
.\}
..
'\"	# DS - begin display
.de DS
.RS
.nf
.sp
..
'\"	# DE - end display
.de DE
.fi
.RE
.sp
..
'\"	# SO - start of list of standard options
.de SO
.SH "STANDARD OPTIONS"
.LP
.nf
.ta 4c 8c 12c
.ft B
..
'\"	# SE - end of list of standard options
.de SE
.fi
.ft R
.LP
See the \\fBoptions\\fR manual entry for details on the standard options.
..
'\"	# OP - start of full description for a single option
.de OP
.LP
.nf
.ta 4c
Command-Line Name:	\\fB\\$1\\fR
Database Name:	\\fB\\$2\\fR
Database Class:	\\fB\\$3\\fR
.fi
.IP
..
'\"	# CS - begin code excerpt
.de CS
.RS
.nf
.ta .25i .5i .75i 1i
..
'\"	# CE - end code excerpt
.de CE
.fi
.RE
..
.de UL
\\$1\l'|0\(ul'\\$2
..
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































Deleted support/installation/modules.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
# -*- tcl -*-
# --------------------------------------------------------------
# List of modules to install and definitions guiding the process of
# doing so.
#
# This file is shared between 'installer.tcl' and 'sak.tcl', like
# 'package_version.tcl'. The swiss army knife requires access to the
# data in this file to be able to check if there are modules in the
# directory hierarchy, but missing in the list of installed modules.
# --------------------------------------------------------------

proc Exclude     {m} {global excluded ; lappend excluded $m ; return }
proc Application {a} {global apps     ; lappend apps     $a ; return }

proc Module  {m pkg doc exa} {
    global modules guide

    lappend   modules $m
    set guide($m,pkg) $pkg
    set guide($m,doc) $doc
    set guide($m,exa) $exa
    return
}

set excluded [list]
set modules  [list]
set apps     [list]
array set guide {}

# --------------------------------------------------------------
# @@ Registration START

set here [file dirname [file normalize [info script]]]
foreach path [glob $here/../../modules/*] {
  if {![file isdirectory $path]} continue
  if {[glob -nocomplain $path/*.tcl] eq {}} continue
  Module [file tail $path]	     _tao  _null _null
} 
#      name           pkg   doc   example
#Module taotk	     _tcl  _null _null
#Module tao-sqlite    _tcl  _null _null
#Application  diagram-viewer
#Application  bitmap-editor

# @@ Registration END
# --------------------------------------------------------------
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































Deleted support/installation/version.tcl.

1
2
package_version 3.2.0
package_name    taolib
<
<




Deleted support/releases/PACKAGES.

1
2
3
4
5
6
7
8
9
10
11
@@ RELEASE 9.2.1

$bundle                     $bundlev
$pkg                        $ver
tao			    9.2.1
tao-httpd 		    10.0
taotk 			    0.2
tao-physics 		    0.1
tao-sqlite                  0.2
tool-ui 		            0.1

<
<
<
<
<
<
<
<
<
<
<






















Deleted support/releases/package_rpm.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
# $Id: package_rpm.txt,v 1.1 2009/02/07 05:18:22 andreas_kupries Exp $

%define version @PACKAGE_VERSION@
%define directory /usr

Summary: The standard Tk library
Name: @PACKAGE_NAME@
Version: %{version}
Release: 2
Copyright: BSD
Group: Development/Languages
Source: %{name}-%{version}.tar.bz2
URL: http://fossil.etoyoc.com/fossil/taolib
Packager: Sean Woods <yoda@etoyoc.com>
BuildArchitectures: noarch
Prefix: /usr
Requires: tcl >= 8.6.0
BuildRequires: tcl >= 8.6.0
Buildroot: /var/tmp/%{name}-%{version}

%description
Taolib is an object oriented suite of tools, built around 
the new TclOO core for Tcl 8.6.
The home web site for this code is http://fossil.etoyoc.com/fossil/taolib
At this web site, you will find mailing lists, web forums, databases
for bug reports and feature requests, the fossil-scm repository,
and more.
Note: also grab source tarball for more documentation, examples, ...

%prep

%setup -q

%install
# compensate for missing manual files:
/usr/bin/tclsh installer.tcl -no-gui -no-wait -no-html -no-examples\
    -pkg-path $RPM_BUILD_ROOT/usr/lib/%{name}-%{version}\
    -nroff-path $RPM_BUILD_ROOT/usr/share/man/mann/
# install HTML documentation to specific modules sub-directories:
# generate list of files in the package (man pages are compressed):
find $RPM_BUILD_ROOT ! -type d |\
    sed -e "s,^$RPM_BUILD_ROOT,,;" -e 's,\.n$,\.n\.gz,;' >\
    %{_builddir}/%{name}-%{version}/files

%clean
rm -rf $RPM_BUILD_ROOT

%files -f %{_builddir}/%{name}-%{version}/files
%defattr(-,root,root)
%doc README ChangeLog license.terms
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































Deleted support/releases/package_tip55.txt.

1
2
3
4
5
6
7
8
9
Identifier: @PACKAGE_NAME@
Title:  Tao Standard Library
Description: This package is intended to be a collection of
    Tcl packages that provide utility functions useful to a
    large collection of TclOO programmers.
Rights: BSD
Version: @PACKAGE_VERSION@
URL: http://fossil.etoyoc.com/fossil/taolib
Architecture: tcl
<
<
<
<
<
<
<
<
<


















Deleted support/releases/package_yml.txt.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
dist_id: taolib
version: @PACKAGE_VERSION@
language: tcl
description: |
   This package is intended to be a collection of Tcl packages that provide
   utility functions useful to a large collection of Tk programmers.

   The home web site for this code is http://fossil.etoyoc.com/fossil/taolib/.
   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.

categories: 
  - Library/Utility
  - Library/GUI
license: BSD
owner_id: AndreasKupries
wrapped_content: @PACKAGE_NAME@-@PACKAGE_VERSION@/
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<