Check-in [6cefd7948e]

Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Sep 9.

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

Overview
Comment:Stash work, review what was done, to remember
Timelines: family | ancestors | v2x-stash
Files: files | file ages | folders
SHA1:6cefd7948ea5b420a455b890ed05b8a3bcd48714
User & Date: aku 2016-06-29 16:13:37
Context
2016-06-29
16:13
Stash work, review what was done, to remember Leaf check-in: 6cefd7948e user: aku tags: v2x-stash
2014-02-07
22:37
Match cmdr fixes for "_find". Leaf check-in: 1ecd270a63 user: andreask tags: v2x
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to TODO.txt.

1
2
3
4
5
6
7
8
9

[..] (.)
	Cmdr - Help - Tcl format (like json, less syntax, directly parse-able).
	Cmdr - help::query-actor => 'actor find' virtual-method
				 or 'actor lookup*'

	Cmdr - Triggers for defered conditional creation
	       (configuration!) of officers when 'extend'ing the tree,
	       to have proper description and such.

|







1
2
3
4
5
6
7
8
9

[OK] (.)
	Cmdr - Help - Tcl format (like json, less syntax, directly parse-able).
	Cmdr - help::query-actor => 'actor find' virtual-method
				 or 'actor lookup*'

	Cmdr - Triggers for defered conditional creation
	       (configuration!) of officers when 'extend'ing the tree,
	       to have proper description and such.

Changes to doc.tcl.

49
50
51
52
53
54
55

56
57
58

59
60
61
62
63
64
65
66

67

68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160







































161
162
163
164

165









166





167
168
169
170
171
172
173
174
175
176
177
...
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
    return
}

proc ::kettle::doc {{docsrcdir doc}} {
    # Overwrite self, we run only once for effect.
    proc ::kettle::doc args {}


    # Heuristic search for figures
    figures $docsrcdir/figures


    # Heuristic search for documentation files.
    # Aborts caller when nothing is found.
    lassign [path scan \
		 tcllib/doctools \
		 $docsrcdir \
		 {path doctools-file}] \
	root manpages


    # Put the documentation into recipes.


    set dd      [path sourcedir [option get --with-doc-destination]]
    set mansrc  $dd/man/files
    set htmlsrc $dd/www

    set mandst  [path mandir  mann]
    set htmldst [path htmldir [file tail [path sourcedir]]]

    set isfossil [expr {[path find.fossil [path sourcedir]] ne {}}]

    recipe define doc {
	(Re)generate the documentation embedded in the repository.
    } {root dst isfossil} {
	if {[option get @dtplite] eq "external"} {
	    # Validate tool presence before actually doing anything
	    tool get dtplite
	}
	DtpliteDo $root $dst $isfossil
    } $root $dd $isfossil

    recipe define {validate doc} {
	Validate the documentation.
    } {root} {
	io puts "Validate documentation"
	path exec dtplite validate .
    } $root

    recipe define install-doc-manpages {
	Install manpages
    } {src dst} {
	path in $src {
	    path install-file-set \
		"manpages" \
		$dst {*}[glob -tails -directory $src *.n]
	}
	return
    } $mansrc $mandst

    recipe define install-doc-html {
	Install HTML documentation
    } {src dst} {
	path in $src {
	    path install-file-group \
		"HTML documentation" \
		$dst {*}[glob -tails -directory $src *]
	}
	return
    } $htmlsrc $htmldst

    recipe define uninstall-doc-manpages {
	Uninstall manpages
    } {src dst} {
	path uninstall-file-set \
	    "manpages" \
	    $dst {*}[glob -directory $src -tails *.n]
	return
    } $mansrc $mandst

    recipe define uninstall-doc-html {
	Uninstall HTML documentation
    } {dst} {
	path uninstall-file-group \
	    "HTML documentation" \
	    $dst
    } $htmldst

    recipe define reinstall-doc-manpages {
	Reinstall manpages
    } {} {
	invoke self uninstall-doc-manpages
	invoke self install-doc-manpages
    }

    recipe define reinstall-doc-html {
	Reinstall HTML documentation
    } {} {
	invoke self uninstall-doc-html
	invoke self install-doc-html
    }

    recipe parent install-doc-html     install-doc
    recipe parent install-doc-manpages install-doc
    recipe parent install-doc          install

    recipe parent uninstall-doc-html     uninstall-doc
    recipe parent uninstall-doc-manpages uninstall-doc
    recipe parent uninstall-doc          uninstall

    recipe parent reinstall-doc-html     reinstall-doc
    recipe parent reinstall-doc-manpages reinstall-doc
    recipe parent reinstall-doc          reinstall

    #recipe parent validate-doc validate







































    return
}

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











proc ::kettle::DtpliteDo {root dst isfossil} {





    io trace {  do fossil=$isfossil}

    path in $root {

	io puts "Removing old documentation..."
	file delete -force $dst

	file mkdir $dst/man
	file mkdir $dst/www

	io puts "Generating man pages..."
................................................................................
	io puts "\nGenerating HTML... Pass 2, resolving cross-references..."
	DtpliteRun {*}$cmd

	# Remove some of the generated files, consider them transient.
	cd  $dst/man ; file delete -force .idxdoc .tocdoc
	cd  ../www   ; file delete -force .idxdoc .tocdoc
    }

}


















































































































