1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
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
|
# -*- tcl -*-
# checker.tcl
#
# Code used inside of a checker interpreter to ensure correct usage of
# doctools formatting commands.
#
# Copyright (c) 2003-2014 Andreas Kupries <andreas_kupries@sourceforge.net>
# L10N
package require msgcat
proc ::msgcat::mcunknown {locale code} {
return "unknown error code \"$code\" (for locale $locale)"
}
if {0} {
puts stderr "Locale [::msgcat::mcpreferences]"
foreach path [dt_search] {
puts stderr "Catalogs: [::msgcat::mcload $path] - $path"
}
} else {
foreach path [dt_search] {
::msgcat::mcload $path
}
}
# State, and checker commands.
# -------------------------------------------------------------
#
# Note that the code below assumes that a command XXX provided by the
# formatter engine is accessible under the name 'fmt_XXX'.
#
# -------------------------------------------------------------
global state lstctx lstitem
# --------------+-----------------------+----------------------
# state | allowed commands | new state (if any)
# --------------+-----------------------+----------------------
# all except | arg cmd opt comment |
# for "done" | syscmd method option |
# | widget fun type class |
# | package var file uri |
# | strong emph namespace |
# --------------+-----------------------+----------------------
# manpage_begin | manpage_begin | header
# --------------+-----------------------+----------------------
# header | moddesc titledesc | header
# | copyright keywords |
# | require see_also category |
# +-----------------------+-----------
# | description | body
# --------------+-----------------------+----------------------
# body | section para list_end | body
# | list_begin lst_item |
# | call bullet usage nl |
# | example see_also |
# | keywords sectref enum |
# | arg_def cmd_def |
# | opt_def tkoption_def |
# | subsection category |
# +-----------------------+-----------
# | example_begin | example
# +-----------------------+-----------
# | manpage_end | done
# --------------+-----------------------+----------------------
# example | example_end | body
# --------------+-----------------------+----------------------
# done | |
# --------------+-----------------------+----------------------
#
# Additional checks
# --------------------------------------+----------------------
# list_begin/list_end | Are allowed to nest.
# --------------------------------------+----------------------
# section | Not allowed in list context
#
# arg_def | Only in 'argument list'.
# cmd_def | Only in 'command list'.
# nl para | Only in list item context.
# opt_def | Only in 'option list'.
# tkoption_def | Only in 'tkoption list'.
# def/call | Only in 'definition list'.
# enum | Only in 'enum list'.
# item/bullet | Only in 'bullet list'.
# --------------------------------------+----------------------
# -------------------------------------------------------------
# Helpers
proc Error {code {text {}}} {
global state lstctx lstitem
# Problematic command with all arguments (we strip the "ck_" prefix!)
# -*- future -*- count lines of input, maintain history buffer, use
# -*- future -*- that to provide some context here.
set cmd [lindex [info level 1] 0]
set args [lrange [info level 1] 1 end]
if {$args != {}} {append cmd " [join $args]"}
# Use a message catalog to map the error code into a legible message.
set msg [::msgcat::mc $code]
if {$text != {}} {
set msg [string map [list @ $text] $msg]
}
dt_error "Manpage error ($code), \"$cmd\" : ${msg}."
return
}
proc Warn {code args} {
global pass
if {$pass > 1} return
# Warnings only in the first pass!
set msg [::msgcat::mc $code]
foreach {off line col} [dt_where] break
set msg [eval [linsert $args 0 format $msg]]
set msg "In macro at line $line, column $col of file [dt_file]:\n$msg"
set msg [split $msg \n]
set prefix "DocTools Warning ($code): "
dt_warning "$prefix[join $msg "\n$prefix"]"
return
}
proc WarnX {code args} {
# Warnings only in the first pass!
set msg [::msgcat::mc $code]
foreach {off line col} [dt_where] break
set msg [eval [linsert $args 0 format $msg]]
set msg "In macro at line $line, column $col of file [dt_file]:\n$msg"
set msg [split $msg \n]
set prefix "DocTools Warning ($code): "
dt_warning "$prefix[join $msg "\n$prefix"]"
return
}
proc Is {s} {global state ; return [string equal $state $s]}
proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]}
proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return}
proc LPush {l} {
global lstctx lstitem
set lstctx [linsert $lstctx 0 $l $lstitem]
return
}
proc LPop {} {
global lstctx lstitem
set lstitem [lindex $lstctx 1]
set lstctx [lrange $lstctx 2 end]
return
}
proc LSItem {} {global lstitem ; set lstitem 1}
proc LIs {l} {global lstctx ; string equal $l [lindex $lstctx 0]}
proc LItem {} {global lstitem ; return $lstitem}
proc LNest {} {
global lstctx
expr {[llength $lstctx] / 2}
}
proc LOpen {} {
global lstctx
expr {$lstctx != {}}
}
global lmap ldmap
array set lmap {
bullet itemized item itemized
arg arguments args arguments
opt options opts options
cmd commands cmds commands
enum enumerated tkoption tkoptions
}
array set ldmap {
bullet . arg . cmd . tkoption . opt .
}
proc LMap {what} {
global lmap ldmap
if {![info exists lmap($what)]} {
return $what
}
if {[dt_deprecated] && [info exists ldmap($what)]} {
Warn depr_ltype $what $lmap($what)
}
return $lmap($what)
}
proc LValid {what} {
switch -exact -- $what {
arguments -
commands -
definitions -
enumerated -
itemized -
options -
tkoptions {return 1}
default {return 0}
}
}
proc State {} {global state ; return $state}
proc Enter {cmd} {Log "\[[State]\] $cmd"}
#proc Log* {text} {puts -nonewline $text}
#proc Log {text} {puts $text}
proc Log* {text} {}
proc Log {text} {}
# -------------------------------------------------------------
# Framing
proc ck_initialize {p} {
global state ; set state manpage_begin
global lstctx ; set lstctx [list]
global lstitem ; set lstitem 0
global sect
if {$p == 1} {
catch {unset sect} ; set sect() . ; unset sect()
catch {unset sectt} ; set sectt() . ; unset sectt()
}
global pass ; set pass $p
global countersection ; set countersection 0
global countersubsection ; set countersubsection 0
return
}
proc ck_complete {} {
if {[Is done]} {
if {![LOpen]} {
return
} else {
Error end/open/list
}
} elseif {[Is example]} {
Error end/open/example
} else {
Error end/open/mp
}
return
}
# -------------------------------------------------------------
# Plain text
proc plain_text {text} {
# Only in body, not between list_begin and first item.
# Ignore everything which is only whitespace ...
set redux [string map [list " " "" "\t" "" "\n" ""] $text]
if {$redux == {}} {return [fmt_plain_text $text]}
if {[IsNot body] && [IsNot example]} {Error body}
if {[LOpen] && ![LItem]} {Error nolisttxt}
return [fmt_plain_text $text]
}
# -------------------------------------------------------------
# Variable handling ...
proc vset {var args} {
switch -exact -- [llength $args] {
0 {
# Retrieve contents of variable VAR
upvar #0 __$var data
if {![info exists data]} {
return -code error "can't read doc variable \"$var\": not set"
}
return $data
}
1 {
# Set contents of variable VAR
global __$var
set __$var [lindex $args 0]
return "" ; # Empty string ! Nothing for output.
}
default {
return -code error "wrong#args: set var ?value?"
}
}
}
# -------------------------------------------------------------
# Formatting commands
proc manpage_begin {title section version} {
Enter manpage_begin
if {[IsNot manpage_begin]} {Error mpbegin}
if {[string match {* *} $title]} {Error mptitle}
Go header
fmt_manpage_begin $title $section $version
}
proc moddesc {desc} {
Enter moddesc
if {[IsNot header]} {Error hdrcmd}
fmt_moddesc $desc
}
proc titledesc {desc} {
Enter titledesc
if {[IsNot header]} {Error hdrcmd}
fmt_titledesc $desc
}
proc copyright {text} {
Enter copyright
if {[IsNot header]} {Error hdrcmd}
fmt_copyright $text
}
proc manpage_end {} {
Enter manpage_end
if {[IsNot body]} {Error bodycmd}
Go done
fmt_manpage_end
}
proc require {pkg {version {}}} {
Enter require
if {[IsNot header]} {Error hdrcmd}
fmt_require $pkg $version
}
proc description {} {
Enter description
if {[IsNot header]} {Error hdrcmd}
Go body
fmt_description [Sectdef section Description description]
}
# Storage for (sub)section ids to enable checking for ambigous
# identificaton. The ids on this level are logical names. The backends
# are given physical names (via counters).
global sect ; # Map of logical -> physical ids
global sectt ; # Map of logical -> section title
global sectci ; # Current section (id)
global sectct ; # Current section (title)
global countersection
global countersubsection
proc section {title {id {}}} {
global sect
Enter section
if {[IsNot body]} {Error bodycmd}
if {[LOpen]} {Error nolistcmd}
fmt_section $title [Sectdef section $title $id]
}
proc subsection {title {id {}}} {
global sect
Enter subsection
if {[IsNot body]} {Error bodycmd}
if {[LOpen]} {Error nolistcmd}
fmt_subsection $title [Sectdef subsection $title $id]
}
proc Sectdef {type title id} {
global sect sectt sectci sectct countersection countersubsection pass
# Compute a (sub)section id from the name (= section label/title)
# if the user did not provide their own id.
if {![string length $id]} {
if {$type == "section"} {
set id [list $title]
} elseif {$type == "subsection"} {
set id [list $sectci $title]
} else {
error INTERNAL
}
}
# Check if the id is unambigous. Issue a warning if not. For
# sections we remember the now-current name and id for use by
# subsections.
if {$pass == 1} {
if {[info exists sect($id)]} {
set msg $title
if {$type == "subsection"} {
append msg " (in " $sectct ")"
}
Warn sectambig $msg
}
set sect($id) $type[incr counter$type]
}
set sectt($id) $title
if {$type == "section"} {
set sectci $id
set sectct $title
}
return $sect($id)
}
proc para {} {
Enter para
if {[IsNot body]} {Error bodycmd}
if {[LOpen]} {
if {![LItem]} {Error nolisthdr}
fmt_nl
} else {
fmt_para
}
}
proc list_begin {what {hint {}}} {
Enter "list_begin $what $hint"
if {[IsNot body]} {Error bodycmd}
if {[LOpen] && ![LItem]} {Error nolisthdr}
set what [LMap $what]
if {![LValid $what]} {Error invalidlist $what}
set res [fmt_list_begin $what $hint]
LPush $what
return $res
}
proc list_end {} {
Enter list_end
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
LPop
fmt_list_end
}
# Deprecated command, and its common misspellings. Canon is 'def'.
proc lst_item {{text {}}} {
if {[dt_deprecated]} {Warn depr_lstitem "\[lst_item\]"}
def $text
}
proc list_item {{text {}}} {
if {[dt_deprecated]} {Warn depr_lstitem "\[list_item\]"}
def $text
}
proc listitem {{text {}}} {
if {[dt_deprecated]} {Warn depr_lstitem "\[listitem\]"}
def $text
}
proc lstitem {{text {}}} {
if {[dt_deprecated]} {Warn depr_lstitem "\[lstitem\]"}
def $text
}
proc def {{text {}}} {
Enter def
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs definitions]} {Error deflist}
LSItem
fmt_lst_item $text
}
proc arg_def {type name {mode {}}} {
Enter arg_def
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs arguments]} {Error arg_list}
LSItem
fmt_arg_def $type $name $mode
}
proc cmd_def {command} {
Enter cmd_def
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs commands]} {Error cmd_list}
LSItem
fmt_cmd_def $command
}
proc opt_def {name {arg {}}} {
Enter opt_def
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs options]} {Error opt_list}
LSItem
fmt_opt_def $name $arg
}
proc tkoption_def {name dbname dbclass} {
Enter tkoption_def
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs tkoptions]} {Error tkoption_list}
LSItem
fmt_tkoption_def $name $dbname $dbclass
}
proc call {cmd args} {
Enter call
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs definitions]} {Error deflist}
LSItem
eval [linsert $args 0 fmt_call $cmd]
}
# Deprecated. Use 'item'
proc bullet {} {
if {[dt_deprecated]} {Warn depr_bullet "\[bullet\]"}
item
}
proc item {} {
Enter item
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs itemized]} {Error bulletlist}
LSItem
fmt_bullet
}
proc enum {} {
Enter enum
if {[IsNot body]} {Error bodycmd}
if {![LOpen]} {Error listcmd}
if {![LIs enumerated]} {Error enumlist}
LSItem
fmt_enum
}
proc example {code} {
Enter example
return [example_begin][plain_text ${code}][example_end]
}
proc example_begin {} {
Enter example_begin
if {[IsNot body]} {Error bodycmd}
if {[LOpen] && ![LItem]} {Error nolisthdr}
Go example
fmt_example_begin
}
proc example_end {} {
Enter example_end
if {[IsNot example]} {Error examplecmd}
Go body
fmt_example_end
}
proc see_also {args} {
Enter see_also
if {[Is done]} {Error nodonecmd}
# if {[IsNot body]} {Error bodycmd}
# if {[LOpen]} {Error nolistcmd}
eval [linsert $args 0 fmt_see_also]
}
proc keywords {args} {
Enter keywords
if {[Is done]} {Error nodonecmd}
# if {[IsNot body]} {Error bodycmd}
# if {[LOpen]} {Error nolistcmd}
eval [linsert $args 0 fmt_keywords]
}
proc category {text} {
Enter category
if {[Is done]} {Error nodonecmd}
# if {[IsNot body]} {Error bodycmd}
# if {[LOpen]} {Error nolistcmd}
fmt_category $text
}
# nl - Deprecated
proc nl {} {
if {[dt_deprecated]} {Warn depr_nl "\[nl\]"}
para
}
proc emph {text} {
if {[Is done]} {Error nodonecmd}
fmt_emph $text
}
# strong - Deprecated
proc strong {text} {
if {[dt_deprecated]} {Warn depr_strong "\[strong\]"}
emph $text
}
proc arg {text} {
if {[Is done]} {Error nodonecmd}
fmt_arg $text
}
proc cmd {text} {
if {[Is done]} {Error nodonecmd}
fmt_cmd $text
}
proc opt {text} {
if {[Is done]} {Error nodonecmd}
fmt_opt $text
}
proc comment {text} {
if {[Is done]} {Error nodonecmd}
return ; #fmt_comment $text
}
proc sectref-external {title} {
if {[IsNot body]} {Error bodycmd}
if {[LOpen] && ![LItem]} {Error nolisthdr}
fmt_sectref $title {}
}
proc sectref {id {title {}}} {
if {[IsNot body]} {Error bodycmd}
if {[LOpen] && ![LItem]} {Error nolisthdr}
# syntax: id ?title?
# Check existence of referenced (sub)section.
global sect sectt sectci pass
# Two things are done.
# (1) Check that the id is known and determine the full id.
# (2) Determine physical id, and, if needed, the title.
if {[info exists sect($id)]} {
# Logical id, likely user-supplied, exists.
set pid $sect($id)
set fid $id
} else {
# Doesn't exist directly. Assume that the id is derived from a
# (sub)section title, search various combinations.
set fid [list $id]
if {[info exists sect($fid)]} {
# Id was wrapped section title.
set pid $sect($fid)
} else {
# See if the id is the tail end of a subsection id.
set ic [array names sect [list * $id]]
if {![llength $ic]} {
# No, it is not. Give up.
if {$pass > 1 } { WarnX missingsect $id }
set pid {}
} elseif {[llength $ic] == 1} {
# Yes, and it is unique. Take it.
set fid [lindex $ic 0]
set pid $sect($fid)
} else {
# Yes, however it is ambigous. Issue warning, then
# select one of the possibilities. Prefer to keep the
# reference within the currenc section, otherwise,
# i.e. if we cannot do that, choose randomly.
if {$pass == 2} { WarnX sectambig $id }
set fid [list $sectci $id]
if {![info exists sect($fid)]} {
# No candidate in current section, so chose
# randomly.
set fid [lindex $ic 0]
}
set pid $sect($fid)
}
}
}
# If we have no text take the section title as text, if we
# can. Last fallback for thext is the id.
if {$title == {}} {
if {$pid != {}} {
set title $sectt($fid)
} else {
set title $id
}
}
# Hand both chosen title and physical id to the backend for
# actual formatting.
fmt_sectref $title $pid
}
proc syscmd {text} {
if {[Is done]} {Error nodonecmd}
fmt_syscmd $text
}
proc method {text} {
if {[Is done]} {Error nodonecmd}
fmt_method $text
}
proc option {text} {
if {[Is done]} {Error nodonecmd}
fmt_option $text
}
proc widget {text} {
if {[Is done]} {Error nodonecmd}
fmt_widget $text
}
proc fun {text} {
if {[Is done]} {Error nodonecmd}
fmt_fun $text
}
proc type {text} {
if {[Is done]} {Error nodonecmd}
fmt_type $text
}
proc package {text} {
if {[Is done]} {Error nodonecmd}
fmt_package $text
}
proc class {text} {
if {[Is done]} {Error nodonecmd}
fmt_class $text
}
proc var {text} {
if {[Is done]} {Error nodonecmd}
fmt_var $text
}
proc file {text} {
if {[Is done]} {Error nodonecmd}
fmt_file $text
}
# Special case: We must not overwrite the builtin namespace command,
# as it is required by the package "msgcat".
proc _namespace {text} {
if {[Is done]} {Error nodonecmd}
fmt_namespace $text
}
proc uri {text {label {}}} {
if {[Is done]} {Error nodonecmd}
# The label argument is left out when undefined so that we can
# control old formatters as well, if the input is not using uri
# labels.
if {$label == {}} {
fmt_uri $text
} else {
fmt_uri $text $label
}
}
proc image {text {label {}}} {
if {[Is done]} {Error nodonecmd}
# The label argument is left out when undefined so that we can
# control old formatters as well, if the input is not using uri
# labels.
if {$label == {}} {
fmt_image $text
} else {
fmt_image $text $label
}
}
proc manpage {text} {
if {[Is done]} {Error nodonecmd}
# The label argument is left out when undefined so that we can
# control old formatters as well, if the input is not using uri
# labels.
fmt_term $text
#fmt_manpage $text
}
proc usage {args} {
if {[Is done]} {Error nodonecmd}
eval fmt_usage $args
}
proc const {text} {
if {[Is done]} {Error nodonecmd}
fmt_const $text
}
proc term {text} {
if {[Is done]} {Error nodonecmd}
fmt_term $text
}
proc mdash {} {
if {[Is done]} {Error nodonecmd}
fmt_mdash $text
}
proc ndash {} {
if {[Is done]} {Error nodonecmd}
fmt_ndash $text
}
# -------------------------------------------------------------
|