1# -*- tcl -*- 2# checker.tcl 3# 4# Code used inside of a checker interpreter to ensure correct usage of 5# doctools formatting commands. 6# 7# Copyright (c) 2003-2010 Andreas Kupries <andreas_kupries@sourceforge.net> 8 9# L10N 10 11package require msgcat 12 13proc ::msgcat::mcunknown {locale code} { 14 return "unknown error code \"$code\" (for locale $locale)" 15} 16 17if {0} { 18 puts stderr "Locale [::msgcat::mcpreferences]" 19 foreach path [dt_search] { 20 puts stderr "Catalogs: [::msgcat::mcload $path] - $path" 21 } 22} else { 23 foreach path [dt_search] { 24 ::msgcat::mcload $path 25 } 26} 27 28# State, and checker commands. 29# ------------------------------------------------------------- 30# 31# Note that the code below assumes that a command XXX provided by the 32# formatter engine is accessible under the name 'fmt_XXX'. 33# 34# ------------------------------------------------------------- 35 36global state lstctx lstitem 37 38# --------------+-----------------------+---------------------- 39# state | allowed commands | new state (if any) 40# --------------+-----------------------+---------------------- 41# all except | arg cmd opt comment | 42# for "done" | syscmd method option | 43# | widget fun type class | 44# | package var file uri | 45# | strong emph namespace | 46# --------------+-----------------------+---------------------- 47# manpage_begin | manpage_begin | header 48# --------------+-----------------------+---------------------- 49# header | moddesc titledesc | header 50# | copyright keywords | 51# | require see_also category | 52# +-----------------------+----------- 53# | description | body 54# --------------+-----------------------+---------------------- 55# body | section para list_end | body 56# | list_begin lst_item | 57# | call bullet usage nl | 58# | example see_also | 59# | keywords sectref enum | 60# | arg_def cmd_def | 61# | opt_def tkoption_def | 62# | subsection category | 63# +-----------------------+----------- 64# | example_begin | example 65# +-----------------------+----------- 66# | manpage_end | done 67# --------------+-----------------------+---------------------- 68# example | example_end | body 69# --------------+-----------------------+---------------------- 70# done | | 71# --------------+-----------------------+---------------------- 72# 73# Additional checks 74# --------------------------------------+---------------------- 75# list_begin/list_end | Are allowed to nest. 76# --------------------------------------+---------------------- 77# section | Not allowed in list context 78# 79# arg_def | Only in 'argument list'. 80# cmd_def | Only in 'command list'. 81# nl para | Only in list item context. 82# opt_def | Only in 'option list'. 83# tkoption_def | Only in 'tkoption list'. 84# def/call | Only in 'definition list'. 85# enum | Only in 'enum list'. 86# item/bullet | Only in 'bullet list'. 87# --------------------------------------+---------------------- 88 89# ------------------------------------------------------------- 90# Helpers 91proc Error {code {text {}}} { 92 global state lstctx lstitem 93 94 # Problematic command with all arguments (we strip the "ck_" prefix!) 95 # -*- future -*- count lines of input, maintain history buffer, use 96 # -*- future -*- that to provide some context here. 97 98 set cmd [lindex [info level 1] 0] 99 set args [lrange [info level 1] 1 end] 100 if {$args != {}} {append cmd " [join $args]"} 101 102 # Use a message catalog to map the error code into a legible message. 103 set msg [::msgcat::mc $code] 104 105 if {$text != {}} { 106 set msg [string map [list @ $text] $msg] 107 } 108 dt_error "Manpage error ($code), \"$cmd\" : ${msg}." 109 return 110} 111proc Warn {code args} { 112 global pass 113 if {$pass > 1} return 114 # Warnings only in the first pass! 115 set msg [::msgcat::mc $code] 116 foreach {off line col} [dt_where] break 117 set msg [eval [linsert $args 0 format $msg]] 118 set msg "In macro at line $line, column $col of file [dt_file]:\n$msg" 119 set msg [split $msg \n] 120 set prefix "DocTools Warning ($code): " 121 dt_warning "$prefix[join $msg "\n$prefix"]" 122 return 123} 124proc WarnX {code args} { 125 # Warnings only in the first pass! 126 set msg [::msgcat::mc $code] 127 foreach {off line col} [dt_where] break 128 set msg [eval [linsert $args 0 format $msg]] 129 set msg "In macro at line $line, column $col of file [dt_file]:\n$msg" 130 set msg [split $msg \n] 131 set prefix "DocTools Warning ($code): " 132 dt_warning "$prefix[join $msg "\n$prefix"]" 133 return 134} 135 136proc Is {s} {global state ; return [string equal $state $s]} 137proc IsNot {s} {global state ; return [expr {![string equal $state $s]}]} 138proc Go {s} {Log " >>\[$s\]" ; global state ; set state $s; return} 139proc LPush {l} { 140 global lstctx lstitem 141 set lstctx [linsert $lstctx 0 $l $lstitem] 142 return 143} 144proc LPop {} { 145 global lstctx lstitem 146 set lstitem [lindex $lstctx 1] 147 set lstctx [lrange $lstctx 2 end] 148 return 149} 150proc LSItem {} {global lstitem ; set lstitem 1} 151proc LIs {l} {global lstctx ; string equal $l [lindex $lstctx 0]} 152proc LItem {} {global lstitem ; return $lstitem} 153proc LNest {} { 154 global lstctx 155 expr {[llength $lstctx] / 2} 156} 157proc LOpen {} { 158 global lstctx 159 expr {$lstctx != {}} 160} 161global lmap ldmap 162array set lmap { 163 bullet itemized item itemized 164 arg arguments args arguments 165 opt options opts options 166 cmd commands cmds commands 167 enum enumerated tkoption tkoptions 168} 169array set ldmap { 170 bullet . arg . cmd . tkoption . opt . 171} 172proc LMap {what} { 173 global lmap ldmap 174 if {![info exists lmap($what)]} { 175 return $what 176 } 177 if {[dt_deprecated] && [info exists ldmap($what)]} { 178 Warn depr_ltype $what $lmap($what) 179 } 180 return $lmap($what) 181} 182proc LValid {what} { 183 switch -exact -- $what { 184 arguments - 185 commands - 186 definitions - 187 enumerated - 188 itemized - 189 options - 190 tkoptions {return 1} 191 default {return 0} 192 } 193} 194 195proc State {} {global state ; return $state} 196proc Enter {cmd} {Log "\[[State]\] $cmd"} 197 198#proc Log* {text} {puts -nonewline $text} 199#proc Log {text} {puts $text} 200proc Log* {text} {} 201proc Log {text} {} 202 203 204# ------------------------------------------------------------- 205# Framing 206proc ck_initialize {p} { 207 global state ; set state manpage_begin 208 global lstctx ; set lstctx [list] 209 global lstitem ; set lstitem 0 210 global sect 211 if {$p == 1} { 212 catch {unset sect} ; set sect() . ; unset sect() 213 catch {unset sectt} ; set sectt() . ; unset sectt() 214 } 215 global pass ; set pass $p 216 global countersection ; set countersection 0 217 global countersubsection ; set countersubsection 0 218 return 219} 220proc ck_complete {} { 221 if {[Is done]} { 222 if {![LOpen]} { 223 return 224 } else { 225 Error end/open/list 226 } 227 } elseif {[Is example]} { 228 Error end/open/example 229 } else { 230 Error end/open/mp 231 } 232 return 233} 234# ------------------------------------------------------------- 235# Plain text 236proc plain_text {text} { 237 # Only in body, not between list_begin and first item. 238 # Ignore everything which is only whitespace ... 239 240 set redux [string map [list " " "" "\t" "" "\n" ""] $text] 241 if {$redux == {}} {return [fmt_plain_text $text]} 242 if {[IsNot body] && [IsNot example]} {Error body} 243 if {[LOpen] && ![LItem]} {Error nolisttxt} 244 return [fmt_plain_text $text] 245} 246 247# ------------------------------------------------------------- 248# Variable handling ... 249 250proc vset {var args} { 251 switch -exact -- [llength $args] { 252 0 { 253 # Retrieve contents of variable VAR 254 upvar #0 __$var data 255 return $data 256 } 257 1 { 258 # Set contents of variable VAR 259 global __$var 260 set __$var [lindex $args 0] 261 return "" ; # Empty string ! Nothing for output. 262 } 263 default { 264 return -code error "wrong#args: set var ?value?" 265 } 266 } 267} 268 269# ------------------------------------------------------------- 270# Formatting commands 271proc manpage_begin {title section version} { 272 Enter manpage_begin 273 if {[IsNot manpage_begin]} {Error mpbegin} 274 Go header 275 fmt_manpage_begin $title $section $version 276} 277proc moddesc {desc} { 278 Enter moddesc 279 if {[IsNot header]} {Error hdrcmd} 280 fmt_moddesc $desc 281} 282proc titledesc {desc} { 283 Enter titledesc 284 if {[IsNot header]} {Error hdrcmd} 285 fmt_titledesc $desc 286} 287proc copyright {text} { 288 Enter copyright 289 if {[IsNot header]} {Error hdrcmd} 290 fmt_copyright $text 291} 292proc manpage_end {} { 293 Enter manpage_end 294 if {[IsNot body]} {Error bodycmd} 295 Go done 296 fmt_manpage_end 297} 298proc require {pkg {version {}}} { 299 Enter require 300 if {[IsNot header]} {Error hdrcmd} 301 fmt_require $pkg $version 302} 303proc description {} { 304 Enter description 305 if {[IsNot header]} {Error hdrcmd} 306 Go body 307 fmt_description [Sectdef section Description description] 308} 309 310# Storage for (sub)section ids to enable checking for ambigous 311# identificaton. The ids on this level are logical names. The backends 312# are given physical names (via counters). 313global sect ; # Map of logical -> physical ids 314global sectt ; # Map of logical -> section title 315global sectci ; # Current section (id) 316global sectct ; # Current section (title) 317global countersection 318global countersubsection 319 320proc section {title {id {}}} { 321 global sect 322 323 Enter section 324 if {[IsNot body]} {Error bodycmd} 325 if {[LOpen]} {Error nolistcmd} 326 327 fmt_section $title [Sectdef section $title $id] 328} 329proc subsection {title {id {}}} { 330 global sect 331 332 Enter subsection 333 if {[IsNot body]} {Error bodycmd} 334 if {[LOpen]} {Error nolistcmd} 335 336 fmt_subsection $title [Sectdef subsection $title $id] 337} 338 339proc Sectdef {type title id} { 340 global sect sectt sectci sectct countersection countersubsection pass 341 342 # Compute a (sub)section id from the name (= section label/title) 343 # if the user did not provide their own id. 344 if {![string length $id]} { 345 if {$type == "section"} { 346 set id [list $title] 347 } elseif {$type == "subsection"} { 348 set id [list $sectci $title] 349 } else { 350 error INTERNAL 351 } 352 } 353 # Check if the id is unambigous. Issue a warning if not. For 354 # sections we remember the now-current name and id for use by 355 # subsections. 356 if {$pass == 1} { 357 if {[info exists sect($id)]} { 358 set msg $title 359 if {$type == "subsection"} { 360 append msg " (in " $sectct ")" 361 } 362 Warn sectambig $msg 363 } 364 set sect($id) $type[incr counter$type] 365 } 366 set sectt($id) $title 367 if {$type == "section"} { 368 set sectci $id 369 set sectct $title 370 } 371 return $sect($id) 372} 373 374proc para {} { 375 Enter para 376 if {[IsNot body]} {Error bodycmd} 377 if {[LOpen]} { 378 if {![LItem]} {Error nolisthdr} 379 fmt_nl 380 } else { 381 fmt_para 382 } 383} 384proc list_begin {what {hint {}}} { 385 Enter "list_begin $what $hint" 386 if {[IsNot body]} {Error bodycmd} 387 if {[LOpen] && ![LItem]} {Error nolisthdr} 388 set what [LMap $what] 389 if {![LValid $what]} {Error invalidlist $what} 390 LPush $what 391 fmt_list_begin $what $hint 392} 393proc list_end {} { 394 Enter list_end 395 if {[IsNot body]} {Error bodycmd} 396 if {![LOpen]} {Error listcmd} 397 LPop 398 fmt_list_end 399} 400 401# Deprecated command, and its common misspellings. Canon is 'def'. 402proc lst_item {{text {}}} { 403 if {[dt_deprecated]} {Warn depr_lstitem "\[lst_item\]"} 404 def $text 405} 406proc list_item {{text {}}} { 407 if {[dt_deprecated]} {Warn depr_lstitem "\[list_item\]"} 408 def $text 409} 410proc listitem {{text {}}} { 411 if {[dt_deprecated]} {Warn depr_lstitem "\[listitem\]"} 412 def $text 413} 414proc lstitem {{text {}}} { 415 if {[dt_deprecated]} {Warn depr_lstitem "\[lstitem\]"} 416 def $text 417} 418proc def {{text {}}} { 419 Enter def 420 if {[IsNot body]} {Error bodycmd} 421 if {![LOpen]} {Error listcmd} 422 if {![LIs definitions]} {Error deflist} 423 LSItem 424 fmt_lst_item $text 425} 426proc arg_def {type name {mode {}}} { 427 Enter arg_def 428 if {[IsNot body]} {Error bodycmd} 429 if {![LOpen]} {Error listcmd} 430 if {![LIs arguments]} {Error arg_list} 431 LSItem 432 fmt_arg_def $type $name $mode 433} 434proc cmd_def {command} { 435 Enter cmd_def 436 if {[IsNot body]} {Error bodycmd} 437 if {![LOpen]} {Error listcmd} 438 if {![LIs commands]} {Error cmd_list} 439 LSItem 440 fmt_cmd_def $command 441} 442proc opt_def {name {arg {}}} { 443 Enter opt_def 444 if {[IsNot body]} {Error bodycmd} 445 if {![LOpen]} {Error listcmd} 446 if {![LIs options]} {Error opt_list} 447 LSItem 448 fmt_opt_def $name $arg 449} 450proc tkoption_def {name dbname dbclass} { 451 Enter tkoption_def 452 if {[IsNot body]} {Error bodycmd} 453 if {![LOpen]} {Error listcmd} 454 if {![LIs tkoptions]} {Error tkoption_list} 455 LSItem 456 fmt_tkoption_def $name $dbname $dbclass 457} 458proc call {cmd args} { 459 Enter call 460 if {[IsNot body]} {Error bodycmd} 461 if {![LOpen]} {Error listcmd} 462 if {![LIs definitions]} {Error deflist} 463 LSItem 464 eval [linsert $args 0 fmt_call $cmd] 465} 466# Deprecated. Use 'item' 467proc bullet {} { 468 if {[dt_deprecated]} {Warn depr_bullet "\[bullet\]"} 469 item 470} 471proc item {} { 472 Enter item 473 if {[IsNot body]} {Error bodycmd} 474 if {![LOpen]} {Error listcmd} 475 if {![LIs itemized]} {Error bulletlist} 476 LSItem 477 fmt_bullet 478} 479proc enum {} { 480 Enter enum 481 if {[IsNot body]} {Error bodycmd} 482 if {![LOpen]} {Error listcmd} 483 if {![LIs enumerated]} {Error enumlist} 484 LSItem 485 fmt_enum 486} 487proc example {code} { 488 Enter example 489 return [example_begin][plain_text ${code}][example_end] 490} 491proc example_begin {} { 492 Enter example_begin 493 if {[IsNot body]} {Error bodycmd} 494 if {[LOpen] && ![LItem]} {Error nolisthdr} 495 Go example 496 fmt_example_begin 497} 498proc example_end {} { 499 Enter example_end 500 if {[IsNot example]} {Error examplecmd} 501 Go body 502 fmt_example_end 503} 504proc see_also {args} { 505 Enter see_also 506 if {[Is done]} {Error nodonecmd} 507 # if {[IsNot body]} {Error bodycmd} 508 # if {[LOpen]} {Error nolistcmd} 509 eval [linsert $args 0 fmt_see_also] 510} 511proc keywords {args} { 512 Enter keywords 513 if {[Is done]} {Error nodonecmd} 514 # if {[IsNot body]} {Error bodycmd} 515 # if {[LOpen]} {Error nolistcmd} 516 eval [linsert $args 0 fmt_keywords] 517} 518proc category {text} { 519 Enter category 520 if {[Is done]} {Error nodonecmd} 521 # if {[IsNot body]} {Error bodycmd} 522 # if {[LOpen]} {Error nolistcmd} 523 fmt_category $text 524} 525# nl - Deprecated 526proc nl {} { 527 if {[dt_deprecated]} {Warn depr_nl "\[nl\]"} 528 para 529} 530proc emph {text} { 531 if {[Is done]} {Error nodonecmd} 532 fmt_emph $text 533} 534# strong - Deprecated 535proc strong {text} { 536 if {[dt_deprecated]} {Warn depr_strong "\[strong\]"} 537 emph $text 538} 539proc arg {text} { 540 if {[Is done]} {Error nodonecmd} 541 fmt_arg $text 542} 543proc cmd {text} { 544 if {[Is done]} {Error nodonecmd} 545 fmt_cmd $text 546} 547proc opt {text} { 548 if {[Is done]} {Error nodonecmd} 549 fmt_opt $text 550} 551proc comment {text} { 552 if {[Is done]} {Error nodonecmd} 553 return ; #fmt_comment $text 554} 555proc sectref-external {title} { 556 if {[IsNot body]} {Error bodycmd} 557 if {[LOpen] && ![LItem]} {Error nolisthdr} 558 559 fmt_sectref $title {} 560} 561proc sectref {id {title {}}} { 562 if {[IsNot body]} {Error bodycmd} 563 if {[LOpen] && ![LItem]} {Error nolisthdr} 564 565 # syntax: id ?title? 566 # Check existence of referenced (sub)section. 567 global sect sectt sectci pass 568 569 # Two things are done. 570 # (1) Check that the id is known and determine the full id. 571 # (2) Determine physical id, and, if needed, the title. 572 573 if {[info exists sect($id)]} { 574 # Logical id, likely user-supplied, exists. 575 set pid $sect($id) 576 set fid $id 577 } else { 578 # Doesn't exist directly. Assume that the id is derived from a 579 # (sub)section title, search various combinations. 580 581 set fid [list $id] 582 if {[info exists sect($fid)]} { 583 # Id was wrapped section title. 584 set pid $sect($fid) 585 } else { 586 # See if the id is the tail end of a subsection id. 587 set ic [array names sect [list * $id]] 588 if {![llength $ic]} { 589 # No, it is not. Give up. 590 if {$pass > 1 } { WarnX missingsect $id } 591 set pid {} 592 } elseif {[llength $ic] == 1} { 593 # Yes, and it is unique. Take it. 594 set fid [lindex $ic 0] 595 set pid $sect($fid) 596 } else { 597 # Yes, however it is ambigous. Issue warning, then 598 # select one of the possibilities. Prefer to keep the 599 # reference within the currenc section, otherwise, 600 # i.e. if we cannot do that, choose randomly. 601 if {$pass == 2} { WarnX sectambig $id } 602 set fid [list $sectci $id] 603 if {![info exists sect($fid)]} { 604 # No candidate in current section, so chose 605 # randomly. 606 set fid [lindex $ic 0] 607 } 608 set pid $sect($fid) 609 } 610 } 611 } 612 613 # If we have no text take the section title as text, if we 614 # can. Last fallback for thext is the id. 615 if {$title == {}} { 616 if {$pid != {}} { 617 set title $sectt($fid) 618 } else { 619 set title $id 620 } 621 } 622 623 # Hand both chosen title and physical id to the backend for 624 # actual formatting. 625 fmt_sectref $title $pid 626} 627proc syscmd {text} { 628 if {[Is done]} {Error nodonecmd} 629 fmt_syscmd $text 630} 631proc method {text} { 632 if {[Is done]} {Error nodonecmd} 633 fmt_method $text 634} 635proc option {text} { 636 if {[Is done]} {Error nodonecmd} 637 fmt_option $text 638} 639proc widget {text} { 640 if {[Is done]} {Error nodonecmd} 641 fmt_widget $text 642} 643proc fun {text} { 644 if {[Is done]} {Error nodonecmd} 645 fmt_fun $text 646} 647proc type {text} { 648 if {[Is done]} {Error nodonecmd} 649 fmt_type $text 650} 651proc package {text} { 652 if {[Is done]} {Error nodonecmd} 653 fmt_package $text 654} 655proc class {text} { 656 if {[Is done]} {Error nodonecmd} 657 fmt_class $text 658} 659proc var {text} { 660 if {[Is done]} {Error nodonecmd} 661 fmt_var $text 662} 663proc file {text} { 664 if {[Is done]} {Error nodonecmd} 665 fmt_file $text 666} 667 668# Special case: We must not overwrite the builtin namespace command, 669# as it is required by the package "msgcat". 670proc _namespace {text} { 671 if {[Is done]} {Error nodonecmd} 672 fmt_namespace $text 673} 674proc uri {text {label {}}} { 675 if {[Is done]} {Error nodonecmd} 676 # The label argument is left out when undefined so that we can 677 # control old formatters as well, if the input is not using uri 678 # labels. 679 680 if {$label == {}} { 681 fmt_uri $text 682 } else { 683 fmt_uri $text $label 684 } 685} 686proc image {text {label {}}} { 687 if {[Is done]} {Error nodonecmd} 688 # The label argument is left out when undefined so that we can 689 # control old formatters as well, if the input is not using uri 690 # labels. 691 692 if {$label == {}} { 693 fmt_image $text 694 } else { 695 fmt_image $text $label 696 } 697} 698proc manpage {text} { 699 if {[Is done]} {Error nodonecmd} 700 # The label argument is left out when undefined so that we can 701 # control old formatters as well, if the input is not using uri 702 # labels. 703 704 fmt_term $text 705 #fmt_manpage $text 706} 707proc usage {args} { 708 if {[Is done]} {Error nodonecmd} 709 eval fmt_usage $args 710} 711proc const {text} { 712 if {[Is done]} {Error nodonecmd} 713 fmt_const $text 714} 715proc term {text} { 716 if {[Is done]} {Error nodonecmd} 717 fmt_term $text 718} 719 720proc mdash {} { 721 if {[Is done]} {Error nodonecmd} 722 fmt_mdash $text 723} 724proc ndash {} { 725 if {[Is done]} {Error nodonecmd} 726 fmt_ndash $text 727} 728 729# ------------------------------------------------------------- 730