proc ::kettle::DtpliteRun {args} {
    io trace { dtplite [path::T $args]}
    if {[option get --dry]} return

    io puts {}
    if {[option get @dtplite] eq "internal"} {
	io trace {  dtplite: internal}
	io trace {[package ifneeded dtplite [package present dtplite]]}


	dtplite::do $args
    } else {
	io trace {  dtplite: external}
	path exec {*}[tool get dtplite] {*}$args
    }
    return
}

# # ## ### ##### ######## ############# #####################
## Handle a github gh-pages branch.

proc ::kettle::gh-pages {} {
    # Overwrite self, we run only once for effect.
    proc ::kettle::gh-pages args {}

    doc

    io trace {Testing for gh-pages}

    # No need to handle a gh-pages documentation branch if there is no
    # documentation to work with.
    if {![recipe exists doc]} {
	io trace {  No gh-pages: No documentation}
	return
    }

    # Ditto if this is not a git-based project.
    if {[path find.git [path sourcedir]] eq {}} {
	io trace {  No gh-pages: Not git based}
	return
    }
 
    # Now we check if the branch we need is present. Note that if we
    # can't find the tool, i.e. "git", we assume that the branch is
    # present and let the recipe error out on the missing tool.

    if {![catch {
	path grep *gh-pages* [exec {*}[tool get git] branch -a]
    } res] && ![llength $res]} {
	io trace {  No gh-pages: branch not present}
	return
    }

    recipe define gh-pages {
	Install embedded documentation into a gh-pages
	branch of the local git repository.
    } {} {
	# Validate tool presence before actually doing anything
	tool get git

	# PWD is the local git checkout.

	# Determine git revision information, informational use only
	set commit  [exec {*}[tool get git] log -1 --pretty=format:%H]
	try {
	    set version [exec {*}[tool get git] describe]
	} on error {} {
	    set version unknown
	}
	regsub -- {^.*/} [string trim [path cat .git/HEAD]] {} branch

	io puts "\n  Commit:      $commit"
	io puts "  Branch:      $branch"
	io puts "  Version:     $version"

	set tmpdir [path tmpdir]/[path tmpfile ghp_]
	file mkdir $tmpdir
	path ensure-cleanup $tmpdir

	# Save the documentation outside of checkout ... ... ...
	set docs [option get --with-doc-destination]/www
	io puts "  Doc Origin:  $docs"
	io puts "  Saving to:   $tmpdir"
	file copy -force $docs $tmpdir/doc

	# Switch to gh-pages branch, i.e. the github website
	io puts {Switching to gh-pages...}


	path exec {*}[tool get git] checkout gh-pages

	# Place the saved documentation
	io puts {Updating documentation...}
	file delete -force doc
	file copy -force $tmpdir/doc doc
	file delete -force $tmpdir

	# Assumming doctools-originated files, remove various
	# irrelevant files.
	file delete doc/.idx doc/.toc doc/.xrf

	## Reminder ... ... ...
	io puts ""
	io puts "You are now in branch"
	io puts \t[io mred gh-pages]
	io puts "coming from commit"
	io puts \t[io mok $commit]
	io puts ""
	io puts "[io mnote Verify] the changes now,"
	io puts "then [io mnote {commit and push}] them,"
	io puts "and lastly [io mnote {switch back}] to where you were via"
	io puts \t[io mnote "git checkout $branch"]
	io puts ""
	return
    }

    return
}

# # ## ### ##### ######## ############# #####################
return







>



>

|






>

>










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




>

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



<







 







>


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








>
|
<
|
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
|
<
|
<
<
<
|
<
<
<
<
<
<
<
<
>
>
|
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|

<
<
<


49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
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
...
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
    return
}

