1#!/bin/sh 2# The next line is executed by /bin/sh, but not tcl \ 3exec tclsh8.4 "$0" ${1+"$@"} 4 5package require Tcl 8.5 6 7# Convert Ousterhout format man pages into highly crosslinked hypertext. 8# 9# Along the way detect many unmatched font changes and other odd things. 10# 11# Note well, this program is a hack rather than a piece of software 12# engineering. In that sense it's probably a good example of things 13# that a scripting language, like Tcl, can do well. It is offered as 14# an example of how someone might convert a specific set of man pages 15# into hypertext, not as a general solution to the problem. If you 16# try to use this, you'll be very much on your own. 17# 18# Copyright (c) 1995-1997 Roger E. Critchlow Jr 19 20set Version "0.40" 21 22set ::CSSFILE "docs.css" 23 24proc parse_command_line {} { 25 global argv Version 26 27 # These variables determine where the man pages come from and where 28 # the converted pages go to. 29 global tcltkdir tkdir tcldir webdir build_tcl build_tk 30 31 # Set defaults based on original code. 32 set tcltkdir ../.. 33 set tkdir {} 34 set tcldir {} 35 set webdir ../html 36 set build_tcl 0 37 set build_tk 0 38 # Default search version is a glob pattern 39 set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}} 40 41 # Handle arguments a la GNU: 42 # --version 43 # --useversion=<version> 44 # --help 45 # --srcdir=/path 46 # --htmldir=/path 47 48 foreach option $argv { 49 switch -glob -- $option { 50 --version { 51 puts "tcltk-man-html $Version" 52 exit 0 53 } 54 55 --help { 56 puts "usage: tcltk-man-html \[OPTION\] ...\n" 57 puts " --help print this help, then exit" 58 puts " --version print version number, then exit" 59 puts " --srcdir=DIR find tcl and tk source below DIR" 60 puts " --htmldir=DIR put generated HTML in DIR" 61 puts " --tcl build tcl help" 62 puts " --tk build tk help" 63 puts " --useversion version of tcl/tk to search for" 64 exit 0 65 } 66 67 --srcdir=* { 68 # length of "--srcdir=" is 9. 69 set tcltkdir [string range $option 9 end] 70 } 71 72 --htmldir=* { 73 # length of "--htmldir=" is 10 74 set webdir [string range $option 10 end] 75 } 76 77 --useversion=* { 78 # length of "--useversion=" is 13 79 set useversion [string range $option 13 end] 80 } 81 82 --tcl { 83 set build_tcl 1 84 } 85 86 --tk { 87 set build_tk 1 88 } 89 90 default { 91 puts stderr "tcltk-man-html: unrecognized option -- `$option'" 92 exit 1 93 } 94 } 95 } 96 97 if {!$build_tcl && !$build_tk} { 98 set build_tcl 1; 99 set build_tk 1 100 } 101 102 if {$build_tcl} { 103 # Find Tcl. 104 set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ 105 -directory $tcltkdir tcl$useversion]] end] 106 if {$tcldir eq ""} { 107 puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" 108 exit 1 109 } 110 puts "using Tcl source directory $tcldir" 111 } 112 113 if {$build_tk} { 114 # Find Tk. 115 set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ 116 -directory $tcltkdir tk$useversion]] end] 117 if {$tkdir eq ""} { 118 puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" 119 exit 1 120 } 121 puts "using Tk source directory $tkdir" 122 } 123 124 # the title for the man pages overall 125 global overall_title 126 set overall_title "" 127 if {$build_tcl} { 128 append overall_title "[capitalize $tcldir]" 129 } 130 if {$build_tcl && $build_tk} { 131 append overall_title "/" 132 } 133 if {$build_tk} { 134 append overall_title "[capitalize $tkdir]" 135 } 136 append overall_title " Documentation" 137} 138 139proc capitalize {string} { 140 return [string toupper $string 0] 141} 142 143## 144## 145## 146set manual(report-level) 1 147 148proc manerror {msg} { 149 global manual 150 set name {} 151 set subj {} 152 set procname [lindex [info level -1] 0] 153 if {[info exists manual(name)]} { 154 set name $manual(name) 155 } 156 if {[info exists manual(section)] && [string length $manual(section)]} { 157 puts stderr "$name: $manual(section): $procname: $msg" 158 } else { 159 puts stderr "$name: $procname: $msg" 160 } 161} 162 163proc manreport {level msg} { 164 global manual 165 if {$level < $manual(report-level)} { 166 uplevel 1 [list manerror $msg] 167 } 168} 169 170proc fatal {msg} { 171 global manual 172 uplevel 1 [list manerror $msg] 173 exit 1 174} 175 176## 177## templating 178## 179proc indexfile {} { 180 if {[info exists ::TARGET] && $::TARGET eq "devsite"} { 181 return "index.tml" 182 } else { 183 return "contents.htm" 184 } 185} 186proc copyright {copyright {level {}}} { 187 # We don't actually generate a separate copyright page anymore 188 #set page "${level}copyright.htm" 189 #return "<A HREF=\"$page\">Copyright</A> © [htmlize-text [lrange $copyright 2 end]]" 190 # obfuscate any email addresses that may appear in name 191 set who [string map {@ (at)} [lrange $copyright 2 end]] 192 return "Copyright © [htmlize-text $who]" 193} 194proc copyout {copyrights {level {}}} { 195 set out "<div class=\"copy\">" 196 foreach c $copyrights { 197 append out "[copyright $c $level]\n" 198 } 199 append out "</div>" 200 return $out 201} 202proc CSS {{level ""}} { 203 return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n" 204} 205proc DOCTYPE {} { 206 return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" 207} 208proc htmlhead {title header args} { 209 set level "" 210 if {[lindex $args end] eq "../[indexfile]"} { 211 # XXX hack - assume same level for CSS file 212 set level "../" 213 } 214 set out "[DOCTYPE]\n<HTML>\n<HEAD><TITLE>$title</TITLE>\n[CSS $level]</HEAD>\n" 215 foreach {uptitle url} $args { 216 set header "<a href=\"$url\">$uptitle</a> <small>></small> $header" 217 } 218 append out "<BODY><H2>$header</H2>" 219 global manual 220 if {[info exists manual(subheader)]} { 221 set subs {} 222 foreach {name subdir} $manual(subheader) { 223 if {$name eq $title} { 224 lappend subs $name 225 } else { 226 lappend subs "<A HREF=\"${level}$subdir/[indexfile]\">$name</A>" 227 } 228 } 229 append out "\n<H3>[join $subs { | }]</H3>" 230 } 231 return $out 232} 233proc gencss {} { 234 set hBd "1px dotted #11577b" 235 return " 236body, div, p, th, td, li, dd, ul, ol, dl, dt, blockquote { 237 font-family: Verdana, sans-serif; 238} 239 240pre, code { font-family: 'Courier New', Courier, monospace; } 241 242pre { 243 background-color: #f6fcec; 244 border-top: 1px solid #6A6A6A; 245 border-bottom: 1px solid #6A6A6A; 246 padding: 1em; 247 overflow: auto; 248} 249 250body { 251 background-color: #FFFFFF; 252 font-size: 12px; 253 line-height: 1.25; 254 letter-spacing: .2px; 255 padding-left: .5em; 256} 257 258h1, h2, h3, h4 { 259 font-family: Georgia, serif; 260 padding-left: 1em; 261 margin-top: 1em; 262} 263 264h1 { 265 font-size: 18px; 266 color: #11577b; 267 border-bottom: $hBd; 268 margin-top: 0px; 269} 270 271h2 { 272 font-size: 14px; 273 color: #11577b; 274 background-color: #c5dce8; 275 padding-left: 1em; 276 border: 1px solid #6A6A6A; 277} 278 279h3, h4 { 280 color: #1674A4; 281 background-color: #e8f2f6; 282 border-bottom: $hBd; 283 border-top: $hBd; 284} 285 286h3 { font-size: 12px; } 287h4 { font-size: 11px; } 288 289.keylist dt, .arguments dt { 290 width: 20em; 291 float: left; 292 padding: 2px; 293 border-top: 1px solid #999; 294} 295 296.keylist dt { font-weight: bold; } 297 298.keylist dd, .arguments dd { 299 margin-left: 20em; 300 padding: 2px; 301 border-top: 1px solid #999; 302} 303 304.copy { 305 background-color: #f6fcfc; 306 white-space: pre; 307 font-size: 80%; 308 border-top: 1px solid #6A6A6A; 309 margin-top: 2em; 310} 311" 312} 313 314## 315## parsing 316## 317proc unquote arg { 318 return [string map [list \" {}] $arg] 319} 320 321proc parse-directive {line codename restname} { 322 upvar 1 $codename code $restname rest 323 return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] 324} 325 326proc htmlize-text {text {charmap {}}} { 327 # contains some extras for use in nroff->html processing 328 # build on the list passed in, if any 329 lappend charmap \ 330 {&} {&} \ 331 {\\} "\" \ 332 {\e} "\" \ 333 {\ } { } \ 334 {\|} { } \ 335 {\0} { } \ 336 \" {"} \ 337 {<} {<} \ 338 {>} {>} \ 339 \u201c "“" \ 340 \u201d "”" 341 342 return [string map $charmap $text] 343} 344 345proc process-text {text} { 346 global manual 347 # preprocess text 348 set charmap [list \ 349 {\&} "\t" \ 350 {\%} {} \ 351 "\\\n" "\n" \ 352 {\(+-} "±" \ 353 {\(co} "©" \ 354 {\(em} "—" \ 355 {\(fm} "′" \ 356 {\(mu} "×" \ 357 {\(->} "<font size=\"+1\">→</font>" \ 358 {\fP} {\fR} \ 359 {\.} . \ 360 {\(bu} "•" \ 361 ] 362 lappend charmap {\o'o^'} {ô} ; # o-circumflex in re_syntax.n 363 lappend charmap {\-\|\-} -- ; # two hyphens 364 lappend charmap {\-} - ; # a hyphen 365 366 set text [htmlize-text $text $charmap] 367 # General quoted entity 368 regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text 369 while {[string first "\\" $text] >= 0} { 370 # C R 371 if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \ 372 {\1<TT>\2</TT>\3} text]} continue 373 # B R 374 if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \ 375 {\1<B>\2</B>\3} text]} continue 376 # B I 377 if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \ 378 {\1<B>\2</B>\\fI\3} text]} continue 379 # I R 380 if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \ 381 {\1<I>\2</I>\3} text]} continue 382 # I B 383 if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \ 384 {\1<I>\2</I>\\fB\3} text]} continue 385 # B B, I I, R R 386 if { 387 [regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \ 388 {\1\\fB\2\3} ntext] 389 || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \ 390 {\1\\fI\2\3} ntext] 391 || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \ 392 {\1\\fR\2\3} ntext] 393 } then { 394 manerror "impotent font change: $text" 395 set text $ntext 396 continue 397 } 398 # unrecognized 399 manerror "uncaught backslash: $text" 400 set text [string map [list "\\" "\"] $text] 401 } 402 return $text 403} 404## 405## pass 2 text input and matching 406## 407proc open-text {} { 408 global manual 409 set manual(text-length) [llength $manual(text)] 410 set manual(text-pointer) 0 411} 412proc more-text {} { 413 global manual 414 return [expr {$manual(text-pointer) < $manual(text-length)}] 415} 416proc next-text {} { 417 global manual 418 if {[more-text]} { 419 set text [lindex $manual(text) $manual(text-pointer)] 420 incr manual(text-pointer) 421 return $text 422 } 423 manerror "read past end of text" 424 error "fatal" 425} 426proc is-a-directive {line} { 427 return [string match .* $line] 428} 429proc split-directive {line opname restname} { 430 upvar 1 $opname op $restname rest 431 set op [string range $line 0 2] 432 set rest [string trim [string range $line 3 end]] 433} 434proc next-op-is {op restname} { 435 global manual 436 upvar 1 $restname rest 437 if {[more-text]} { 438 set text [lindex $manual(text) $manual(text-pointer)] 439 if {[string equal -length 3 $text $op]} { 440 set rest [string range $text 4 end] 441 incr manual(text-pointer) 442 return 1 443 } 444 } 445 return 0 446} 447proc backup-text {n} { 448 global manual 449 if {$manual(text-pointer)-$n >= 0} { 450 incr manual(text-pointer) -$n 451 } 452} 453proc match-text args { 454 global manual 455 set nargs [llength $args] 456 if {$manual(text-pointer) + $nargs > $manual(text-length)} { 457 return 0 458 } 459 set nback 0 460 foreach arg $args { 461 if {![more-text]} { 462 backup-text $nback 463 return 0 464 } 465 set arg [string trim $arg] 466 set targ [string trim [lindex $manual(text) $manual(text-pointer)]] 467 if {$arg eq $targ} { 468 incr nback 469 incr manual(text-pointer) 470 continue 471 } 472 if {[regexp {^@(\w+)$} $arg all name]} { 473 upvar 1 $name var 474 set var $targ 475 incr nback 476 incr manual(text-pointer) 477 continue 478 } 479 if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\ 480 && [string equal $op [lindex $targ 0]]} { 481 upvar 1 $name var 482 set var [lrange $targ 1 end] 483 incr nback 484 incr manual(text-pointer) 485 continue 486 } 487 backup-text $nback 488 return 0 489 } 490 return 1 491} 492proc expand-next-text {n} { 493 global manual 494 return [join [lrange $manual(text) $manual(text-pointer) \ 495 [expr {$manual(text-pointer)+$n-1}]] \n\n] 496} 497## 498## pass 2 output 499## 500proc man-puts {text} { 501 global manual 502 lappend manual(output-$manual(wing-file)-$manual(name)) $text 503} 504 505## 506## build hypertext links to tables of contents 507## 508proc long-toc {text} { 509 global manual 510 set here M[incr manual(section-toc-n)] 511 set there L[incr manual(long-toc-n)] 512 lappend manual(section-toc) \ 513 "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>" 514 return "<A NAME=\"$here\">$text</A>" 515} 516proc option-toc {name class switch} { 517 global manual 518 if {[string match "*OPTIONS" $manual(section)]} { 519 if { 520 $manual(name) ne "ttk_widget" 521 && $manual(section) ne "WIDGET-SPECIFIC OPTIONS" 522 } then { 523 # link the defined option into the long table of contents 524 set link [long-toc "$switch, $name, $class"] 525 regsub -- "$switch, $name, $class" $link "$switch" link 526 return $link 527 } 528 } elseif {"$manual(name):$manual(section)" ne "options:DESCRIPTION"} { 529 error "option-toc in $manual(name) section $manual(section)" 530 } 531 532 # link the defined standard option to the long table of contents and make 533 # a target for the standard option references from other man pages. 534 535 set first [lindex $switch 0] 536 set here M$first 537 set there L[incr manual(long-toc-n)] 538 set manual(standard-option-$manual(name)-$first) \ 539 "<A HREF=\"$manual(name).htm#$here\">$switch, $name, $class</A>" 540 lappend manual(section-toc) \ 541 "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>" 542 return "<A NAME=\"$here\">$switch</A>" 543} 544proc std-option-toc {name page} { 545 global manual 546 if {[info exists manual(standard-option-$page-$name)]} { 547 lappend manual(section-toc) <DD>$manual(standard-option-$page-$name) 548 return $manual(standard-option-$page-$name) 549 } 550 manerror "missing reference to \"$name\" in $page.n" 551 set here M[incr manual(section-toc-n)] 552 set there L[incr manual(long-toc-n)] 553 set other M$name 554 lappend manual(section-toc) "<DD><A HREF=\"$page.htm#$other\">$name</A>" 555 return "<A HREF=\"$page.htm#$other\">$name</A>" 556} 557## 558## process the widget option section 559## in widget and options man pages 560## 561proc output-widget-options {rest} { 562 global manual 563 man-puts <DL> 564 lappend manual(section-toc) <DL> 565 backup-text 1 566 set para {} 567 while {[next-op-is .OP rest]} { 568 switch -exact -- [llength $rest] { 569 3 { 570 lassign $rest switch name class 571 } 572 5 { 573 set switch [lrange $rest 0 2] 574 set name [lindex $rest 3] 575 set class [lindex $rest 4] 576 } 577 default { 578 fatal "bad .OP $rest" 579 } 580 } 581 if {![regexp {^(<.>)([-\w ]+)(</.>)$} $switch \ 582 all oswitch switch cswitch]} { 583 if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)(</.>)$} $switch \ 584 all oswitch switch1 switch2 cswitch]} { 585 error "not Switch: $switch" 586 } 587 set switch "$switch1$cswitch or $oswitch$switch2" 588 } 589 if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} { 590 error "not Name: $name" 591 } 592 if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} { 593 error "not Class: $class" 594 } 595 man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch" 596 man-puts "<DT>Database Name: $oname$name$cname" 597 man-puts "<DT>Database Class: $oclass$class$cclass" 598 man-puts <DD>[next-text] 599 set para <P> 600 601 if {[next-op-is .RS rest]} { 602 while {[more-text]} { 603 set line [next-text] 604 if {[is-a-directive $line]} { 605 split-directive $line code rest 606 switch -exact -- $code { 607 .RE { 608 break 609 } 610 .SH - .SS { 611 manerror "unbalanced .RS at section end" 612 backup-text 1 613 break 614 } 615 default { 616 output-directive $line 617 } 618 } 619 } else { 620 man-puts $line 621 } 622 } 623 } 624 } 625 man-puts </DL> 626 lappend manual(section-toc) </DL> 627} 628 629## 630## process .RS lists 631## 632proc output-RS-list {} { 633 global manual 634 if {[next-op-is .IP rest]} { 635 output-IP-list .RS .IP $rest 636 if {[match-text .RE .sp .RS @rest .IP @rest2]} { 637 man-puts <P>$rest 638 output-IP-list .RS .IP $rest2 639 } 640 if {[match-text .RE .sp .RS @rest .RE]} { 641 man-puts <P>$rest 642 return 643 } 644 if {[next-op-is .RE rest]} { 645 return 646 } 647 } 648 man-puts <DL><DD> 649 while {[more-text]} { 650 set line [next-text] 651 if {[is-a-directive $line]} { 652 split-directive $line code rest 653 switch -exact -- $code { 654 .RE { 655 break 656 } 657 .SH - .SS { 658 manerror "unbalanced .RS at section end" 659 backup-text 1 660 break 661 } 662 default { 663 output-directive $line 664 } 665 } 666 } else { 667 man-puts $line 668 } 669 } 670 man-puts </DL> 671} 672 673## 674## process .IP lists which may be plain indents, 675## numeric lists, or definition lists 676## 677proc output-IP-list {context code rest} { 678 global manual 679 if {![string length $rest]} { 680 # blank label, plain indent, no contents entry 681 man-puts <DL><DD> 682 while {[more-text]} { 683 set line [next-text] 684 if {[is-a-directive $line]} { 685 split-directive $line code rest 686 if {$code eq ".IP" && $rest eq {}} { 687 man-puts "<P>" 688 continue 689 } 690 if {$code in {.br .DS .RS}} { 691 output-directive $line 692 } else { 693 backup-text 1 694 break 695 } 696 } else { 697 man-puts $line 698 } 699 } 700 man-puts </DL> 701 } else { 702 # labelled list, make contents 703 if {$context ne ".SH" && $context ne ".SS"} { 704 man-puts <P> 705 } 706 set dl "<DL class=\"[string tolower $manual(section)]\">" 707 man-puts $dl 708 lappend manual(section-toc) $dl 709 backup-text 1 710 set accept_RE 0 711 set para {} 712 while {[more-text]} { 713 set line [next-text] 714 if {[is-a-directive $line]} { 715 split-directive $line code rest 716 switch -exact -- $code { 717 .IP { 718 if {$accept_RE} { 719 output-IP-list .IP $code $rest 720 continue 721 } 722 if {$manual(section) eq "ARGUMENTS" || \ 723 [regexp {^\[\d+\]$} $rest]} { 724 man-puts "$para<DT>$rest<DD>" 725 } elseif {"•" eq $rest} { 726 man-puts "$para<DT><DD>$rest " 727 } else { 728 man-puts "$para<DT>[long-toc $rest]<DD>" 729 } 730 if {"$manual(name):$manual(section)" eq \ 731 "selection:DESCRIPTION"} { 732 if {[match-text .RE @rest .RS .RS]} { 733 man-puts <DT>[long-toc $rest]<DD> 734 } 735 } 736 } 737 .sp - .br - .DS - .CS { 738 output-directive $line 739 } 740 .RS { 741 if {[match-text .RS]} { 742 output-directive $line 743 incr accept_RE 1 744 } elseif {[match-text .CS]} { 745 output-directive .CS 746 incr accept_RE 1 747 } elseif {[match-text .PP]} { 748 output-directive .PP 749 incr accept_RE 1 750 } elseif {[match-text .DS]} { 751 output-directive .DS 752 incr accept_RE 1 753 } else { 754 output-directive $line 755 } 756 } 757 .PP { 758 if {[match-text @rest1 .br @rest2 .RS]} { 759 # yet another nroff kludge as above 760 man-puts "$para<DT>[long-toc $rest1]" 761 man-puts "<DT>[long-toc $rest2]<DD>" 762 incr accept_RE 1 763 } elseif {[match-text @rest .RE]} { 764 # gad, this is getting ridiculous 765 if {!$accept_RE} { 766 man-puts "</DL><P>$rest<DL>" 767 backup-text 1 768 set para {} 769 break 770 } else { 771 man-puts "<P>$rest" 772 incr accept_RE -1 773 } 774 } elseif {$accept_RE} { 775 output-directive $line 776 } else { 777 backup-text 1 778 break 779 } 780 } 781 .RE { 782 if {!$accept_RE} { 783 backup-text 1 784 break 785 } 786 incr accept_RE -1 787 } 788 default { 789 backup-text 1 790 break 791 } 792 } 793 } else { 794 man-puts $line 795 } 796 set para <P> 797 } 798 man-puts "$para</DL>" 799 lappend manual(section-toc) </DL> 800 if {$accept_RE} { 801 manerror "missing .RE in output-IP-list" 802 } 803 } 804} 805## 806## handle the NAME section lines 807## there's only one line in the NAME section, 808## consisting of a comma separated list of names, 809## followed by a hyphen and a short description. 810## 811proc output-name {line} { 812 global manual 813 # split name line into pieces 814 regexp {^([^-]+) - (.*)$} $line all head tail 815 # output line to manual page untouched 816 man-puts $line 817 # output line to long table of contents 818 lappend manual(section-toc) <DL><DD>$line</DD></DL> 819 # separate out the names for future reference 820 foreach name [split $head ,] { 821 set name [string trim $name] 822 if {[llength $name] > 1} { 823 manerror "name has a space: {$name}\nfrom: $line" 824 } 825 lappend manual(wing-toc) $name 826 lappend manual(name-$name) $manual(wing-file)/$manual(name) 827 } 828} 829## 830## build a cross-reference link if appropriate 831## 832proc cross-reference {ref} { 833 global manual 834 if {[string match "Tcl_*" $ref]} { 835 set lref $ref 836 } elseif {[string match "Tk_*" $ref]} { 837 set lref $ref 838 } elseif {$ref eq "Tcl"} { 839 set lref $ref 840 } else { 841 set lref [string tolower $ref] 842 } 843 ## 844 ## nothing to reference 845 ## 846 if {![info exists manual(name-$lref)]} { 847 foreach name { 848 array file history info interp string trace after clipboard grab 849 image option pack place selection tk tkwait update winfo wm 850 } { 851 if {[regexp "^$name \[a-z0-9]*\$" $lref] && \ 852 [info exists manual(name-$name)] && \ 853 $manual(tail) ne "$name.n"} { 854 return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>" 855 } 856 } 857 if {$lref in {stdin stdout stderr end}} { 858 # no good place to send these 859 # tcl tokens? 860 # also end 861 } 862 return $ref 863 } 864 ## 865 ## would be a self reference 866 ## 867 foreach name $manual(name-$lref) { 868 if {"$manual(wing-file)/$manual(name)" in $name} { 869 return $ref 870 } 871 } 872 ## 873 ## multiple choices for reference 874 ## 875 if {[llength $manual(name-$lref)] > 1} { 876 set tcl_i [lsearch -glob $manual(name-$lref) *TclCmd*] 877 set tcl_ref [lindex $manual(name-$lref) $tcl_i] 878 set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*] 879 set tk_ref [lindex $manual(name-$lref) $tk_i] 880 if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd" 881 || $manual(wing-file) eq "TclLib"} { 882 return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" 883 } 884 if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd" 885 || $manual(wing-file) eq "TkLib"} { 886 return "<A HREF=\"../$tk_ref.htm\">$ref</A>" 887 } 888 if {$lref eq "exit" && $manual(tail) eq "tclsh.1" && $tcl_i >= 0} { 889 return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" 890 } 891 puts stderr "multiple cross reference to $ref in $manual(name-$lref) from $manual(wing-file)/$manual(tail)" 892 return $ref 893 } 894 ## 895 ## exceptions, sigh, to the rule 896 ## 897 switch -exact -- $manual(tail) { 898 canvas.n { 899 if {$lref eq "focus"} { 900 upvar 1 tail tail 901 set clue [string first command $tail] 902 if {$clue < 0 || $clue > 5} { 903 return $ref 904 } 905 } 906 if {$lref in {bitmap image text}} { 907 return $ref 908 } 909 } 910 checkbutton.n - radiobutton.n { 911 if {$lref in {image}} { 912 return $ref 913 } 914 } 915 menu.n { 916 if {$lref in {checkbutton radiobutton}} { 917 return $ref 918 } 919 } 920 options.n { 921 if {$lref in {bitmap image set}} { 922 return $ref 923 } 924 } 925 regexp.n { 926 if {$lref in {string}} { 927 return $ref 928 } 929 } 930 source.n { 931 if {$lref in {text}} { 932 return $ref 933 } 934 } 935 history.n { 936 if {$lref in {exec}} { 937 return $ref 938 } 939 } 940 return.n { 941 if {$lref in {error continue break}} { 942 return $ref 943 } 944 } 945 scrollbar.n { 946 if {$lref in {set}} { 947 return $ref 948 } 949 } 950 } 951 ## 952 ## return the cross reference 953 ## 954 return "<A HREF=\"../$manual(name-$lref).htm\">$ref</A>" 955} 956## 957## reference generation errors 958## 959proc reference-error {msg text} { 960 global manual 961 puts stderr "$manual(tail): $msg: {$text}" 962 return $text 963} 964## 965## insert as many cross references into this text string as are appropriate 966## 967proc insert-cross-references {text} { 968 global manual 969 ## 970 ## we identify cross references by: 971 ## ``quotation'' 972 ## <B>emboldening</B> 973 ## Tcl_ prefix 974 ## Tk_ prefix 975 ## [a-zA-Z0-9]+ manual entry 976 ## and we avoid messing with already anchored text 977 ## 978 ## 979 ## find where each item lives 980 ## 981 array set offset [list \ 982 anchor [string first {<A } $text] \ 983 end-anchor [string first {</A>} $text] \ 984 quote [string first {``} $text] \ 985 end-quote [string first {''} $text] \ 986 bold [string first {<B>} $text] \ 987 end-bold [string first {</B>} $text] \ 988 tcl [string first {Tcl_} $text] \ 989 tk [string first {Tk_} $text] \ 990 Tcl1 [string first {Tcl manual entry} $text] \ 991 Tcl2 [string first {Tcl overview manual entry} $text] \ 992 ] 993 ## 994 ## accumulate a list 995 ## 996 foreach name [array names offset] { 997 if {$offset($name) >= 0} { 998 set invert($offset($name)) $name 999 lappend offsets $offset($name) 1000 } 1001 } 1002 ## 1003 ## if nothing, then we're done. 1004 ## 1005 if {![info exists offsets]} { 1006 return $text 1007 } 1008 ## 1009 ## sort the offsets 1010 ## 1011 set offsets [lsort -integer $offsets] 1012 ## 1013 ## see which we want to use 1014 ## 1015 switch -exact -- $invert([lindex $offsets 0]) { 1016 anchor { 1017 if {$offset(end-anchor) < 0} { 1018 return [reference-error {Missing end anchor} $text] 1019 } 1020 set head [string range $text 0 $offset(end-anchor)] 1021 set tail [string range $text [expr {$offset(end-anchor)+1}] end] 1022 return $head[insert-cross-references $tail] 1023 } 1024 quote { 1025 if {$offset(end-quote) < 0} { 1026 return [reference-error "Missing end quote" $text] 1027 } 1028 if {$invert([lindex $offsets 1]) eq "tk"} { 1029 set offsets [lreplace $offsets 1 1] 1030 } 1031 if {$invert([lindex $offsets 1]) eq "tcl"} { 1032 set offsets [lreplace $offsets 1 1] 1033 } 1034 switch -exact -- $invert([lindex $offsets 1]) { 1035 end-quote { 1036 set head [string range $text 0 [expr {$offset(quote)-1}]] 1037 set body [string range $text [expr {$offset(quote)+2}] \ 1038 [expr {$offset(end-quote)-1}]] 1039 set tail [string range $text \ 1040 [expr {$offset(end-quote)+2}] end] 1041 return "$head``[cross-reference $body]''[insert-cross-references $tail]" 1042 } 1043 bold - 1044 anchor { 1045 set head [string range $text \ 1046 0 [expr {$offset(end-quote)+1}]] 1047 set tail [string range $text \ 1048 [expr {$offset(end-quote)+2}] end] 1049 return "$head[insert-cross-references $tail]" 1050 } 1051 } 1052 return [reference-error "Uncaught quote case" $text] 1053 } 1054 bold { 1055 if {$offset(end-bold) < 0} { 1056 return $text 1057 } 1058 if {$invert([lindex $offsets 1]) eq "tk"} { 1059 set offsets [lreplace $offsets 1 1] 1060 } 1061 if {$invert([lindex $offsets 1]) eq "tcl"} { 1062 set offsets [lreplace $offsets 1 1] 1063 } 1064 switch -exact -- $invert([lindex $offsets 1]) { 1065 end-bold { 1066 set head [string range $text 0 [expr {$offset(bold)-1}]] 1067 set body [string range $text [expr {$offset(bold)+3}] \ 1068 [expr {$offset(end-bold)-1}]] 1069 set tail [string range $text \ 1070 [expr {$offset(end-bold)+4}] end] 1071 return "$head<B>[cross-reference $body]</B>[insert-cross-references $tail]" 1072 } 1073 anchor { 1074 set head [string range $text \ 1075 0 [expr {$offset(end-bold)+3}]] 1076 set tail [string range $text \ 1077 [expr {$offset(end-bold)+4}] end] 1078 return "$head[insert-cross-references $tail]" 1079 } 1080 } 1081 return [reference-error "Uncaught bold case" $text] 1082 } 1083 tk { 1084 set head [string range $text 0 [expr {$offset(tk)-1}]] 1085 set tail [string range $text $offset(tk) end] 1086 if {![regexp {^(Tk_\w+)(.*)$} $tail all body tail]} { 1087 return [reference-error "Tk regexp failed" $text] 1088 } 1089 return $head[cross-reference $body][insert-cross-references $tail] 1090 } 1091 tcl { 1092 set head [string range $text 0 [expr {$offset(tcl)-1}]] 1093 set tail [string range $text $offset(tcl) end] 1094 if {![regexp {^(Tcl_\w+)(.*)$} $tail all body tail]} { 1095 return [reference-error {Tcl regexp failed} $text] 1096 } 1097 return $head[cross-reference $body][insert-cross-references $tail] 1098 } 1099 Tcl1 - 1100 Tcl2 { 1101 set off [lindex $offsets 0] 1102 set head [string range $text 0 [expr {$off-1}]] 1103 set body Tcl 1104 set tail [string range $text [expr {$off+3}] end] 1105 return $head[cross-reference $body][insert-cross-references $tail] 1106 } 1107 end-anchor - 1108 end-bold - 1109 end-quote { 1110 return [reference-error "Out of place $invert([lindex $offsets 0])" $text] 1111 } 1112 } 1113} 1114## 1115## process formatting directives 1116## 1117proc output-directive {line} { 1118 global manual 1119 # process format directive 1120 split-directive $line code rest 1121 switch -exact -- $code { 1122 .BS - .BE { 1123 # man-puts <HR> 1124 } 1125 .SH - .SS { 1126 # drain any open lists 1127 # announce the subject 1128 set manual(section) $rest 1129 # start our own stack of stuff 1130 set manual($manual(name)-$manual(section)) {} 1131 lappend manual(has-$manual(section)) $manual(name) 1132 if {$code ne ".SS"} { 1133 man-puts "<H3>[long-toc $manual(section)]</H3>" 1134 } else { 1135 man-puts "<H4>[long-toc $manual(section)]</H4>" 1136 } 1137 # some sections can simply free wheel their way through the text 1138 # some sections can be processed in their own loops 1139 switch -exact -- $manual(section) { 1140 NAME { 1141 if {$manual(tail) in {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3}} { 1142 # these manual pages have two NAME sections 1143 if {[info exists manual($manual(tail)-NAME)]} { 1144 return 1145 } 1146 set manual($manual(tail)-NAME) 1 1147 } 1148 set names {} 1149 while {1} { 1150 set line [next-text] 1151 if {[is-a-directive $line]} { 1152 backup-text 1 1153 output-name [join $names { }] 1154 return 1155 } else { 1156 lappend names [string trim $line] 1157 } 1158 } 1159 } 1160 SYNOPSIS { 1161 lappend manual(section-toc) <DL> 1162 while {1} { 1163 if { 1164 [next-op-is .nf rest] 1165 || [next-op-is .br rest] 1166 || [next-op-is .fi rest] 1167 } then { 1168 continue 1169 } 1170 if { 1171 [next-op-is .SH rest] 1172 || [next-op-is .SS rest] 1173 || [next-op-is .BE rest] 1174 || [next-op-is .SO rest] 1175 } then { 1176 backup-text 1 1177 break 1178 } 1179 if {[next-op-is .sp rest]} { 1180 #man-puts <P> 1181 continue 1182 } 1183 set more [next-text] 1184 if {[is-a-directive $more]} { 1185 manerror "in SYNOPSIS found $more" 1186 backup-text 1 1187 break 1188 } 1189 foreach more [split $more \n] { 1190 man-puts $more<BR> 1191 if {$manual(wing-file) in {TclLib TkLib}} { 1192 lappend manual(section-toc) <DD>$more 1193 } 1194 } 1195 } 1196 lappend manual(section-toc) </DL> 1197 return 1198 } 1199 {SEE ALSO} { 1200 while {[more-text]} { 1201 if {[next-op-is .SH rest] || [next-op-is .SS rest]} { 1202 backup-text 1 1203 return 1204 } 1205 set more [next-text] 1206 if {[is-a-directive $more]} { 1207 manerror "$more" 1208 backup-text 1 1209 return 1210 } 1211 set nmore {} 1212 foreach cr [split $more ,] { 1213 set cr [string trim $cr] 1214 if {![regexp {^<B>.*</B>$} $cr]} { 1215 set cr <B>$cr</B> 1216 } 1217 if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} { 1218 set cr <B>$name</B> 1219 } 1220 lappend nmore $cr 1221 } 1222 man-puts [join $nmore {, }] 1223 } 1224 return 1225 } 1226 KEYWORDS { 1227 while {[more-text]} { 1228 if {[next-op-is .SH rest] || [next-op-is .SS rest]} { 1229 backup-text 1 1230 return 1231 } 1232 set more [next-text] 1233 if {[is-a-directive $more]} { 1234 manerror "$more" 1235 backup-text 1 1236 return 1237 } 1238 set keys {} 1239 foreach key [split $more ,] { 1240 set key [string trim $key] 1241 lappend manual(keyword-$key) [list $manual(name) $manual(wing-file)/$manual(name).htm] 1242 set initial [string toupper [string index $key 0]] 1243 lappend keys "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>" 1244 } 1245 man-puts [join $keys {, }] 1246 } 1247 return 1248 } 1249 } 1250 if {[next-op-is .IP rest]} { 1251 output-IP-list $code .IP $rest 1252 return 1253 } 1254 if {[next-op-is .PP rest]} { 1255 return 1256 } 1257 return 1258 } 1259 .SO { 1260 set targetPage $rest 1261 if {[match-text @stuff .SE]} { 1262 output-directive {.SH STANDARD OPTIONS} 1263 set opts [split $stuff \n\t] 1264 man-puts <DL> 1265 lappend manual(section-toc) <DL> 1266 foreach option [lsort -dictionary $opts] { 1267 man-puts "<DT><B>[std-option-toc $option $targetPage]</B>" 1268 } 1269 man-puts </DL> 1270 lappend manual(section-toc) </DL> 1271 } else { 1272 manerror "unexpected .SO format:\n[expand-next-text 2]" 1273 } 1274 } 1275 .OP { 1276 output-widget-options $rest 1277 return 1278 } 1279 .IP { 1280 output-IP-list .IP .IP $rest 1281 return 1282 } 1283 .PP { 1284 man-puts <P> 1285 } 1286 .RS { 1287 output-RS-list 1288 return 1289 } 1290 .RE { 1291 manerror "unexpected .RE" 1292 return 1293 } 1294 .br { 1295 man-puts <BR> 1296 return 1297 } 1298 .DE { 1299 manerror "unexpected .DE" 1300 return 1301 } 1302 .DS { 1303 if {[next-op-is .ta rest]} { 1304 # skip the leading .ta directive if it is there 1305 } 1306 if {[match-text @stuff .DE]} { 1307 set td "<td><p style=\"font-size:12px;padding-left:.5em;padding-right:.5em;\">" 1308 set bodyText [string map [list \n <tr>$td \t $td] \n$stuff] 1309 man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>" 1310 #man-puts <PRE>$stuff</PRE> 1311 } elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} { 1312 man-puts "<PRE>[lindex $ul1 1][lindex $ul2 1]\n$stuff</PRE>" 1313 } else { 1314 manerror "unexpected .DS format:\n[expand-next-text 2]" 1315 } 1316 return 1317 } 1318 .CS { 1319 if {[next-op-is .ta rest]} { 1320 # ??? 1321 } 1322 if {[match-text @stuff .CE]} { 1323 man-puts <PRE>$stuff</PRE> 1324 } else { 1325 manerror "unexpected .CS format:\n[expand-next-text 2]" 1326 } 1327 return 1328 } 1329 .CE { 1330 manerror "unexpected .CE" 1331 return 1332 } 1333 .sp { 1334 man-puts <P> 1335 } 1336 .ta { 1337 # these are tab stop settings for short tables 1338 switch -exact -- $manual(name):$manual(section) { 1339 {bind:MODIFIERS} - 1340 {bind:EVENT TYPES} - 1341 {bind:BINDING SCRIPTS AND SUBSTITUTIONS} - 1342 {expr:OPERANDS} - 1343 {expr:MATH FUNCTIONS} - 1344 {history:DESCRIPTION} - 1345 {history:HISTORY REVISION} - 1346 {switch:DESCRIPTION} - 1347 {upvar:DESCRIPTION} { 1348 return; # fix.me 1349 } 1350 default { 1351 manerror "ignoring $line" 1352 } 1353 } 1354 } 1355 .nf { 1356 if {[match-text @more .fi]} { 1357 foreach more [split $more \n] { 1358 man-puts $more<BR> 1359 } 1360 } elseif {[match-text .RS @more .RE .fi]} { 1361 man-puts <DL><DD> 1362 foreach more [split $more \n] { 1363 man-puts $more<BR> 1364 } 1365 man-puts </DL> 1366 } elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} { 1367 man-puts <DL><DD> 1368 foreach more [split $more \n] { 1369 man-puts $more<BR> 1370 } 1371 man-puts <DL><DD> 1372 foreach more2 [split $more2 \n] { 1373 man-puts $more2<BR> 1374 } 1375 man-puts </DL></DL> 1376 } elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} { 1377 man-puts <DL><DD> 1378 foreach more [split $more \n] { 1379 man-puts $more<BR> 1380 } 1381 man-puts <DL><DD> 1382 foreach more2 [split $more2 \n] { 1383 man-puts $more2<BR> 1384 } 1385 man-puts </DL><DD> 1386 foreach more3 [split $more3 \n] { 1387 man-puts $more3<BR> 1388 } 1389 man-puts </DL> 1390 } elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} { 1391 man-puts <P><DL><DD> 1392 foreach more [split $more \n] { 1393 man-puts $more<BR> 1394 } 1395 man-puts <DL><DD> 1396 foreach more2 [split $more2 \n] { 1397 man-puts $more2<BR> 1398 } 1399 man-puts </DL></DL><P> 1400 } elseif {[match-text .RS .sp @more .sp .RE .fi]} { 1401 man-puts <P><DL><DD> 1402 foreach more [split $more \n] { 1403 man-puts $more<BR> 1404 } 1405 man-puts </DL><P> 1406 } else { 1407 manerror "ignoring $line" 1408 } 1409 } 1410 .fi { 1411 manerror "ignoring $line" 1412 } 1413 .na - 1414 .ad - 1415 .UL - 1416 .ne { 1417 manerror "ignoring $line" 1418 } 1419 default { 1420 manerror "unrecognized format directive: $line" 1421 } 1422 } 1423} 1424## 1425## merge copyright listings 1426## 1427proc merge-copyrights {l1 l2} { 1428 set merge {} 1429 set re1 {^Copyright +(?:\(c\)|\\\(co|©) +(\w.*?)(?:all rights reserved)?(?:\. )*$} 1430 set re2 {^(\d+) +(?:by +)?(\w.*)$} ;# date who 1431 set re3 {^(\d+)-(\d+) +(?:by +)?(\w.*)$} ;# from to who 1432 set re4 {^(\d+), *(\d+) +(?:by +)?(\w.*)$} ;# date1 date2 who 1433 foreach copyright [concat $l1 $l2] { 1434 if {[regexp -nocase -- $re1 $copyright -> info]} { 1435 set info [string trimright $info ". "] ; # remove extra period 1436 if {[regexp -- $re2 $info -> date who]} { 1437 lappend dates($who) $date 1438 continue 1439 } elseif {[regexp -- $re3 $info -> from to who]} { 1440 for {set date $from} {$date <= $to} {incr date} { 1441 lappend dates($who) $date 1442 } 1443 continue 1444 } elseif {[regexp -- $re3 $info -> date1 date2 who]} { 1445 lappend dates($who) $date1 $date2 1446 continue 1447 } 1448 } 1449 puts "oops: $copyright" 1450 } 1451 foreach who [array names dates] { 1452 set list [lsort -dictionary $dates($who)] 1453 if {[llength $list] == 1 || [lindex $list 0] eq [lrange $list end end]} { 1454 lappend merge "Copyright © [lindex $list 0] $who" 1455 } else { 1456 lappend merge "Copyright © [lindex $list 0]-[lrange $list end end] $who" 1457 } 1458 } 1459 return [lsort -dictionary $merge] 1460} 1461 1462proc makedirhier {dir} { 1463 if {![file isdirectory $dir] && \ 1464 [catch {file mkdir $dir} error]} { 1465 return -code error "cannot create directory $dir: $error" 1466 } 1467} 1468 1469proc addbuffer {args} { 1470 global manual 1471 if {$manual(partial-text) ne ""} { 1472 append manual(partial-text) \n 1473 } 1474 append manual(partial-text) [join $args ""] 1475} 1476proc flushbuffer {} { 1477 global manual 1478 if {$manual(partial-text) ne ""} { 1479 lappend manual(text) [process-text $manual(partial-text)] 1480 set manual(partial-text) "" 1481 } 1482} 1483 1484## 1485## foreach of the man directories specified by args 1486## convert manpages into hypertext in the directory 1487## specified by html. 1488## 1489proc make-man-pages {html args} { 1490 global manual overall_title tcltkdesc 1491 makedirhier $html 1492 set cssfd [open $html/$::CSSFILE w] 1493 puts $cssfd [gencss] 1494 close $cssfd 1495 set manual(short-toc-n) 1 1496 set manual(short-toc-fp) [open $html/[indexfile] w] 1497 puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title] 1498 puts $manual(short-toc-fp) "<DL class=\"keylist\">" 1499 set manual(merge-copyrights) {} 1500 foreach arg $args { 1501 # preprocess to set up subheader for the rest of the files 1502 if {![llength $arg]} { 1503 continue 1504 } 1505 set name [lindex $arg 1] 1506 set file [lindex $arg 2] 1507 lappend manual(subheader) $name $file 1508 } 1509 foreach arg $args { 1510 if {![llength $arg]} { 1511 continue 1512 } 1513 set manual(wing-glob) [lindex $arg 0] 1514 set manual(wing-name) [lindex $arg 1] 1515 set manual(wing-file) [lindex $arg 2] 1516 set manual(wing-description) [lindex $arg 3] 1517 set manual(wing-copyrights) {} 1518 makedirhier $html/$manual(wing-file) 1519 set manual(wing-toc-fp) [open $html/$manual(wing-file)/[indexfile] w] 1520 # whistle 1521 puts stderr "scanning section $manual(wing-name)" 1522 # put the entry for this section into the short table of contents 1523 puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>" 1524 # initialize the wing table of contents 1525 puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \ 1526 $manual(wing-name) $overall_title "../[indexfile]"] 1527 # initialize the short table of contents for this section 1528 set manual(wing-toc) {} 1529 # initialize the man directory for this section 1530 makedirhier $html/$manual(wing-file) 1531 # initialize the long table of contents for this section 1532 set manual(long-toc-n) 1 1533 # get the manual pages for this section 1534 set manual(pages) [lsort -dictionary [glob $manual(wing-glob)]] 1535 set n [lsearch -glob $manual(pages) */ttk_widget.n] 1536 if {$n >= 0} { 1537 set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" 1538 } 1539 set n [lsearch -glob $manual(pages) */options.n] 1540 if {$n >= 0} { 1541 set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" 1542 } 1543 # set manual(pages) [lrange $manual(pages) 0 5] 1544 set LQ \u201c 1545 set RQ \u201d 1546 foreach manual_page $manual(pages) { 1547 set manual(page) $manual_page 1548 # whistle 1549 puts stderr "scanning page $manual(page)" 1550 set manual(tail) [file tail $manual(page)] 1551 set manual(name) [file root $manual(tail)] 1552 set manual(section) {} 1553 if {$manual(name) in {case pack-old menubar}} { 1554 # obsolete 1555 manerror "discarding $manual(name)" 1556 continue 1557 } 1558 set manual(infp) [open $manual(page)] 1559 set manual(text) {} 1560 set manual(partial-text) {} 1561 foreach p {.RS .DS .CS .SO} { 1562 set manual($p) 0 1563 } 1564 set manual(stack) {} 1565 set manual(section) {} 1566 set manual(section-toc) {} 1567 set manual(section-toc-n) 1 1568 set manual(copyrights) {} 1569 lappend manual(copyrights) "Copyright © 1995-1997 Roger E. Critchlow Jr." 1570 lappend manual(all-pages) $manual(wing-file)/$manual(tail) 1571 manreport 100 $manual(name) 1572 while {[gets $manual(infp) line] >= 0} { 1573 manreport 100 $line 1574 if {[regexp {^[`'][/\\]} $line]} { 1575 if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} { 1576 lappend manual(copyrights) $copyright 1577 } 1578 # comment 1579 continue 1580 } 1581 if {"$line" eq {'}} { 1582 # comment 1583 continue 1584 } 1585 if {![parse-directive $line code rest]} { 1586 addbuffer $line 1587 continue 1588 } 1589 switch -exact -- $code { 1590 .ad - .na - .so - .ne - .AS - .VE - .VS - . { 1591 # ignore 1592 continue 1593 } 1594 } 1595 switch -exact -- $code { 1596 .SH - .SS { 1597 flushbuffer 1598 if {[llength $rest] == 0} { 1599 gets $manual(infp) rest 1600 } 1601 lappend manual(text) "$code [unquote $rest]" 1602 } 1603 .TH { 1604 flushbuffer 1605 lappend manual(text) "$code [unquote $rest]" 1606 } 1607 .QW { 1608 set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] 1609 addbuffer $LQ [unquote [lindex $rest 0]] $RQ \ 1610 [unquote [lindex $rest 1]] 1611 } 1612 .PQ { 1613 set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] 1614 addbuffer ( $LQ [unquote [lindex $rest 0]] $RQ \ 1615 [unquote [lindex $rest 1]] ) \ 1616 [unquote [lindex $rest 2]] 1617 } 1618 .QR { 1619 set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] 1620 addbuffer $LQ [unquote [lindex $rest 0]] - \ 1621 [unquote [lindex $rest 1]] $RQ \ 1622 [unquote [lindex $rest 2]] 1623 } 1624 .MT { 1625 addbuffer $LQ$RQ 1626 } 1627 .HS - .UL - .ta { 1628 flushbuffer 1629 lappend manual(text) "$code [unquote $rest]" 1630 } 1631 .BS - .BE - .br - .fi - .sp - .nf { 1632 flushbuffer 1633 if {"$rest" ne {}} { 1634 manerror "unexpected argument: $line" 1635 } 1636 lappend manual(text) $code 1637 } 1638 .AP { 1639 flushbuffer 1640 lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]] 1641 } 1642 .IP { 1643 flushbuffer 1644 regexp {^(.*) +\d+$} $rest all rest 1645 lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]" 1646 } 1647 .TP { 1648 flushbuffer 1649 while {[is-a-directive [set next [gets $manual(infp)]]]} { 1650 manerror "ignoring $next after .TP" 1651 } 1652 if {"$next" ne {'}} { 1653 lappend manual(text) ".IP [process-text $next]" 1654 } 1655 } 1656 .OP { 1657 flushbuffer 1658 lappend manual(text) [concat .OP [process-text \ 1659 "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]] 1660 } 1661 .PP - .LP { 1662 flushbuffer 1663 lappend manual(text) {.PP} 1664 } 1665 .RS { 1666 flushbuffer 1667 incr manual(.RS) 1668 lappend manual(text) $code 1669 } 1670 .RE { 1671 flushbuffer 1672 incr manual(.RS) -1 1673 lappend manual(text) $code 1674 } 1675 .SO { 1676 flushbuffer 1677 incr manual(.SO) 1678 if {[llength $rest] == 0} { 1679 lappend manual(text) "$code options" 1680 } else { 1681 lappend manual(text) "$code [unquote $rest]" 1682 } 1683 } 1684 .SE { 1685 flushbuffer 1686 incr manual(.SO) -1 1687 lappend manual(text) $code 1688 } 1689 .DS { 1690 flushbuffer 1691 incr manual(.DS) 1692 lappend manual(text) $code 1693 } 1694 .DE { 1695 flushbuffer 1696 incr manual(.DS) -1 1697 lappend manual(text) $code 1698 } 1699 .CS { 1700 flushbuffer 1701 incr manual(.CS) 1702 lappend manual(text) $code 1703 } 1704 .CE { 1705 flushbuffer 1706 incr manual(.CS) -1 1707 lappend manual(text) $code 1708 } 1709 .de { 1710 while {[gets $manual(infp) line] >= 0} { 1711 if {[string match "..*" $line]} { 1712 break 1713 } 1714 } 1715 } 1716 .. { 1717 error "found .. outside of .de" 1718 } 1719 default { 1720 flushbuffer 1721 manerror "unrecognized format directive: $line" 1722 } 1723 } 1724 } 1725 flushbuffer 1726 close $manual(infp) 1727 # fixups 1728 if {$manual(.RS) != 0} { 1729 puts "unbalanced .RS .RE" 1730 } 1731 if {$manual(.DS) != 0} { 1732 puts "unbalanced .DS .DE" 1733 } 1734 if {$manual(.CS) != 0} { 1735 puts "unbalanced .CS .CE" 1736 } 1737 if {$manual(.SO) != 0} { 1738 puts "unbalanced .SO .SE" 1739 } 1740 # output conversion 1741 open-text 1742 set haserror 0 1743 if {[next-op-is .HS rest]} { 1744 set manual($manual(name)-title) \ 1745 "[lrange $rest 1 end] [lindex $rest 0] manual page" 1746 } elseif {[next-op-is .TH rest]} { 1747 set manual($manual(name)-title) "[lindex $rest 0] manual page - [lrange $rest 4 end]" 1748 } else { 1749 set haserror 1 1750 manerror "no .HS or .TH record found" 1751 } 1752 if {!$haserror} { 1753 while {[more-text]} { 1754 set line [next-text] 1755 if {[is-a-directive $line]} { 1756 output-directive $line 1757 } else { 1758 man-puts $line 1759 } 1760 } 1761 man-puts [copyout $manual(copyrights) "../"] 1762 set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)] 1763 } 1764 # 1765 # make the long table of contents for this page 1766 # 1767 set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL>] 1768 } 1769 1770 # 1771 # make the wing table of contents for the section 1772 # 1773 set width 0 1774 foreach name $manual(wing-toc) { 1775 if {[string length $name] > $width} { 1776 set width [string length $name] 1777 } 1778 } 1779 set perline [expr {120 / $width}] 1780 set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] 1781 set n 0 1782 catch {unset rows} 1783 foreach name [lsort -dictionary $manual(wing-toc)] { 1784 set tail $manual(name-$name) 1785 if {[llength $tail] > 1} { 1786 manerror "$name is defined in more than one file: $tail" 1787 set tail [lindex $tail [expr {[llength $tail]-1}]] 1788 } 1789 set tail [file tail $tail] 1790 append rows([expr {$n%$nrows}]) \ 1791 "<td> <a href=\"$tail.htm\">$name</a>" 1792 incr n 1793 } 1794 puts $manual(wing-toc-fp) <table> 1795 foreach row [lsort -integer [array names rows]] { 1796 puts $manual(wing-toc-fp) <tr>$rows($row)</tr> 1797 } 1798 puts $manual(wing-toc-fp) </table> 1799 1800 # 1801 # insert wing copyrights 1802 # 1803 puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"] 1804 puts $manual(wing-toc-fp) "</BODY></HTML>" 1805 close $manual(wing-toc-fp) 1806 set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)] 1807 } 1808 1809 ## 1810 ## build the keyword index. 1811 ## 1812 file delete -force -- $html/Keywords 1813 makedirhier $html/Keywords 1814 set keyfp [open $html/Keywords/[indexfile] w] 1815 puts $keyfp [htmlhead "$tcltkdesc Keywords" "$tcltkdesc Keywords" \ 1816 $overall_title "../[indexfile]"] 1817 set letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} 1818 # Create header first 1819 set keyheader {} 1820 foreach a $letters { 1821 set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] 1822 if {[llength $keys]} { 1823 lappend keyheader "<A HREF=\"$a.htm\">$a</A>" 1824 } else { 1825 # No keywords for this letter 1826 lappend keyheader $a 1827 } 1828 } 1829 set keyheader "<H3>[join $keyheader " |\n"]</H3>" 1830 puts $keyfp $keyheader 1831 foreach a $letters { 1832 set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] 1833 if {![llength $keys]} { 1834 continue 1835 } 1836 # Per-keyword page 1837 set afp [open $html/Keywords/$a.htm w] 1838 puts $afp [htmlhead "$tcltkdesc Keywords - $a" \ 1839 "$tcltkdesc Keywords - $a" \ 1840 $overall_title "../[indexfile]"] 1841 puts $afp $keyheader 1842 puts $afp "<DL class=\"keylist\">" 1843 foreach k [lsort -dictionary $keys] { 1844 set k [string range $k 8 end] 1845 puts $afp "<DT><A NAME=\"$k\">$k</A></DT>" 1846 puts $afp "<DD>" 1847 set refs {} 1848 foreach man $manual(keyword-$k) { 1849 set name [lindex $man 0] 1850 set file [lindex $man 1] 1851 lappend refs "<A HREF=\"../$file\">$name</A>" 1852 } 1853 puts $afp "[join $refs {, }]</DD>" 1854 } 1855 puts $afp "</DL>" 1856 # insert merged copyrights 1857 puts $afp [copyout $manual(merge-copyrights)] 1858 puts $afp "</BODY></HTML>" 1859 close $afp 1860 } 1861 # insert merged copyrights 1862 puts $keyfp [copyout $manual(merge-copyrights)] 1863 puts $keyfp "</BODY></HTML>" 1864 close $keyfp 1865 1866 ## 1867 ## finish off short table of contents 1868 ## 1869 puts $manual(short-toc-fp) "<DT><A HREF=\"Keywords/[indexfile]\">Keywords</A><DD>The keywords from the $tcltkdesc man pages." 1870 puts $manual(short-toc-fp) "</DL>" 1871 # insert merged copyrights 1872 puts $manual(short-toc-fp) [copyout $manual(merge-copyrights)] 1873 puts $manual(short-toc-fp) "</BODY></HTML>" 1874 close $manual(short-toc-fp) 1875 1876 ## 1877 ## output man pages 1878 ## 1879 unset manual(section) 1880 foreach path $manual(all-pages) { 1881 set manual(wing-file) [file dirname $path] 1882 set manual(tail) [file tail $path] 1883 set manual(name) [file root $manual(tail)] 1884 set text $manual(output-$manual(wing-file)-$manual(name)) 1885 set ntext 0 1886 foreach item $text { 1887 incr ntext [llength [split $item \n]] 1888 incr ntext 1889 } 1890 set toc $manual(toc-$manual(wing-file)-$manual(name)) 1891 set ntoc 0 1892 foreach item $toc { 1893 incr ntoc [llength [split $item \n]] 1894 incr ntoc 1895 } 1896 puts stderr "rescanning page $manual(name) $ntoc/$ntext" 1897 set outfd [open $html/$manual(wing-file)/$manual(name).htm w] 1898 puts $outfd [htmlhead "$manual($manual(name)-title)" \ 1899 $manual(name) $manual(wing-file) "[indexfile]" \ 1900 $overall_title "../[indexfile]"] 1901 if { 1902 (($ntext > 60) && ($ntoc > 32)) || $manual(tail) in { 1903 Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType CrtItemType 1904 CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetDash 1905 GetJustify GetPixels GetVisual ParseArgv QueueEvent 1906 } 1907 } then { 1908 foreach item $toc { 1909 puts $outfd $item 1910 } 1911 } 1912 foreach item $text { 1913 puts $outfd [insert-cross-references $item] 1914 } 1915 puts $outfd "</BODY></HTML>" 1916 close $outfd 1917 } 1918 return {} 1919} 1920 1921parse_command_line 1922 1923set tcltkdesc ""; set cmdesc ""; set appdir "" 1924if {$build_tcl} { 1925 append tcltkdesc "Tcl" 1926 append cmdesc "Tcl" 1927 append appdir "$tcldir" 1928} 1929if {$build_tcl && $build_tk} { 1930 append tcltkdesc "/" 1931 append cmdesc " and " 1932 append appdir "," 1933} 1934if {$build_tk} { 1935 append tcltkdesc "Tk" 1936 append cmdesc "Tk" 1937 append appdir "$tkdir" 1938} 1939 1940set usercmddesc "The interpreters which implement $cmdesc." 1941set tclcmddesc {The commands which the <B>tclsh</B> interpreter implements.} 1942set tkcmddesc {The additional commands which the <B>wish</B> interpreter implements.} 1943set tcllibdesc {The C functions which a Tcl extended C program may use.} 1944set tklibdesc {The additional C functions which a Tk extended C program may use.} 1945 1946if {1} { 1947 if {[catch { 1948 make-man-pages $webdir \ 1949 "$tcltkdir/{$appdir}/doc/*.1 \"$tcltkdesc Applications\" UserCmd {$usercmddesc}" \ 1950 [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" : ""}] \ 1951 [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" : ""}] \ 1952 [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" : ""}] \ 1953 [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" : ""}] 1954 } error]} { 1955 puts $error\n$errorInfo 1956 } 1957} 1958