proc ::kettle::doc {{docsrcdir doc}} {
    # Overwrite self, we run only once for effect.
    proc ::kettle::doc args {}

    # - - -- --- ----- -------- -------------
    # Heuristic search for figures
    figures $docsrcdir/figures

    # - - -- --- ----- -------- -------------
    # Heuristic search for documentation files.
    # Aborts caller when nothing is found, preventing recipe definition.
    lassign [path scan \
		 tcllib/doctools \
		 $docsrcdir \
		 {path doctools-file}] \
	root manpages

    # - - -- --- ----- -------- -------------
    # Put the documentation into recipes.
    # Determine the various paths needed by the backend commands.

    set dd      [path sourcedir [option get --with-doc-destination]]
    set mansrc  $dd/man/files
    set htmlsrc $dd/www

    set mandst  [path mandir  mann]
    set htmldst [path htmldir [file tail [path sourcedir]]]

    set isfossil [expr {[path find.fossil [path sourcedir]] ne {}}]

    # - - -- --- ----- -------- -------------
    # Generate documentation

    recipe defx {doc regenerate} {
	(Re)generate the documentation embedded in the repository.
    } [list ::kettle::doc::Regenerate $root $dd $isfossil]

    # - - -- --- ----- -------- -------------
    # Validate documentation (multiple paths to the same functionality).

    recipe defx {validate doc} {
	Validate the documentation.
    } [list ::kettle::doc::Validate $root]

    recipe defx {doc validate} {
	Validate the documentation.
    } [list ::kettle::doc::Validate $root]

    # - - -- --- ----- -------- -------------
    # Installation (multiple paths to the same functionality).

    recipe defx {install doc manpages} {
	Install the manpages.
    } [list ::kettle::doc::InstallManpages $mansrc $mandst]

    recipe defx {doc install manpages} {
	Install the manpages.
    } [list ::kettle::doc::InstallManpages $mansrc $mandst]

    recipe defx {install doc html} {
	Install the HTML documentation.
    } [list ::kettle::doc::InstallHTML $htmlsrc $htmldst]

    recipe defx {doc install html} {
	Install the HTML documentation.
    } [list ::kettle::doc::InstallHTML $htmlsrc $htmldst]


    # - - -- --- ----- -------- -------------
    # Uninstallation (multiple paths to the same functionality).

    recipe defx {uninstall doc manpages} {
	Uninstall manpages
    }  [list ::kettle::doc::UninstallManpages $mansrc $mandst]

    recipe defx {doc uninstall manpages} {
	Uninstall manpages
    }  [list ::kettle::doc::UninstallManpages $mansrc $mandst]

    recipe defx {uninstall doc html} {
	Uninstall HTML documentation
    }  [list ::kettle::doc::UninstallHTML $htmldst]

    recipe defx {doc uninstall html} {
	Uninstall HTML documentation
    }  [list ::kettle::doc::UninstallHTML $htmldst]

    # - - -- --- ----- -------- -------------
    # Reinstallation (multiple paths to the same functionality).

    recipe defx {reinstall doc manpages} {
	Reinstall manpages
    } ::kettle::doc::ReinstallManpages

    recipe defx {doc reinstall manpages} {
	Reinstall manpages
    } ::kettle::doc::ReinstallManpages

    recipe defx {reinstall doc html} {
	Reinstall HTML documentation
    } ::kettle::doc::ReinstallHTML

    recipe defx {doc reinstall html} {
	Reinstall HTML documentation
    } ::kettle::doc::ReinstallHTML

    return
}

# # ## ### ##### ######## ############# #####################
## Handle a github gh-pages branch.

proc ::kettle::gh-pages {} {
    # Overwrite self, we run only once for effect.
    proc ::kettle::gh-pages args {}

    doc

    # - - -- --- ----- -------- -------------
    io trace {Testing for gh-pages}

    # No need to handle a gh-pages documentation branch if there is no
    # documentation to work with.
    if {![recipe exists doc]} {
	io trace {  No gh-pages: No documentation}
	return
    }

    # Ditto if this is not a git-based project.
    if {[path find.git [path sourcedir]] eq {}} {
	io trace {  No gh-pages: Not git based}
	return
    }
 
    # Now we check if the branch we need is present. Note that if we
    # can't find the tool, i.e. "git", we assume that the branch is
    # present and let the recipe error out on the missing tool.

    if {![catch {
	path grep *gh-pages* [exec {*}[tool get git] branch -a]
    } res] && ![llength $res]} {
	io trace {  No gh-pages: branch not present}
	return
    }

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

    recipe define {doc gh-pages} {
	Install embedded documentation into a "gh-pages"
	branch of the local git repository.
    } ::kettle::doc::GithubPages

    return
}

# # ## ### ##### ######## ############# #####################
## Recipe Callbacks

namespace eval ::kettle::doc {
    # No ensemble!
    namespace import ::kettle::tool
    namespace import ::kettle::option
    namespace import ::kettle::path
    namespace import ::kettle::io
    namespace import ::kettle::invoke
}

proc ::kettle::doc::Regenerate {root dst isfossil} {
    if {[option get @dtplite] eq "external"} {
	# Validate tool presence before actually doing anything
	tool get dtplite
    }

    io trace {  do fossil=$isfossil}

    path in $root {

	io puts "Removing old documentation..."
	file delete -force $dst

	file mkdir $dst/man
	file mkdir $dst/www

	io puts "Generating man pages..."
................................................................................
	io puts "\nGenerating HTML... Pass 2, resolving cross-references..."
	DtpliteRun {*}$cmd

	# Remove some of the generated files, consider them transient.
	cd  $dst/man ; file delete -force .idxdoc .tocdoc
	cd  ../www   ; file delete -force .idxdoc .tocdoc
    }
    return
}

proc ::kettle::doc::Validate {root} {
    io puts "Validate documentation"
    path in $root {
	DtpliteRun validate .
    }
    return
}

proc ::kettle::doc::InstallManpages {src dst} {
    path in $src {
	path install-file-set \
	    "manpages" \
	    $dst {*}[glob -tails -directory $src *.n]
    }
    return
}

proc ::kettle::doc::InstallHTML {src dst} {
    path in $src {
	path install-file-group \
	    "HTML documentation" \
	    $dst {*}[glob -tails -directory $src *]
    }
    return
}

proc ::kettle::doc::UninstallManpages {src dst} {
    path uninstall-file-set \
	"manpages" \
	$dst {*}[glob -directory $src -tails *.n]
    return
}

proc ::kettle::doc::UninstallHTML {dst} {
    path uninstall-file-group \
	"HTML documentation" \
	$dst
    return
}

proc ::kettle::doc::ReinstallManpages {} {
    invoke self  doc uninstall manpages
    invoke self  doc install   manpages
    return
}

proc ::kettle::doc::ReinstallHTML {} {
    invoke self  doc uninstall html
    invoke self  doc install   html
    return
}

proc ::kettle::doc::GithubPages {} {
    # Validate tool presence before actually doing anything
    tool get git

    # PWD is the local git checkout.

    # Determine git revision information, informational use only
    set commit  [exec {*}[tool get git] log -1 --pretty=format:%H]
    try {
	set version [exec {*}[tool get git] describe]
    } on error {} {
	set version unknown
    }
    regsub -- {^.*/} [string trim [path cat .git/HEAD]] {} branch

    io puts "\n  Commit:      $commit"
    io puts "  Branch:      $branch"
    io puts "  Version:     $version"

    set tmpdir [path tmpdir]/[path tmpfile ghp_]
    file mkdir $tmpdir
    path ensure-cleanup $tmpdir

    # Save the documentation outside of checkout ... ... ...
    set docs [option get --with-doc-destination]/www
    io puts "  Doc Origin:  $docs"
    io puts "  Saving to:   $tmpdir"
    file copy -force $docs $tmpdir/doc

    # Switch to gh-pages branch, i.e. the github website
    io puts {Switching to gh-pages...}
    path exec {*}[tool get git] checkout gh-pages

    # Place the saved documentation
    io puts {Updating documentation...}
    file delete -force doc
    file copy -force $tmpdir/doc doc
    file delete -force $tmpdir

    # Assumming doctools-originated files, remove various
    # irrelevant files.
    file delete doc/.idx doc/.toc doc/.xrf

    ## Reminder ... ... ...
    io puts ""
    io puts "You are now in branch"
    io puts \t[io mred gh-pages]
    io puts "coming from commit"
    io puts \t[io mok $commit]
    io puts ""
    io puts "[io mnote Verify] the changes now,"
    io puts "then [io mnote {commit and push}] them,"
    io puts "and lastly [io mnote {switch back}] to where you were via"
    io puts \t[io mnote "git checkout $branch"]
    io puts ""
    return
}

# # ## ### ##### ######## ############# #####################
## Internal Support

proc ::kettle::doc::DtpliteRun {args} {
    io trace { dtplite [path::T $args]}
    if {[option get --dry]} return

    io puts {}
    if {[option get @dtplite] eq "internal"} {
	io trace {  dtplite: internal}
	io trace {[package ifneeded dtplite [package present dtplite]]}

	try {
	    dtplite::do $args

	} trap STOP             {e o} - \
	  trap {DTPLITE STOP}   {e o} - \
	  trap {DOCTOOLS INPUT} {e o} {



















































	    io err {





		io puts $e

	    }



	}








    } else {
	io trace {  dtplite: external}
	path exec {*}[tool get dtplite] {*}$args
    }






















    return
}




# # ## ### ##### ######## ############# #####################
return

Added doc/include/configuration.inc.























>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
[comment {--- Project configuration --}]
[vset AUTHOR {Andreas Kupries}]
[vset COPYRIGHT 2013-2014]
[vset LICENSE bsd]
[vset MAN_SECTION n]
[vset MODULE_DESC {Kettle - The Quick Brew System}]
[vset PROJECT kettle]
[vset PTITLE Kettle]
[vset REPOSITORY https:/core.tcl.tk/akupries/kettle]
[vset VC_TYPE fossil]
[vset VERSION 1.0]

Added doc/include/definitions.inc.



>
1
[include configuration.inc]

Changes to doc/include/feedback.inc.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
[comment {-*- tcl -*- --- !doctools --- manpage}]
[comment {- - -- --- ----- -------- ------------- ---------------------}]
[section {Bugs, Ideas, Feedback}]
[vset R https://chiselapp.com/user/andreas_kupries/repository/Kettle/index]

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

Please report such at the
[uri [vset R] {Kettle Tracker}].

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




<





|




1
2
3

4
5
6
7
8
9
10
11
12
13
[comment {-*- tcl -*- --- !doctools --- manpage}]
[comment {- - -- --- ----- -------- ------------- ---------------------}]
[section {Bugs, Ideas, Feedback}]


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

Please report such at the
[uri [vset REPOSITORY] "[vset PTITLE] Tracker"].

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

Changes to doc/include/general.inc.

1
2
3

4
5
6
[comment {-*- tcl -*- --- !doctools --- manpage}]
[comment {- - -- --- ----- -------- ------------- ---------------------}]
[moddesc   {Kettle - The Quick Brew System}]

[category  {Build support}]
[keywords  {build tea}]
[require Tcl 8.5]


|
>



1
2
3
4
5
6
7
[comment {-*- tcl -*- --- !doctools --- manpage}]
[comment {- - -- --- ----- -------- ------------- ---------------------}]
[include definitions.inc]
[moddesc   [vset MODULE_DESC]]
[category  {Build support}]
[keywords  {build tea}]
[require Tcl 8.5]

Changes to recipes.tcl.

31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46







47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
..
66
67
68
69
70
71
72















































73
74
75
76
77
78
79
..
82
83
84
85
86
87
88
89
90
91
92
93
94
95

96
97
98
99
100
101
102
...
190
191
192
193
194
195
196
197
198
199

200
201
202
203
204
205
206
207
208
209
    namespace import ::kettle::io
    namespace import ::kettle::status
}

# # ## ### ##### ######## ############# #####################
## Management API commands.

proc ::kettle::recipe::anchor {name description} {

    kettle cli defered $name [subst -nocommands -nobackslashes {
	description {}
	private all {
	    section Targets Project
	    description {$description}
	} ::kettle::recipe::RunSiblings
	default all
    }]







}

proc ::kettle::recipe::RunSiblings {config} {
    # Determine the sibling commands, and run them.

    set super [$config context super]
    set self  [$super default]

    foreach sibling [lsort -dict [$super known]] {
	# Ignore ourselves and the autuo-generated commands.
	if {$sibling eq $self} continue
	if {$sibling in {exit help}} continue

	# Alternate: Exclude privates which do not have the recipe
	# action callback.

	# Run the sibling.
................................................................................
	# - Or a variant of do taking the config to use.
	# - This becomes critical when construction reaches option handling.

	[$super lookup $sibling] do
    }
    return
}
















































proc ::kettle::recipe::define {name description arguments script args} {
    variable recipe

    # Note! The scripts are evaluated in the context of namespace
    # ::kettle. This provide access to various internal commands
    # without making them visible to the user/DSL.
................................................................................
    io trace {DEF $name}

    Init $name $description

    dict update recipe $name def {
	dict lappend def script \
	    [lambda@ ::kettle $arguments $script {*}$args]

	#dict lappend def help $description
    }
    return
}

proc ::kettle::recipe::parent {name parent} {

    variable recipe

    Init $name
    Init $parent
    dict update recipe $name def {
	dict lappend def parent $parent
    }
................................................................................
    if {[dict exists $recipe $name]} return
    dict set recipe $name {
	script {}
	help   {}
	parent {}
    }

    set cmd [kettle cli extend $name {
	section Targets Project
	# parameters -> only options, define dynamically

    } [list ::kettle::recipe::RunIt $name]]

    $cmd description: $description

    # Remember reference to handler for future modifications.
    dict set recipe $name handler $cmd
    return
}

proc ::kettle::recipe::RunIt {name config} {







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









|







 







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







 







<
<





>







 







|


>
|
<
<







31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
...
137
138
139
140
141
142
143


144
145
146
147
148
149
150
151
152
153
154
155
156
...
244
245
246
247
248
249
250
251
252
253
254
255


256
257
258
259
260
261
262
    namespace import ::kettle::io
    namespace import ::kettle::status
}

# # ## ### ##### ######## ############# #####################
## Management API commands.

proc ::kettle::recipe::anchor {path description {mode all}} {
    if {$mode eq "all"} {
	set spec  [subst -nocommands -nobackslashes {
	    description {}
	    private all {
		section Targets Project
		description {$description}
	    } ::kettle::recipe::RunSiblings
	    default all
	}]
    } else {
	set spec [subst -nocommands -nobackslashes {
	    description {$description}
	}]
    }
    kettle cli phantom $path $spec
    return
}

proc ::kettle::recipe::RunSiblings {config} {
    # Determine the sibling commands, and run them.

    set super [$config context super]
    set self  [$super default]

    foreach sibling [lsort -dict [$super known]] {
	# Ignore ourselves and the auto-generated commands.
	if {$sibling eq $self} continue
	if {$sibling in {exit help}} continue

	# Alternate: Exclude privates which do not have the recipe
	# action callback.

	# Run the sibling.
................................................................................
	# - Or a variant of do taking the config to use.
	# - This becomes critical when construction reaches option handling.

	[$super lookup $sibling] do
    }
    return
}

proc ::kettle::recipe::defx {name description cmdprefix} {
    # Note! The scripts are evaluated in the context of namespace
    # ::kettle. This provide access to various internal commands
    # without making them visible to the user/DSL.

    set description [strutil reflow $description]
    io trace {DEF $name}

    kettle cli extend $name [subst -nocommands -nobackslashes {
	section Targets Project
	# parameters -> only options, define dynamically
	description {$description}
    }] [list ::kettle::recipe::RunCmd $name $cmdprefix]
    return
}

proc ::kettle::recipe::RunCmd {name cmdprefix config} {
    # config => options
    # dynamically save the information somewhere.
    # maybe just save 'config'

    try {
	status begin $name

	# Now run the recipe itself
	io trace {RUN ($name) ... BEGIN}

	if {![option get --machine]} {
	    io note { io puts -nonewline "\n${name}: " }
	}

	try {
	    {*}$cmdprefix
	    status ok
	} trap {KETTLE STATUS OK}   {e o} {
	    io trace {RUN ($name) ... OK}
	    # nothing - implied continue
	} trap {KETTLE STATUS FAIL} {e o} {
	    io trace {RUN ($name) ... FAIL}
	    # nothing - implied break
	}
    }
    return
}

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

proc ::kettle::recipe::define {name description arguments script args} {
    variable recipe

    # Note! The scripts are evaluated in the context of namespace
    # ::kettle. This provide access to various internal commands
    # without making them visible to the user/DSL.
................................................................................
    io trace {DEF $name}

    Init $name $description

    dict update recipe $name def {
	dict lappend def script \
	    [lambda@ ::kettle $arguments $script {*}$args]


    }
    return
}

proc ::kettle::recipe::parent {name parent} {
return
    variable recipe

    Init $name
    Init $parent
    dict update recipe $name def {
	dict lappend def parent $parent
    }
................................................................................
    if {[dict exists $recipe $name]} return
    dict set recipe $name {
	script {}
	help   {}
	parent {}
    }

    set cmd [kettle cli extend $name [subst -nocommands -nobackslashes {
	section Targets Project
	# parameters -> only options, define dynamically
	description {$description}
    }] [list ::kettle::recipe::RunIt $name]]



    # Remember reference to handler for future modifications.
    dict set recipe $name handler $cmd
    return
}

proc ::kettle::recipe::RunIt {name config} {

Changes to standard.tcl.

12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
..
68
69
70
71
72
73
74

75
76






















77
78


79

80


















81
    section Targets Standard
    description {
	No operation.
	Debugging helper (use with -trace).
    }
} [lambda {config} {}]

# TODO: Make it a proper alias of 'null' above.
kettle cli extend nop {
    #section Targets Standard
    section Targets Standard
    description {
	No operation.
	Debugging helper (use with -trace).

    }
} [lambda {config} {}]

kettle cli extend forever {
    section Targets Standard
    description {
	Infinite loop.
	Debugging helper (use with -trace).
    }
................................................................................
kettle recipe define gui {
    Graphical interface to the system.
} {} {
    gui make
}

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


kettle recipe anchor validate {






















    Validation of various parts of the project.
}




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


















return







<
|
<
<
<
<
<
>
|
<







 







>


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

>
>
|
>

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

12
13
14
15
16
17
18

19





20
21

22
23
24
25
26
27
28
..
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
    section Targets Standard
    description {
	No operation.
	Debugging helper (use with -trace).
    }
} [lambda {config} {}]


kettle cli learn {





    alias nop = null
}


kettle cli extend forever {
    section Targets Standard
    description {
	Infinite loop.
	Debugging helper (use with -trace).
    }
................................................................................
kettle recipe define gui {
    Graphical interface to the system.
} {} {
    gui make
}

# # ## ### ##### ######## ############# #####################
## Anchors for project-based recipes to hook into.

kettle recipe anchor validate {
    Validate the entire project.
}

kettle recipe anchor doc {
    Manage the project documentation.
} !all

kettle recipe anchor {doc install} {
    Install the project documentation.
}

kettle recipe anchor {doc uninstall} {
    Uninstall the project documentation.
}

kettle recipe anchor {doc reinstall} {
    Reinstall the project documentation.
}

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

kettle recipe anchor install {
    Install the project.
}
kettle recipe anchor {install doc} {
    Install the project documentation.
}

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

kettle recipe anchor uninstall {
    Uninstall the project.
}
kettle recipe anchor {uninstall doc} {
    Uninstall the project documentation.
}

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

kettle recipe anchor reinstall {
    Reinstall the project. I.e. uninstall it, then install it again.
}
kettle recipe anchor {reinstall doc} {
    Reinstall the project documentation.
}

# # ## ### ##### ######## ############# #####################
return

Changes to testsuite.tcl.

466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
...
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
...
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
...
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
    stream to rawlog {[string range $line 0 end-1]}

    # Counters and other state in the calling environment.
    upvar 1 state state

    # Capture of test failure in progress.
    # Take all lines, unprocessed.
    CaptureFailureSync            ; # cap/state: sync     => body
    CaptureFailureCollectBody     ; # cap/state: body     => actual|error|setup|cleanup|normal
    CaptureFailureCollectSetup    ; # cap/state: setup    => none
    CaptureFailureCollectCleanup  ; # cap/state: cleanup  => none
    CaptureFailureCollectActual   ; # cap/state: actual   => expected
    CaptureFailureCollectExpected ; # cap/state: expected => none
    CaptureFailureCollectError    ; # cap/state: error    => expected
    CaptureFailureCollectNormal   ; # cap/state: normal   => none

    # Capture of Tcl stack trace in progress.
    # Take all lines, unprocessed.
    CaptureStack

    # Start processing the input line for easier matching, and to
    # reduce the log.
................................................................................
    Host;Platform;Cwd;Shell;Tcl
    Start;End
    Testsuite;NoTestsuite
    Support;Testing
    Summary

    TestStart;TestSkipped;TestPassed
    TestFailed        ; # cap/state => sync, see CaptureFailure* above
    CaptureStackStart ; # cap/stack => on,   see CaptureStaCK ABOVE

    Aborted
    AbortCause

    Match||Skip||Sourced

    # Unknown lines are simply shown (disturbing the animation, good
................................................................................
	file     {}
	test     {}
	start    {}
	times    {}

	suite/status ok

	cap/state none
	cap/stack off
    }
    return
}

proc ::kettle::Test::Host {} {
    upvar 1 line line state state
................................................................................
}

proc ::kettle::Test::TestFailed {} {
    upvar 1 line line state state
    if {![string match {==== * FAILED} $line]} return
    set testname [lindex [split [string range $line 5 end-7]] 0]
    stream awrite "FAIL $testname"
    dict set state suite/status fail
    dict incr state testfail

    if {![dict exists $state test] ||
	([dict get $state test] eq {})} {
	# Required for tests which fail during -setup. These are not
	# reported as started, and TestStart above is never run for
	# them.
	dict set state test $testname
    }

    CaptureInit
    return -code return
}

proc ::kettle::Test::CaptureFailureSync {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "sync"} return
    upvar 1 line line
    if {![string match {==== Contents*} $line]} return
    CaptureNext body
    return -code return
}

proc ::kettle::Test::CaptureFailureCollectBody {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "body"} return

    upvar 1 line line
    if {[string match {---- Result was*} $line]} {
	CaptureNext actual
	return -code return
    } elseif {[string match {---- Test setup failed:*} $line]} {
	CaptureNext setup
	return -code return
    } elseif {[string match {---- Test cleanup failed:*} $line]} {
	CaptureNext cleanup
	return -code return
    } elseif {[string match {---- Test generated error*} $line]} {
	CaptureNext error
	return -code return
    } elseif {[string match {---- Test completed normally*} $line]} {
	CaptureNext normal
	return -code return
    }

    if {[string trim $line] ne {}} {
	dict update state cap c {
	    dict append c body $line
	}
    }

    return -code return
}

proc ::kettle::Test::CaptureFailureCollectSetup {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "setup"} return

    upvar 1 line line

    if {![string match {==== *} $line]} {
	dict update state cap c {
	    dict append c setup $line
	}
	return -code return
    }

    CaptureStop
    return -code return
}

proc ::kettle::Test::CaptureFailureCollectCleanup {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "cleanup"} return

    upvar 1 line line

    if {![string match {==== *} $line]} {
	dict update state cap c {
	    dict append c cleanup $line
	}
	return -code return
    }

    CaptureStop
    return -code return
}

proc ::kettle::Test::CaptureFailureCollectActual {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "actual"} return

    upvar 1 line line
    if {[string match {---- Result should*} $line]} {
	CaptureNext expected
	return -code return
    }

    dict update state cap c {
	dict append c actual $line
    }

    return -code return
}

proc ::kettle::Test::CaptureFailureCollectExpected {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "expected"} return

    upvar 1 line line
    if {![string match {==== *} $line]} {
	dict update state cap c {
	    dict append c expected $line
	}
	return -code return
    }

    CaptureStop
    return -code return
}

proc ::kettle::Test::CaptureFailureCollectNormal {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "normal"} return

    upvar 1 line line
    if {![string match {==== *} $line]} {
	dict update state cap c {
	    dict append c normal $line
	}
	return -code return
    }

    CaptureStop
    return -code return
}

proc ::kettle::Test::CaptureFailureCollectError {} {
    upvar 1 state state
    if {[dict get $state cap/state] ne "error"} return

    upvar 1 line line
    if {[string match {---- errorCode*} $line]} {
	CaptureNext expected
	return -code return
    }

    dict update state cap c {
	dict append c actual $line
    }
    return -code return
}

proc ::kettle::Test::CaptureInit {} {
    #upvar 1 line line ; stream to captrace {CAP/sync: $line}
    upvar 1 state state
    ## Initialize state machine to capture the test result.
    ## states: none, sync, body, actual, expected, done, error
    dict set state cap/state    sync
    dict set state cap actual   {}
    dict set state cap body     {}
    dict set state cap cleanup  {}
    dict set state cap expected {}
    dict set state cap setup    {}
    dict set state cap normal   {}
    return
}

proc ::kettle::Test::CaptureNext {new} {
    #upvar 1 line line ; stream to captrace {CAP/$new: $line}
    upvar 1 state state
    dict set state cap/state $new
    return
}

proc ::kettle::Test::CaptureStop {} {
    #upvar 1 line line ; stream to captrace {CAP/stop: $line}
    upvar 1 state state

    if {[stream active]} {
	set test     [dict get $state test]
	set body     [dict get $state cap body]
	set setup    [dict get $state cap setup]
	set cleanup  [dict get $state cap cleanup]
	set actual   [dict get $state cap actual]
	set expected [dict get $state cap expected]
	set normal   [dict get $state cap normal]

	stream to faildetails {}
	stream to faildetails {[string repeat = 60]}
	stream to faildetails {==== [lrange $test end-1 end]}
	stream to faildetails {==== Contents of test case:\n}
	stream to faildetails {$body}

	if {$actual ne {}} {
	    stream to faildetails {---- Result was:}
	    stream to faildetails {[string range $actual 0 end-1]}
	    stream to faildetails {---- Result should have been:}
	    stream to faildetails {[string range $expected 0 end-1]}
	    stream to faildetails {---- End\n}

	    set fname [string map {
		/ %2f
		: %3a
	    } $test]

	    stream to result.${fname}.expected {$expected}
	    stream to result.${fname}.actual   {$actual}
	}

	if {$setup ne {}} {
	    stream to faildetails {---- Test setup failed:}
	    stream to faildetails {[string range $setup 0 end-1]}
	}

	if {$cleanup ne {}} {
	    stream to faildetails {---- Test cleanup failed:}
	    stream to faildetails {[string range $cleanup 0 end-1]}
	}

	if {$normal ne {}} {
	    stream to faildetails {---- Test completed normally, expected error:}
	    stream to faildetails {[string range $normal 0 end-1]}
	}

	stream to faildetails {[string repeat = 60]}

    }

    dict unset state cap
    dict set   state cap/state none
    dict set   state test {}
    return
}

proc ::kettle::Test::CaptureStackStart {} {
    upvar 1 line line state state
    if {![string match {@+*} $line]} return







|
<
<
<
<
<
<
<







 







|
|







 







|







 







|










|



|

|
<
<
<
<
|
<
<
<
<
<

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
|
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
|
<
|
<
<
<
<
<
<
<
<
<
<
<
|
|

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|



<
|
<
|
<
<
<
<
<
<
<
<
<
<
<










<
<
<
<
<



<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
|
<
<
<
<
<
<
<
<
<
<
<
<
>



|







466
467
468
469
470
471
472
473







474
475
476
477
478
479
480
...
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
...
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
...
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
    stream to rawlog {[string range $line 0 end-1]}

    # Counters and other state in the calling environment.
    upvar 1 state state

    # Capture of test failure in progress.
    # Take all lines, unprocessed.
    CaptureFailure








    # Capture of Tcl stack trace in progress.
    # Take all lines, unprocessed.
    CaptureStack

    # Start processing the input line for easier matching, and to
    # reduce the log.
................................................................................
    Host;Platform;Cwd;Shell;Tcl
    Start;End
    Testsuite;NoTestsuite
    Support;Testing
    Summary

    TestStart;TestSkipped;TestPassed
    TestFailed        ; # cap/state => on, see CaptureFailure above
    CaptureStackStart ; # cap/stack => on, see CaptureStack   above

    Aborted
    AbortCause

    Match||Skip||Sourced

    # Unknown lines are simply shown (disturbing the animation, good
................................................................................
	file     {}
	test     {}
	start    {}
	times    {}

	suite/status ok

	cap/state off
	cap/stack off
    }
    return
}

proc ::kettle::Test::Host {} {
    upvar 1 line line state state
................................................................................
}

proc ::kettle::Test::TestFailed {} {
    upvar 1 line line state state
    if {![string match {==== * FAILED} $line]} return
    set testname [lindex [split [string range $line 5 end-7]] 0]
    stream awrite "FAIL $testname"
    dict set  state suite/status fail
    dict incr state testfail

    if {![dict exists $state test] ||
	([dict get $state test] eq {})} {
	# Required for tests which fail during -setup. These are not
	# reported as started, and TestStart above is never run for
	# them.
	dict set state test $testname
    }

    CaptureInit $line\n
    return -code return
}

proc ::kettle::Test::CaptureFailure {} {
    upvar 1 state state
    if {![dict get $state cap/state]} return










    upvar 1 line line


















    dict update state cap c {
	dict append c body $line
    }











    if {[string match {==== * FAILED*} $line]} {






	CaptureStop

    }











    return -code return
}






































































proc ::kettle::Test::CaptureInit {line} {
    #upvar 1 line line ; stream to captrace {CAP/sync: $line}
    upvar 1 state state
    ## Initialize state machine to capture the test result.

    dict set state cap/state    1

    dict set state cap body     $line











    return
}

proc ::kettle::Test::CaptureStop {} {
    #upvar 1 line line ; stream to captrace {CAP/stop: $line}
    upvar 1 state state

    if {[stream active]} {
	set test     [dict get $state test]
	set body     [dict get $state cap body]






	stream to faildetails {}
	stream to faildetails {[string repeat = 60]}


	stream to faildetails {[string trimright $body]}



















	stream to faildetails {[string repeat = 60]}













	# REDO: extract expected and actual results, and save them.
    }

    dict unset state cap
    dict set   state cap/state 0
    dict set   state test {}
    return
}

proc ::kettle::Test::CaptureStackStart {} {
    upvar 1 line line state state
    if {![string match {@+*} $line]} return