开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tcltk-man2html.tcl
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：47k
源码类别：

通讯编程

开发平台：

Visual C++

tcltk-man2html.tcl：源码内容
  1. #!/bin/sh
  2. # The next line is executed by /bin/sh, but not tcl 
  3. exec tclsh8.4 "$0" ${1+"$@"}
  5. package require Tcl 8.4
  7. # Convert Ousterhout format man pages into highly crosslinked
  8. # hypertext.
  9. #
  10. # Along the way detect many unmatched font changes and other odd
  11. # things.
  12. #
  13. # Note well, this program is a hack rather than a piece of software
  14. # engineering.  In that sense it's probably a good example of things
  15. # that a scripting language, like Tcl, can do well.  It is offered as
  16. # an example of how someone might convert a specific set of man pages
  17. # into hypertext, not as a general solution to the problem.  If you
  18. # try to use this, you'll be very much on your own.
  19. #
  20. # Copyright (c) 1995-1997 Roger E. Critchlow Jr
  21. #
  22. # The authors hereby grant permission to use, copy, modify, distribute,
  23. # and license this software and its documentation for any purpose, provided
  24. # that existing copyright notices are retained in all copies and that this
  25. # notice is included verbatim in any distributions. No written agreement,
  26. # license, or royalty fee is required for any of the authorized uses.
  27. # Modifications to this software may be copyrighted by their authors
  28. # and need not follow the licensing terms described here, provided that
  29. # the new terms are clearly indicated on the first page of each file where
  30. # they apply.
  31. # 
  32. # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
  33. # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
  34. # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
  35. # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
  36. # POSSIBILITY OF SUCH DAMAGE.
  37. # 
  38. # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
  39. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
  40. # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
  41. # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
  42. # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
  43. # MODIFICATIONS.
  44. #
  45. # Revisions:
  46. #  May 15, 1995 - initial release
  47. #  May 16, 1995 - added a back to home link to toplevel table of
  48. # contents.
  49. #  May 18, 1995 - broke toplevel table of contents into separate
  50. # pages for each section, and broke long table of contents
  51. # into a one page for each man page.
  52. #  Mar 10, 1996 - updated for tcl7.5b3/tk4.1b3
  53. #  Apr 14, 1996 - incorporated command line parsing from Tom Tromey,
  54. #   <tromey@creche.cygnus.com> -- thanks Tom.
  55. # - updated for tcl7.5/tk4.1 final release.
  56. # - converted to same copyright as the man pages.
  57. #  Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1
  58. #  Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions.
  59. #  Oct 22, 1996 - major hacking on indentation code and elsewhere.
  60. #  Mar  4, 1997 - 
  61. #  May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions
  62. # - cleaned source for tclsh8.0 execution
  63. # - renamed output files for windoze installation
  64. # - added spaces to tables
  65. #  Oct 24, 1997 - moved from 8.0b1 to 8.0 release
  66. #
  68. set Version "0.32"
  70. proc parse_command_line {} {
  71.     global argv Version
  73.     # These variables determine where the man pages come from and where
  74.     # the converted pages go to.
  75.     global tcltkdir tkdir tcldir webdir build_tcl build_tk
  77.     # Set defaults based on original code.
  78.     set tcltkdir ../..
  79.     set tkdir {}
  80.     set tcldir {}
  81.     set webdir ../html
  82.     set build_tcl 0
  83.     set build_tk 0
  84.     # Default search version is a glob pattern
  85.     set useversion {{,[8-9].[0-9]{,.[0-9]{,[0-9]}}}}
  87.     # Handle arguments a la GNU:
  88.     #   --version
  89.     #   --useversion=<version>
  90.     #   --help
  91.     #   --srcdir=/path
  92.     #   --htmldir=/path
  94.     foreach option $argv {
  95. switch -glob -- $option {
  96.     --version {
  97. puts "tcltk-man-html $Version"
  98. exit 0
  99.     }
  101.     --help {
  102. puts "usage: tcltk-man-html [OPTION] ...n"
  103. puts "  --help              print this help, then exit"
  104. puts "  --version           print version number, then exit"
  105. puts "  --srcdir=DIR        find tcl and tk source below DIR"
  106. puts "  --htmldir=DIR       put generated HTML in DIR"
  107. puts "  --tcl               build tcl help"
  108. puts "  --tk                build tk help"
  109. puts "  --useversion        version of tcl/tk to search for"
  110. exit 0
  111.     }
  113.     --srcdir=* {
  114. # length of "--srcdir=" is 9.
  115. set tcltkdir [string range $option 9 end]
  116.     }
  118.     --htmldir=* {
  119. # length of "--htmldir=" is 10
  120. set webdir [string range $option 10 end]
  121.     }
  123.     --useversion=* {
  124. # length of "--useversion=" is 13
  125. set useversion [string range $option 13 end]
  126.     }
  128.     --tcl {
  129. set build_tcl 1
  130.     }
  132.     --tk {
  133. set build_tk 1
  134.     }
  136.     default {
  137. puts stderr "tcltk-man-html: unrecognized option -- `$option'"
  138. exit 1
  139.     }
  140. }
  141.     }
  143.     if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1}
  145.     if {$build_tcl} {
  146. # Find Tcl.
  147. set tcldir [lindex [lsort [glob -nocomplain -tails -type d 
  148.        -directory $tcltkdir tcl$useversion]] end]
  149. if {$tcldir == ""} then {
  150.     puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
  151.     exit 1
  152. }
  153. puts "using Tcl source directory $tcldir"
  154.     }
  156.     if {$build_tk} {
  157. # Find Tk.
  158. set tkdir [lindex [lsort [glob -nocomplain -tails -type d 
  159.       -directory $tcltkdir tk$useversion]] end]
  160. if {$tkdir == ""} then {
  161.     puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
  162.     exit 1
  163. }
  164. puts "using Tk source directory $tkdir"
  165.     }
  167.     # the title for the man pages overall
  168.     global overall_title
  169.     set overall_title ""
  170.     if {$build_tcl} {append overall_title "[capitalize $tcldir]"}
  171.     if {$build_tcl && $build_tk} {append overall_title "/"}
  172.     if {$build_tk} {append overall_title "[capitalize $tkdir]"}
  173.     append overall_title " Manual"
  174. }
  176. proc capitalize {string} {
  177.     return [string toupper $string 0]
  178. }
  180. ##
  181. ##
  182. ##
  183. set manual(report-level) 1
  185. proc manerror {msg} {
  186.     global manual
  187.     set name {}
  188.     set subj {}
  189.     if {[info exists manual(name)]} {
  190. set name $manual(name)
  191.     }
  192.     if {[info exists manual(section)] && [string length $manual(section)]} {
  193. puts stderr "$name: $manual(section):  $msg"
  194.     } else {
  195. puts stderr "$name: $msg"
  196.     }
  197. }
  199. proc manreport {level msg} {
  200.     global manual
  201.     if {$level < $manual(report-level)} {
  202. manerror $msg
  203.     }
  204. }
  206. proc fatal {msg} {
  207.     global manual
  208.     manerror $msg
  209.     exit 1
  210. }
  211. ##
  212. ## parsing
  213. ##
  214. proc unquote arg {
  215.     return [string map [list " {}] $arg]
  216. }
  218. proc parse-directive {line codename restname} {
  219.     upvar $codename code $restname rest
  220.     return [regexp {^(.[.a-zA-Z0-9]*) *(.*)} $line all code rest]
  221. }
  223. proc process-text {text} {
  224.     global manual
  225.     # preprocess text
  226.     set text [string map [list 
  227.     {&} "t" 
  228.     {&} {&amp;} 
  229.     {\} {&#92;} 
  230.     {e} {&#92;} 
  231.     { } {&nbsp;} 
  232.     {|} {&nbsp;} 
  233.     {} { } 
  234.     {%} {} 
  235.     "\n" "n" 
  236.     " {&quot;} 
  237.     {<} {&lt;} 
  238.     {>} {&gt;} 
  239.     {(+-} {&#177;} 
  240.     {fP} {fR} 
  241.     {.} . 
  242.     {(bu} {&#8226;} 
  243.     ] $text]
  244.     regsub -all {\o'o^'} $text {&ocirc;} text; # o-circumflex in re_syntax.n
  245.     regsub -all {\-\|\-} $text -- text; # two hyphens
  246.     regsub -all -- {\-\^\-} $text -- text; # two hyphens
  247.     regsub -all {\-} $text - text; # a hyphen
  248.     regsub -all "\\n" $text "\&#92;n" text; # backslashed newline
  249.     while {[string first "\" $text] >= 0} {
  250. # C R
  251. if {[regsub {^([^\]*)\fC([^\]*)\fR(.*)$} $text 
  252. {1<TT>2</TT>3} text]} continue
  253. # B R
  254. if {[regsub {^([^\]*)\fB([^\]*)\fR(.*)$} $text 
  255. {1<B>2</B>3} text]} continue
  256. # B I
  257. if {[regsub {^([^\]*)\fB([^\]*)\fI(.*)$} $text 
  258. {1<B>2</B>\fI3} text]} continue
  259. # I R
  260. if {[regsub {^([^\]*)\fI([^\]*)\fR(.*)$} $text 
  261. {1<I>2</I>3} text]} continue
  262. # I B
  263. if {[regsub {^([^\]*)\fI([^\]*)\fB(.*)$} $text 
  264. {1<I>2</I>\fB3} text]} continue
  265. # B B, I I, R R
  266. if {[regsub {^([^\]*)\fB([^\]*)\fB(.*)$} $text 
  267. {1\fB23} ntext]
  268.     || [regsub {^([^\]*)\fI([^\]*)\fI(.*)$} $text 
  269.     {1\fI23} ntext]
  270.     || [regsub {^([^\]*)\fR([^\]*)\fR(.*)$} $text 
  271.     {1\fR23} ntext]} {
  272.     manerror "process-text: impotent font change: $text"
  273.     set text $ntext
  274.     continue
  275. }
  276. # unrecognized
  277. manerror "process-text: uncaught backslash: $text"
  278. set text [string map [list "\" "#92;"] $text]
  279.     }
  280.     return $text
  281. }
  282. ##
  283. ## pass 2 text input and matching
  284. ##
  285. proc open-text {} {
  286.     global manual
  287.     set manual(text-length) [llength $manual(text)]
  288.     set manual(text-pointer) 0
  289. }
  290. proc more-text {} {
  291.     global manual
  292.     return [expr {$manual(text-pointer) < $manual(text-length)}]
  293. }
  294. proc next-text {} {
  295.     global manual
  296.     if {[more-text]} {
  297. set text [lindex $manual(text) $manual(text-pointer)]
  298. incr manual(text-pointer)
  299. return $text
  300.     }
  301.     manerror "read past end of text"
  302.     error "fatal"
  303. }
  304. proc is-a-directive {line} {
  305.     return [string match .* $line]
  306. }
  307. proc split-directive {line opname restname} {
  308.     upvar $opname op $restname rest
  309.     set op [string range $line 0 2]
  310.     set rest [string trim [string range $line 3 end]]
  311. }
  312. proc next-op-is {op restname} {
  313.     global manual
  314.     upvar $restname rest
  315.     if {[more-text]} {
  316. set text [lindex $manual(text) $manual(text-pointer)]
  317. if {[string equal -length 3 $text $op]} {
  318.     set rest [string range $text 4 end]
  319.     incr manual(text-pointer)
  320.     return 1
  321. }
  322.     }
  323.     return 0
  324. }
  325. proc backup-text {n} {
  326.     global manual
  327.     if {$manual(text-pointer)-$n >= 0} {
  328. incr manual(text-pointer) -$n
  329.     }
  330. }
  331. proc match-text args {
  332.     global manual
  333.     set nargs [llength $args]
  334.     if {$manual(text-pointer) + $nargs > $manual(text-length)} {
  335. return 0
  336.     }
  337.     set nback 0
  338.     foreach arg $args {
  339. if {![more-text]} {
  340.     backup-text $nback
  341.     return 0
  342. }
  343. set arg [string trim $arg]
  344. set targ [string trim [lindex $manual(text) $manual(text-pointer)]]
  345. if {[string equal $arg $targ]} {
  346.     incr nback
  347.     incr manual(text-pointer)
  348.     continue
  349. }
  350. if {[regexp {^@(w+)$} $arg all name]} {
  351.     upvar $name var
  352.     set var $targ
  353.     incr nback
  354.     incr manual(text-pointer)
  355.     continue
  356. }
  357. if {[regexp -nocase {^(.[A-Z][A-Z])@(w+)$} $arg all op name]
  358. && [string equal $op [lindex $targ 0]]} {
  359.     upvar $name var
  360.     set var [lrange $targ 1 end]
  361.     incr nback
  362.     incr manual(text-pointer)
  363.     continue
  364. }
  365. backup-text $nback
  366. return 0
  367.     }
  368.     return 1
  369. }
  370. proc expand-next-text {n} {
  371.     global manual
  372.     return [join [lrange $manual(text) $manual(text-pointer) 
  373.     [expr {$manual(text-pointer)+$n-1}]] nn]
  374. }
  375. ##
  376. ## pass 2 output
  377. ##
  378. proc man-puts {text} {
  379.     global manual
  380.     lappend manual(output-$manual(wing-file)-$manual(name)) $text
  381. }
  383. ##
  384. ## build hypertext links to tables of contents
  385. ##
  386. proc long-toc {text} {
  387.     global manual
  388.     set here M[incr manual(section-toc-n)]
  389.     set there L[incr manual(long-toc-n)]
  390.     lappend manual(section-toc) 
  391.     "<DD><A HREF="$manual(name).htm#$here" NAME="$there">$text</A>"
  392.     return "<A NAME="$here">$text</A>"
  393. }
  394. proc option-toc {name class switch} {
  395.     global manual
  396.     if {[string equal $manual(section) "WIDGET-SPECIFIC OPTIONS"]} {
  397. # link the defined option into the long table of contents
  398. set link [long-toc "$switch, $name, $class"]
  399. regsub -- "$switch, $name, $class" $link "$switch" link
  400. return $link
  401.     } elseif {[string equal $manual(name):$manual(section) 
  402.     "options:DESCRIPTION"]} {
  403. # link the defined standard option to the long table of
  404. # contents and make a target for the standard option references
  405. # from other man pages.
  406. set first [lindex $switch 0]
  407. set here M$first
  408. set there L[incr manual(long-toc-n)]
  409. set manual(standard-option-$first) "<A HREF="$manual(name).htm#$here">$switch, $name, $class</A>"
  410. lappend manual(section-toc) "<DD><A HREF="$manual(name).htm#$here" NAME="$there">$switch, $name, $class</A>"
  411. return "<A NAME="$here">$switch</A>"
  412.     } else {
  413. error "option-toc in $manual(name) section $manual(section)"
  414.     }
  415. }
  416. proc std-option-toc {name} {
  417.     global manual
  418.     if {[info exists manual(standard-option-$name)]} {
  419. lappend manual(section-toc) <DD>$manual(standard-option-$name)
  420. return $manual(standard-option-$name)
  421.     }
  422.     set here M[incr manual(section-toc-n)]
  423.     set there L[incr manual(long-toc-n)]
  424.     set other M$name
  425.     lappend manual(section-toc) "<DD><A HREF="options.htm#$other">$name</A>"
  426.     return "<A HREF="options.htm#$other">$name</A>"
  427. }
  428. ##
  429. ## process the widget option section
  430. ## in widget and options man pages
  431. ##
  432. proc output-widget-options {rest} {
  433.     global manual
  434.     man-puts <DL>
  435.     lappend manual(section-toc) <DL>
  436.     backup-text 1
  437.     set para {}
  438.     while {[next-op-is .OP rest]} {
  439. switch -exact [llength $rest] {
  440.     3 { foreach {switch name class} $rest { break } }
  441.     5 {
  442. set switch [lrange $rest 0 2]
  443. set name [lindex $rest 3]
  444. set class [lindex $rest 4]
  445.     }
  446.     default {
  447. fatal "bad .OP $rest"
  448.     }
  449. }
  450. if {![regexp {^(<.>)([-w ]+)(</.>)$} $switch all oswitch switch cswitch]} {
  451.     if {![regexp {^(<.>)([-w ]+) or ([-w ]+)(</.>)$} $switch all oswitch switch1 switch2 cswitch]} {
  452. error "not Switch: $switch"
  453.     } else {
  454. set switch "$switch1$cswitch or $oswitch$switch2"
  455.     }
  456. }
  457. if {![regexp {^(<.>)([w]*)(</.>)$} $name all oname name cname]} {
  458.     error "not Name: $name"
  459. }
  460. if {![regexp {^(<.>)([w]*)(</.>)$} $class all oclass class cclass]} {
  461.     error "not Class: $class"
  462. }
  463. man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
  464. man-puts "<DT>Database Name: $oname$name$cname"
  465. man-puts "<DT>Database Class: $oclass$class$cclass"
  466. man-puts <DD>[next-text]
  467. set para <P>
  468.     }
  469.     man-puts </DL>
  470.     lappend manual(section-toc) </DL>
  471. }
  473. ##
  474. ## process .RS lists
  475. ##
  476. proc output-RS-list {} {
  477.     global manual
  478.     if {[next-op-is .IP rest]} {
  479. output-IP-list .RS .IP $rest
  480. if {[match-text .RE .sp .RS @rest .IP @rest2]} {
  481.     man-puts <P>$rest
  482.     output-IP-list .RS .IP $rest2
  483. }
  484. if {[match-text .RE .sp .RS @rest .RE]} {
  485.     man-puts <P>$rest
  486.     return
  487. }
  488. if {[next-op-is .RE rest]} {
  489.     return
  490. }
  491.     }
  492.     man-puts <DL><DD>
  493.     while {[more-text]} {
  494. set line [next-text]
  495. if {[is-a-directive $line]} {
  496.     split-directive $line code rest
  497.     switch -exact $code {
  498. .RE {
  499.     break
  500. }
  501. .SH - .SS {
  502.     manerror "unbalanced .RS at section end"
  503.     backup-text 1
  504.     break
  505. }
  506. default {
  507.     output-directive $line
  508. }
  509.     }
  510. } else {
  511.     man-puts $line
  512. }
  513.     }
  514.     man-puts </DL>
  515. }
  517. ##
  518. ## process .IP lists which may be plain indents,
  519. ## numeric lists, or definition lists
  520. ##
  521. proc output-IP-list {context code rest} {
  522.     global manual
  523.     if {![string length $rest]} {
  524. # blank label, plain indent, no contents entry
  525. man-puts <DL><DD>
  526. while {[more-text]} {
  527.     set line [next-text]
  528.     if {[is-a-directive $line]} {
  529. split-directive $line code rest
  530. if {[string equal $code ".IP"] && [string equal $rest {}]} {
  531.     man-puts "<P>"
  532.     continue
  533. }
  534. if {[lsearch {.br .DS .RS} $code] >= 0} {
  535.     output-directive $line
  536. } else {
  537.     backup-text 1
  538.     break
  539. }
  540.     } else {
  541. man-puts $line
  542.     }
  543. }
  544. man-puts </DL>
  545.     } else {
  546. # labelled list, make contents
  547. if {
  548.     [string compare $context ".SH"] &&
  549.     [string compare $context ".SS"]
  550. } then {
  551.     man-puts <P>
  552. }
  553. man-puts <DL>
  554. lappend manual(section-toc) <DL>
  555. backup-text 1
  556. set accept_RE 0
  557. set para {}
  558. while {[more-text]} {
  559.     set line [next-text]
  560.     if {[is-a-directive $line]} {
  561. split-directive $line code rest
  562. switch -exact $code {
  563.     .IP {
  564. if {$accept_RE} {
  565.     output-IP-list .IP $code $rest
  566.     continue
  567. }
  568. if {[string equal $manual(section) "ARGUMENTS"] || 
  569. [regexp {^[d+]$} $rest]} {
  570.     man-puts "$para<DT>$rest<DD>"
  571. } elseif {[string equal {&#8226;} $rest]} {
  572.    man-puts "$para<DT><DD>$rest&nbsp;"
  573. } else {
  574.     man-puts "$para<DT>[long-toc $rest]<DD>"
  575. }
  576. if {[string equal $manual(name):$manual(section) 
  577. "selection:DESCRIPTION"]} {
  578.     if {[match-text .RE @rest .RS .RS]} {
  579. man-puts <DT>[long-toc $rest]<DD>
  580.     }
  581. }
  582.     }
  583.     .sp -
  584.     .br -
  585.     .DS -
  586.     .CS {
  587. output-directive $line
  588.     }
  589.     .RS {
  590. if {[match-text .RS]} {
  591.     output-directive $line
  592.     incr accept_RE 1
  593. } elseif {[match-text .CS]} {
  594.     output-directive .CS
  595.     incr accept_RE 1
  596. } elseif {[match-text .PP]} {
  597.     output-directive .PP
  598.     incr accept_RE 1
  599. } elseif {[match-text .DS]} {
  600.     output-directive .DS
  601.     incr accept_RE 1
  602. } else {
  603.     output-directive $line
  604. }
  605.     }
  606.     .PP {
  607. if {[match-text @rest1 .br @rest2 .RS]} {
  608.     # yet another nroff kludge as above
  609.     man-puts "$para<DT>[long-toc $rest1]"
  610.     man-puts "<DT>[long-toc $rest2]<DD>"
  611.     incr accept_RE 1
  612. } elseif {[match-text @rest .RE]} {
  613.     # gad, this is getting ridiculous
  614.     if {!$accept_RE} {
  615. man-puts "</DL><P>$rest<DL>"
  616. backup-text 1
  617. set para {}
  618. break
  619.     } else {
  620. man-puts "<P>$rest"
  621. incr accept_RE -1
  622.     }
  623. } elseif {$accept_RE} {
  624.     output-directive $line
  625. } else {
  626.     backup-text 1
  627.     break
  628. }
  629.     }
  630.     .RE {
  631. if {!$accept_RE} {
  632.     backup-text 1
  633.     break
  634. }
  635. incr accept_RE -1
  636.     }
  637.     default {
  638. backup-text 1
  639. break
  640.     }
  641. }
  642.     } else {
  643. man-puts $line
  644.     }
  645.     set para <P>
  646. }
  647. man-puts "$para</DL>"
  648. lappend manual(section-toc) </DL>
  649. if {$accept_RE} {
  650.     manerror "missing .RE in output-IP-list"
  651. }
  652.     }
  653. }
  654. ##
  655. ## handle the NAME section lines
  656. ## there's only one line in the NAME section,
  657. ## consisting of a comma separated list of names,
  658. ## followed by a hyphen and a short description.
  659. ##
  660. proc output-name {line} {
  661.     global manual
  662.     # split name line into pieces
  663.     regexp {^([^-]+) - (.*)$} $line all head tail
  664.     # output line to manual page untouched
  665.     man-puts $line
  666.     # output line to long table of contents
  667.     lappend manual(section-toc) <DL><DD>$line</DL>
  668.     # separate out the names for future reference
  669.     foreach name [split $head ,] {
  670. set name [string trim $name]
  671. if {[llength $name] > 1} {
  672.     manerror "name has a space: {$name}nfrom: $line"
  673. }
  674. lappend manual(wing-toc) $name
  675. lappend manual(name-$name) $manual(wing-file)/$manual(name)
  676.     }
  677. }
  678. ##
  679. ## build a cross-reference link if appropriate
  680. ##
  681. proc cross-reference {ref} {
  682.     global manual
  683.     if {[string match Tcl_* $ref]} {
  684. set lref $ref
  685.     } elseif {[string match Tk_* $ref]} {
  686. set lref $ref
  687.     } elseif {[string equal $ref "Tcl"]} {
  688. set lref $ref
  689.     } else {
  690. set lref [string tolower $ref]
  691.     }
  692.     ##
  693.     ## nothing to reference
  694.     ##
  695.     if {![info exists manual(name-$lref)]} {
  696. foreach name {array file history info interp string trace
  697. after clipboard grab image option pack place selection tk tkwait update winfo wm} {
  698.     if {[regexp "^$name [a-z0-9]*$" $lref] && 
  699.     [info exists manual(name-$name)] && 
  700.     [string compare $manual(tail) "$name.n"]} {
  701. return "<A HREF="../$manual(name-$name).htm">$ref</A>"
  702.     }
  703. }
  704. if {[lsearch {stdin stdout stderr end} $lref] >= 0} {
  705.     # no good place to send these
  706.     # tcl tokens?
  707.     # also end
  708. }
  709. return $ref
  710.     }
  711.     ##
  712.     ## would be a self reference
  713.     ##
  714.     foreach name $manual(name-$lref) {
  715. if {[lsearch $name $manual(wing-file)/$manual(name)] >= 0} {
  716.     return $ref
  717. }
  718.     }
  719.     ##
  720.     ## multiple choices for reference
  721.     ##
  722.     if {[llength $manual(name-$lref)] > 1} {
  723. set tcl_i [lsearch -glob $manual(name-$lref) *TclCmd*]
  724. set tcl_ref [lindex $manual(name-$lref) $tcl_i]
  725. set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*]
  726. set tk_ref [lindex $manual(name-$lref) $tk_i]
  727. if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} 
  728. ||  "$manual(wing-file)" == {TclLib}} {
  729.     return "<A HREF="../$tcl_ref.htm">$ref</A>"
  730. }
  731. if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} 
  732. || "$manual(wing-file)" == {TkLib}} {
  733.     return "<A HREF="../$tk_ref.htm">$ref</A>"
  734. }
  735. if {"$lref" == {exit} && "$manual(tail)" == {tclsh.1} && $tcl_i >= 0} {
  736.     return "<A HREF="../$tcl_ref.htm">$ref</A>"
  737. }
  738. puts stderr "multiple cross reference to $ref in $manual(name-$lref) from $manual(wing-file)/$manual(tail)"
  739. return $ref
  740.     }
  741.     ##
  742.     ## exceptions, sigh, to the rule
  743.     ##
  744.     switch $manual(tail) {
  745. canvas.n {
  746.     if {$lref == {focus}} {
  747. upvar tail tail
  748. set clue [string first command $tail]
  749. if {$clue < 0 ||  $clue > 5} {
  750.     return $ref
  751. }
  752.     }
  753.     if {[lsearch {bitmap image text} $lref] >= 0} {
  754. return $ref
  755.     }
  756. }
  757. checkbutton.n -
  758. radiobutton.n {
  759.     if {[lsearch {image} $lref] >= 0} {
  760. return $ref
  761.     }
  762. }
  763. menu.n {
  764.     if {[lsearch {checkbutton radiobutton} $lref] >= 0} {
  765. return $ref
  766.     }
  767. }
  768. options.n {
  769.     if {[lsearch {bitmap image set} $lref] >= 0} {
  770. return $ref
  771.     }
  772. }
  773. regexp.n {
  774.     if {[lsearch {string} $lref] >= 0} {
  775. return $ref
  776.     }
  777. }
  778. source.n {
  779.     if {[lsearch {text} $lref] >= 0} {
  780. return $ref
  781.     }
  782. }
  783. history.n {
  784.     if {[lsearch {exec} $lref] >= 0} {
  785. return $ref
  786.     }
  787. }
  788. return.n {
  789.     if {[lsearch {error continue break} $lref] >= 0} {
  790. return $ref
  791.     }
  792. }
  793. scrollbar.n {
  794.     if {[lsearch {set} $lref] >= 0} {
  795. return $ref
  796.     }
  797. }
  798.     }
  799.     ##
  800.     ## return the cross reference
  801.     ##
  802.     return "<A HREF="../$manual(name-$lref).htm">$ref</A>"
  803. }
  804. ##
  805. ## reference generation errors
  806. ##
  807. proc reference-error {msg text} {
  808.     global manual
  809.     puts stderr "$manual(tail): $msg: {$text}"
  810.     return $text
  811. }
  812. ##
  813. ## insert as many cross references into this text string as are appropriate
  814. ##
  815. proc insert-cross-references {text} {
  816.     global manual
  817.     ##
  818.     ## we identify cross references by:
  819.     ##     ``quotation''
  820.     ##    <B>emboldening</B>
  821.     ##    Tcl_ prefix
  822.     ##    Tk_ prefix
  823.     ##   [a-zA-Z0-9]+ manual entry
  824.     ## and we avoid messing with already anchored text
  825.     ##
  826.     ##
  827.     ## find where each item lives
  828.     ##
  829.     array set offset [list 
  830.     anchor [string first {<A } $text] 
  831.     end-anchor [string first {</A>} $text] 
  832.     quote [string first {``} $text] 
  833.     end-quote [string first {''} $text] 
  834.     bold [string first {<B>} $text] 
  835.     end-bold [string first {</B>} $text] 
  836.     tcl [string first {Tcl_} $text] 
  837.     tk [string first {Tk_} $text] 
  838.     Tcl1 [string first {Tcl manual entry} $text] 
  839.     Tcl2 [string first {Tcl overview manual entry} $text] 
  840.     ]
  841.     ##
  842.     ## accumulate a list
  843.     ##
  844.     foreach name [array names offset] {
  845. if {$offset($name) >= 0} {
  846.     set invert($offset($name)) $name
  847.     lappend offsets $offset($name)
  848. }
  849.     }
  850.     ##
  851.     ## if nothing, then we're done.
  852.     ##
  853.     if {![info exists offsets]} {
  854. return $text
  855.     }
  856.     ##
  857.     ## sort the offsets
  858.     ##
  859.     set offsets [lsort -integer $offsets]
  860.     ##
  861.     ## see which we want to use
  862.     ##
  863.     switch -exact $invert([lindex $offsets 0]) {
  864. anchor {
  865.     if {$offset(end-anchor) < 0} {
  866. return [reference-error {Missing end anchor} $text]
  867.     }
  868.     set head [string range $text 0 $offset(end-anchor)]
  869.     set tail [string range $text [expr {$offset(end-anchor)+1}] end]
  870.     return $head[insert-cross-references $tail]
  871. }
  872. quote {
  873.     if {$offset(end-quote) < 0} {
  874. return [reference-error "Missing end quote" $text]
  875.     }
  876.     if {$invert([lindex $offsets 1]) == "tk"} {
  877. set offsets [lreplace $offsets 1 1]
  878.     }
  879.     if {$invert([lindex $offsets 1]) == "tcl"} {
  880. set offsets [lreplace $offsets 1 1]
  881.     }
  882.     switch -exact $invert([lindex $offsets 1]) {
  883. end-quote {
  884.     set head [string range $text 0 [expr {$offset(quote)-1}]]
  885.     set body [string range $text [expr {$offset(quote)+2}] 
  886.     [expr {$offset(end-quote)-1}]]
  887.     set tail [string range $text 
  888.     [expr {$offset(end-quote)+2}] end]
  889.     return "$head``[cross-reference $body]''[insert-cross-references $tail]"
  890. }
  891. bold -
  892. anchor {
  893.     set head [string range $text 
  894.     0 [expr {$offset(end-quote)+1}]]
  895.     set tail [string range $text 
  896.     [expr {$offset(end-quote)+2}] end]
  897.     return "$head[insert-cross-references $tail]"
  898. }
  899.     }
  900.     return [reference-error "Uncaught quote case" $text]
  901. }
  902. bold {
  903.     if {$offset(end-bold) < 0} { return $text }
  904.     if {$invert([lindex $offsets 1]) == "tk"} {
  905. set offsets [lreplace $offsets 1 1]
  906.     }
  907.     if {$invert([lindex $offsets 1]) == "tcl"} {
  908. set offsets [lreplace $offsets 1 1]
  909.     }
  910.     switch -exact $invert([lindex $offsets 1]) {
  911. end-bold {
  912.     set head [string range $text 0 [expr {$offset(bold)-1}]]
  913.     set body [string range $text [expr {$offset(bold)+3}] 
  914.     [expr {$offset(end-bold)-1}]]
  915.     set tail [string range $text 
  916.     [expr {$offset(end-bold)+4}] end]
  917.     return "$head<B>[cross-reference $body]</B>[insert-cross-references $tail]"
  918. }
  919. anchor {
  920.     set head [string range $text 
  921.     0 [expr {$offset(end-bold)+3}]]
  922.     set tail [string range $text 
  923.     [expr {$offset(end-bold)+4}] end]
  924.     return "$head[insert-cross-references $tail]"
  925. }
  926.     }
  927.     return [reference-error "Uncaught bold case" $text]
  928. }
  929. tk {
  930.     set head [string range $text 0 [expr {$offset(tk)-1}]]
  931.     set tail [string range $text $offset(tk) end]
  932.     if {![regexp {^(Tk_w+)(.*)$} $tail all body tail]} {
  933. return [reference-error "Tk regexp failed" $text]
  934.     }
  935.     return $head[cross-reference $body][insert-cross-references $tail]
  936. }
  937. tcl {
  938.     set head [string range $text 0 [expr {$offset(tcl)-1}]]
  939.     set tail [string range $text $offset(tcl) end]
  940.     if {![regexp {^(Tcl_w+)(.*)$} $tail all body tail]} {
  941. return [reference-error {Tcl regexp failed} $text]
  942.     }
  943.     return $head[cross-reference $body][insert-cross-references $tail]
  944. }
  945. Tcl1 -
  946. Tcl2 {
  947.     set off [lindex $offsets 0]
  948.     set head [string range $text 0 [expr {$off-1}]]
  949.     set body Tcl
  950.     set tail [string range $text [expr {$off+3}] end]
  951.     return $head[cross-reference $body][insert-cross-references $tail]
  952. }
  953. end-anchor -
  954. end-bold -
  955. end-quote {
  956.     return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
  957. }
  958.     }
  959. }
  960. ##
  961. ## process formatting directives
  962. ##
  963. proc output-directive {line} {
  964.     global manual
  965.     # process format directive
  966.     split-directive $line code rest
  967.     switch -exact $code {
  968. .BS -
  969. .BE {
  970.     # man-puts <HR>
  971. }
  972. .SH - .SS {
  973.     # drain any open lists
  974.     # announce the subject
  975.     set manual(section) $rest
  976.     # start our own stack of stuff
  977.     set manual($manual(name)-$manual(section)) {}
  978.     lappend manual(has-$manual(section)) $manual(name)
  979.     if {[string compare .SS $code]} {
  980. man-puts "<H3>[long-toc $manual(section)]</H3>"
  981.     } else {
  982. man-puts "<H4>[long-toc $manual(section)]</H4>"
  983.     }
  984.     # some sections can simply free wheel their way through the text
  985.     # some sections can be processed in their own loops
  986.     switch -exact $manual(section) {
  987. NAME {
  988.     if {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} {
  989. # these manual pages have two NAME sections
  990. if {[info exists manual($manual(tail)-NAME)]} {
  991.     return
  992. }
  993. set manual($manual(tail)-NAME) 1
  994.     }
  995.     set names {}
  996.     while {1} {
  997. set line [next-text]
  998. if {[is-a-directive $line]} {
  999.     backup-text 1
  1000.     output-name [join $names { }]
  1001.     return
  1002. } else {
  1003.     lappend names [string trim $line]
  1004. }
  1005.     }
  1006. }
  1007. SYNOPSIS {
  1008.     lappend manual(section-toc) <DL>
  1009.     while {1} {
  1010. if {[next-op-is .nf rest]
  1011.  || [next-op-is .br rest]
  1012.  || [next-op-is .fi rest]} {
  1013.     continue
  1014. }
  1015. if {[next-op-is .SH rest]
  1016.          || [next-op-is .SS rest]
  1017.          || [next-op-is .BE rest]
  1018.  || [next-op-is .SO rest]} {
  1019.     backup-text 1
  1020.     break
  1021. }
  1022. if {[next-op-is .sp rest]} {
  1023.     #man-puts <P>
  1024.     continue
  1025. }
  1026. set more [next-text]
  1027. if {[is-a-directive $more]} {
  1028.     manerror "in SYNOPSIS found $more"
  1029.     backup-text 1
  1030.     break
  1031. } else {
  1032.     foreach more [split $more n] {
  1033. man-puts $more<BR>
  1034. if {[lsearch {TclLib TkLib} $manual(wing-file)] < 0} {
  1035.     lappend manual(section-toc) <DD>$more
  1036. }
  1037.     }
  1038. }
  1039.     }
  1040.     lappend manual(section-toc) </DL>
  1041.     return
  1042. }
  1043. {SEE ALSO} {
  1044.     while {[more-text]} {
  1045. if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
  1046.     backup-text 1
  1047.     return
  1048. }
  1049. set more [next-text]
  1050. if {[is-a-directive $more]} {
  1051.     manerror "$more"
  1052.     backup-text 1
  1053.     return
  1054. }
  1055. set nmore {}
  1056. foreach cr [split $more ,] {
  1057.     set cr [string trim $cr]
  1058.     if {![regexp {^<B>.*</B>$} $cr]} {
  1059. set cr <B>$cr</B>
  1060.     }
  1061.     if {[regexp {^<B>(.*)([13n])</B>$} $cr all name]} {
  1062. set cr <B>$name</B>
  1063.     }
  1064.     lappend nmore $cr
  1065. }
  1066. man-puts [join $nmore {, }]
  1067.     }
  1068.     return
  1069. }
  1070. KEYWORDS {
  1071.     while {[more-text]} {
  1072. if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
  1073.     backup-text 1
  1074.     return
  1075. }
  1076. set more [next-text]
  1077. if {[is-a-directive $more]} {
  1078.     manerror "$more"
  1079.     backup-text 1
  1080.     return
  1081. }
  1082. set keys {}
  1083. foreach key [split $more ,] {
  1084.     set key [string trim $key]
  1085.     lappend manual(keyword-$key) [list $manual(name) $manual(wing-file)/$manual(name).htm]
  1086.     set initial [string toupper [string index $key 0]]
  1087.     lappend keys "<A href="../Keywords/$initial.htm#$key">$key</A>"
  1088. }
  1089. man-puts [join $keys {, }]
  1090.     }
  1091.     return
  1092. }
  1093.     }
  1094.     if {[next-op-is .IP rest]} {
  1095. output-IP-list $code .IP $rest
  1096. return
  1097.     }
  1098.     if {[next-op-is .PP rest]} {
  1099. return
  1100.     }
  1101.     return
  1102. }
  1103. .SO {
  1104.     if {[match-text @stuff .SE]} {
  1105. output-directive {.SH STANDARD OPTIONS}
  1106. set opts {}
  1107. foreach line [split $stuff n] {
  1108.     foreach option [split $line t] {
  1109. lappend opts $option
  1110.     }
  1111. }
  1112. man-puts <DL>
  1113. lappend manual(section-toc) <DL>
  1114. foreach option [lsort $opts] {
  1115.     man-puts "<DT><B>[std-option-toc $option]</B>"
  1116. }
  1117. man-puts </DL>
  1118. lappend manual(section-toc) </DL>
  1119.     } else {
  1120. manerror "unexpected .SO format:n[expand-next-text 2]"
  1121.     }
  1122. }
  1123. .OP {
  1124.     output-widget-options $rest
  1125.     return
  1126. }
  1127. .IP {
  1128.     output-IP-list .IP .IP $rest
  1129.     return
  1130. }
  1131. .PP {
  1132.     man-puts <P>
  1133. }
  1134. .RS {
  1135.     output-RS-list
  1136.     return
  1137. }
  1138. .RE {
  1139.     manerror "unexpected .RE"
  1140.     return
  1141. }
  1142. .br {
  1143.     man-puts <BR>
  1144.     return
  1145. }
  1146. .DE {
  1147.     manerror "unexpected .DE"
  1148.     return
  1149. }
  1150. .DS {
  1151.     if {[next-op-is .ta rest]} {
  1153.     }
  1154.     if {[match-text @stuff .DE]} {
  1155. man-puts <PRE>$stuff</PRE>
  1156.     } elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
  1157. man-puts "<PRE>[lindex $ul1 1][lindex $ul2 1]n$stuff</PRE>"
  1158.     } else {
  1159. manerror "unexpected .DS format:n[expand-next-text 2]"
  1160.     }
  1161.     return
  1162. }
  1163. .CS {
  1164.     if {[next-op-is .ta rest]} {
  1166.     }
  1167.     if {[match-text @stuff .CE]} {
  1168. man-puts <PRE>$stuff</PRE>
  1169.     } else {
  1170. manerror "unexpected .CS format:n[expand-next-text 2]"
  1171.     }
  1172.     return
  1173. }
  1174. .CE {
  1175.     manerror "unexpected .CE"
  1176.     return
  1177. }
  1178. .sp {
  1179.     man-puts <P>
  1180. }
  1181. .ta {
  1182.     # these are tab stop settings for short tables
  1183.     switch -exact $manual(name):$manual(section) {
  1184. {bind:MODIFIERS} -
  1185. {bind:EVENT TYPES} -
  1186. {bind:BINDING SCRIPTS AND SUBSTITUTIONS} -
  1187. {expr:OPERANDS} -
  1188. {expr:MATH FUNCTIONS} -
  1189. {history:DESCRIPTION} -
  1190. {history:HISTORY REVISION} -
  1191. {re_syntax:BRACKET EXPRESSIONS} -
  1192. {switch:DESCRIPTION} -
  1193. {upvar:DESCRIPTION} {
  1194.     return; # fix.me
  1195. }
  1196. default {
  1197.     manerror "ignoring $line"
  1198. }
  1199.     }
  1200. }
  1201. .nf {
  1202.     if {[match-text @more .fi]} {
  1203. foreach more [split $more n] {
  1204.     man-puts $more<BR>
  1205. }
  1206.     } elseif {[match-text .RS @more .RE .fi]} {
  1207. man-puts <DL><DD>
  1208. foreach more [split $more n] {
  1209.     man-puts $more<BR>
  1210. }
  1211. man-puts </DL>
  1212.     } elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
  1213. man-puts <DL><DD>
  1214. foreach more [split $more n] {
  1215.     man-puts $more<BR>
  1216. }
  1217. man-puts <DL><DD>
  1218. foreach more2 [split $more2 n] {
  1219.     man-puts $more2<BR>
  1220. }
  1221. man-puts </DL></DL>
  1222.     } elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
  1223. man-puts <DL><DD>
  1224. foreach more [split $more n] {
  1225.     man-puts $more<BR>
  1226. }
  1227. man-puts <DL><DD>
  1228. foreach more2 [split $more2 n] {
  1229.     man-puts $more2<BR>
  1230. }
  1231. man-puts </DL><DD>
  1232. foreach more3 [split $more3 n] {
  1233.     man-puts $more3<BR>
  1234. }
  1235. man-puts </DL>
  1236.     } elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
  1237. man-puts <P><DL><DD>
  1238. foreach more [split $more n] {
  1239.     man-puts $more<BR>
  1240. }
  1241. man-puts <DL><DD>
  1242. foreach more2 [split $more2 n] {
  1243.     man-puts $more2<BR>
  1244. }
  1245. man-puts </DL></DL><P>
  1246.     } elseif {[match-text .RS .sp @more .sp .RE .fi]} {
  1247. man-puts <P><DL><DD>
  1248. foreach more [split $more n] {
  1249.     man-puts $more<BR>
  1250. }
  1251. man-puts </DL><P>
  1252.     } else {
  1253. manerror "ignoring $line"
  1254.     }
  1255. }
  1256. .fi {
  1257.     manerror "ignoring $line"
  1258. }
  1259. .na -
  1260. .ad -
  1261. .UL -
  1262. .ne {
  1263.     manerror "ignoring $line"
  1264. }
  1265. default {
  1266.     manerror "unrecognized format directive: $line"
  1267. }
  1268.     }
  1269. }
  1270. ##
  1271. ## merge copyright listings
  1272. ## 
  1273. proc merge-copyrights {l1 l2} {
  1274.     foreach copyright [concat $l1 $l2] {
  1275. if {[regexp {^Copyright +(c) +(d+) +(by +)?(w.*)$} $copyright all date by who]} {
  1276.     lappend dates($who) $date
  1277.     continue
  1278. }
  1279. if {[regexp {^Copyright +(c) +(d+)-(d+) +(by +)?(w.*)$} $copyright all from to by who]} {
  1280.     for {set date $from} {$date <= $to} {incr date} {
  1281. lappend dates($who) $date
  1282.     }
  1283.     continue
  1284. }
  1285. if {[regexp {^Copyright +(c) +(d+), *(d+) +(by +)?(w.*)$} $copyright all date1 date2 by who]} {
  1286.     lappend dates($who) $date1 $date2
  1287.     continue
  1288. }
  1289. puts "oops: $copyright"
  1290.     }
  1291.     foreach who [array names dates] {
  1292. set list [lsort $dates($who)]
  1293. if {[llength $list] == 1 || [lindex $list 0] == [lrange $list end end]} {
  1294.     lappend merge "Copyright (c) [lindex $list 0] $who"
  1295. } else {
  1296.     lappend merge "Copyright (c) [lindex $list 0]-[lrange $list end end] $who"
  1297. }
  1298.     }
  1299.     return [lsort $merge]
  1300. }
  1302. proc makedirhier {dir} {
  1303.     if {![file isdirectory $dir] && 
  1304.     [catch {file mkdir $dir} error]} {
  1305. return -code error "cannot create directory $dir: $error"
  1306.     }
  1307. }
  1309. ##
  1310. ## foreach of the man directories specified by args
  1311. ## convert manpages into hypertext in the directory
  1312. ## specified by html.
  1313. ##
  1314. proc make-man-pages {html args} {
  1315.     global env manual overall_title tcltkdesc
  1316.     makedirhier $html
  1317.     set manual(short-toc-n) 1
  1318.     set manual(short-toc-fp) [open $html/contents.htm w]
  1319.     puts $manual(short-toc-fp) "<HTML><HEAD><TITLE>$overall_title</TITLE></HEAD>"
  1320.     puts $manual(short-toc-fp) "<BODY><HR><H3>$overall_title</H3><HR><DL>"
  1321.     set manual(merge-copyrights) {}
  1322.     foreach arg $args {
  1323. if {$arg == ""} {continue}
  1324. set manual(wing-glob) [lindex $arg 0]
  1325. set manual(wing-name) [lindex $arg 1]
  1326. set manual(wing-file) [lindex $arg 2]
  1327. set manual(wing-description) [lindex $arg 3]
  1328. set manual(wing-copyrights) {}
  1329. makedirhier $html/$manual(wing-file)
  1330. set manual(wing-toc-fp) [open $html/$manual(wing-file)/contents.htm w]
  1331. # whistle
  1332. puts stderr "scanning section $manual(wing-name)"
  1333. # put the entry for this section into the short table of contents
  1334. puts $manual(short-toc-fp) "<DT><A HREF="$manual(wing-file)/contents.htm">$manual(wing-name)</A><DD>$manual(wing-description)"
  1335. # initialize the wing table of contents
  1336. puts $manual(wing-toc-fp) "<HTML><HEAD><TITLE>$manual(wing-name) Manual</TITLE></HEAD>"
  1337. puts $manual(wing-toc-fp) "<BODY><HR><H3>$manual(wing-name)</H3><HR>"
  1338. # initialize the short table of contents for this section
  1339. set manual(wing-toc) {}
  1340. # initialize the man directory for this section
  1341. makedirhier $html/$manual(wing-file)
  1342. # initialize the long table of contents for this section
  1343. set manual(long-toc-n) 1
  1344. # get the manual pages for this section
  1345. set manual(pages) [lsort [glob $manual(wing-glob)]]
  1346. if {[lsearch -glob $manual(pages) */options.n] >= 0} {
  1347.     set n [lsearch $manual(pages) */options.n]
  1348.     set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]"
  1349. }
  1350. # set manual(pages) [lrange $manual(pages) 0 5]
  1351. foreach manual(page) $manual(pages) {
  1352.     # whistle
  1353.     puts stderr "scanning page $manual(page)"
  1354.     set manual(tail) [file tail $manual(page)]
  1355.     set manual(name) [file root $manual(tail)]
  1356.     set manual(section) {}
  1357.     if {[lsearch {case pack-old menubar} $manual(name)] >= 0} {
  1358. # obsolete
  1359. manerror "discarding $manual(name)"
  1360. continue
  1361.     }
  1362.     set manual(infp) [open $manual(page)]
  1363.     set manual(text) {}
  1364.     set manual(partial-text) {}
  1365.     foreach p {.RS .DS .CS .SO} {
  1366. set manual($p) 0
  1367.     }
  1368.     set manual(stack) {}
  1369.     set manual(section) {}
  1370.     set manual(section-toc) {}
  1371.     set manual(section-toc-n) 1
  1372.     set manual(copyrights) {}
  1373.     lappend manual(all-pages) $manual(wing-file)/$manual(tail)
  1374.     manreport 100 $manual(name)
  1375.     while {[gets $manual(infp) line] >= 0} {
  1376. manreport 100 $line
  1377. if {[regexp {^[`'][/\]} $line]} {
  1378.     if {[regexp {Copyright (c).*$} $line copyright]} {
  1379. lappend manual(copyrights) $copyright
  1380.     }
  1381.     # comment
  1382.     continue
  1383. }
  1384. if {"$line" == {'}} {
  1385.     # comment
  1386.     continue
  1387. }
  1388. if {[parse-directive $line code rest]} {
  1389.     switch -exact $code {
  1390. .ad - .na - .so - .ne - .AS - .VE - .VS -
  1391. . {
  1392.     # ignore
  1393.     continue
  1394. }
  1395.     }
  1396.     if {"$manual(partial-text)" != {}} {
  1397. lappend manual(text) [process-text $manual(partial-text)]
  1398. set manual(partial-text) {}
  1399.     }
  1400.     switch -exact $code {
  1401. .SH - .SS {
  1402.     if {[llength $rest] == 0} {
  1403. gets $manual(infp) rest
  1404.     }
  1405.     lappend manual(text) "$code [unquote $rest]"
  1406. }
  1407. .TH {
  1408.     lappend manual(text) "$code [unquote $rest]"
  1409. }
  1410. .HS - .UL -
  1411. .ta {
  1412.     lappend manual(text) "$code [unquote $rest]"
  1413. }
  1414. .BS - .BE - .br - .fi - .sp -
  1415. .nf {
  1416.     if {"$rest" != {}} {
  1417. manerror "unexpected argument: $line"
  1418.     }
  1419.     lappend manual(text) $code
  1420. }
  1421. .AP {
  1422.     lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \fB[lindex $rest 1]\fR ([lindex $rest 2])"]]
  1423. }
  1424. .IP {
  1425.     regexp {^(.*) +d+$} $rest all rest
  1426.     lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
  1427. }
  1428. .TP {
  1429.     while {[is-a-directive [set next [gets $manual(infp)]]]} {
  1430.      manerror "ignoring $next after .TP"
  1431.     }
  1432.     if {"$next" != {'}} {
  1433. lappend manual(text) ".IP [process-text $next]"
  1434.     }
  1435. }
  1436. .OP {
  1437.     lappend manual(text) [concat .OP [process-text 
  1438.     "\fB[lindex $rest 0]\fR \fB[lindex $rest 1]\fR \fB[lindex $rest 2]\fR"]]
  1439. }
  1440. .PP -
  1441. .LP {
  1442.     lappend manual(text) {.PP}
  1443. }
  1444. .RS {
  1445.     incr manual(.RS)
  1446.     lappend manual(text) $code
  1447. }
  1448. .RE {
  1449.     incr manual(.RS) -1
  1450.     lappend manual(text) $code
  1451. }
  1452. .SO {
  1453.     incr manual(.SO)
  1454.     lappend manual(text) $code
  1455. }
  1456. .SE {
  1457.     incr manual(.SO) -1
  1458.     lappend manual(text) $code
  1459. }
  1460. .DS {
  1461.     incr manual(.DS)
  1462.     lappend manual(text) $code
  1463. }
  1464. .DE {
  1465.     incr manual(.DS) -1
  1466.     lappend manual(text) $code
  1467. }
  1468. .CS {
  1469.     incr manual(.CS)
  1470.     lappend manual(text) $code
  1471. }
  1472. .CE {
  1473.     incr manual(.CS) -1
  1474.     lappend manual(text) $code
  1475. }
  1476. .de {
  1477.     while {[gets $manual(infp) line] >= 0} {
  1478. if {[string match "..*" $line]} {
  1479.     break
  1480. }
  1481.     }
  1482. }
  1483. .. {
  1484.     error "found .. outside of .de"
  1485. }
  1486. default {
  1487.     manerror "unrecognized format directive: $line"
  1488. }
  1489.     }
  1490. } else {
  1491.     if {$manual(partial-text) == ""} {
  1492. set manual(partial-text) $line
  1493.     } else {
  1494. append manual(partial-text) n$line
  1495.     }
  1496. }
  1497.     }
  1498.     if {$manual(partial-text) != ""} {
  1499. lappend manual(text) [process-text $manual(partial-text)]
  1500.     }
  1501.     close $manual(infp)
  1502.     # fixups
  1503.     if {$manual(.RS) != 0} {
  1504. if {$manual(name) != "selection"} {
  1505.     puts "unbalanced .RS .RE"
  1506. }
  1507.     }
  1508.     if {$manual(.DS) != 0} {
  1509. puts "unbalanced .DS .DE"
  1510.     }
  1511.     if {$manual(.CS) != 0} {
  1512. puts "unbalanced .CS .CE"
  1513.     }
  1514.     if {$manual(.SO) != 0} {
  1515. puts "unbalanced .SO .SE"
  1516.     }
  1517.     # output conversion
  1518.     open-text
  1519.     if {[next-op-is .HS rest]} {
  1520. set manual($manual(name)-title) 
  1521. "[lrange $rest 1 end] [lindex $rest 0] manual page"
  1522. while {[more-text]} {
  1523.     set line [next-text]
  1524.     if {[is-a-directive $line]} {
  1525. output-directive $line
  1526.     } else {
  1527. man-puts $line
  1528.     }
  1529. }
  1530. man-puts <HR><PRE>
  1531. foreach copyright $manual(copyrights) {
  1532.     man-puts "<A HREF="../copyright.htm">Copyright</A> &#169; [lrange $copyright 2 end]"
  1533. }
  1534. man-puts "<A HREF="../copyright.htm">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.</PRE>"
  1535. set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)]
  1536.     } elseif {[next-op-is .TH rest]} {
  1537. set manual($manual(name)-title) "[lrange $rest 4 end] - [lindex $rest 0] manual page"
  1538. while {[more-text]} {
  1539.     set line [next-text]
  1540.     if {[is-a-directive $line]} {
  1541. output-directive $line
  1542.     } else {
  1543. man-puts $line
  1544.     }
  1545. }
  1546. man-puts <HR><PRE>
  1547. foreach copyright $manual(copyrights) {
  1548.     man-puts "<A HREF="../copyright.htm">Copyright</A> &#169; [lrange $copyright 2 end]"
  1549. }
  1550. man-puts "<A HREF="../copyright.htm">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.</PRE>"
  1551. set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)]
  1552.     } else {
  1553. manerror "no .HS or .TH record found"
  1554.     }
  1555.     #
  1556.     # make the long table of contents for this page
  1557.     #
  1558.     set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL><HR>]
  1559. }
  1561. #
  1562. # make the wing table of contents for the section
  1563. #
  1564. set width 0
  1565. foreach name $manual(wing-toc) {
  1566.     if {[string length $name] > $width} {
  1567. set width [string length $name]
  1568.     }
  1569. }
  1570. set perline [expr {120 / $width}]
  1571. set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
  1572. set n 0
  1573.         catch {unset rows}
  1574. foreach name [lsort $manual(wing-toc)] {
  1575.     set tail $manual(name-$name)
  1576.     if {[llength $tail] > 1} {
  1577. manerror "$name is defined in more than one file: $tail"
  1578. set tail [lindex $tail [expr {[llength $tail]-1}]]
  1579.     }
  1580.     set tail [file tail $tail]
  1581.     append rows([expr {$n%$nrows}]) 
  1582.     "<td> <a href="$tail.htm">$name</a>"
  1583.     incr n
  1584. }
  1585. puts $manual(wing-toc-fp) <table>
  1586.         foreach row [lsort -integer [array names rows]] {
  1587.     puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
  1588. }
  1589. puts $manual(wing-toc-fp) </table>
  1591. #
  1592. # insert wing copyrights
  1593. #
  1594. puts $manual(wing-toc-fp) "<HR><PRE>"
  1595. foreach copyright $manual(wing-copyrights) {
  1596.     puts $manual(wing-toc-fp) "<A HREF="../copyright.htm">Copyright</A> &#169; [lrange $copyright 2 end]"
  1597. }
  1598. puts $manual(wing-toc-fp) "<A HREF="../copyright.htm">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr."
  1599. puts $manual(wing-toc-fp) "</PRE></BODY></HTML>"
  1600. close $manual(wing-toc-fp)
  1601. set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]
  1602.     }
  1604.     ##
  1605.     ## build the keyword index.
  1606.     ##
  1607.     proc strcasecmp {a b} { return [string compare -nocase $a $b] }
  1608.     set keys [lsort -command strcasecmp [array names manual keyword-*]]
  1609.     makedirhier $html/Keywords
  1610.     catch {eval file delete -- [glob $html/Keywords/*]}
  1611.     puts $manual(short-toc-fp) "<DT><A HREF="Keywords/contents.htm">Keywords</A><DD>The keywords from the $tcltkdesc man pages."
  1612.     set keyfp [open $html/Keywords/contents.htm w]
  1613.     puts $keyfp "<HTML><HEAD><TITLE>$tcltkdesc Keywords</TITLE></HEAD>"
  1614.     puts $keyfp "<BODY><HR><H3>$tcltkdesc Keywords</H3><HR><H2>"
  1615.     foreach a {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} {
  1616. puts $keyfp "<A HREF="$a.htm">$a</A>"
  1617. set afp [open $html/Keywords/$a.htm w]
  1618. puts $afp "<HTML><HEAD><TITLE>$tcltkdesc Keywords - $a</TITLE></HEAD>"
  1619. puts $afp "<BODY><HR><H3>$tcltkdesc Keywords - $a</H3><HR><H2>"
  1620. foreach b {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} {
  1621.     puts $afp "<A HREF="$b.htm">$b</A>"
  1622. }
  1623. puts $afp "</H2><HR><DL>"
  1624. foreach k $keys {
  1625.     if {[string match -nocase "keyword-${a}*" $k]} {
  1626. set k [string range $k 8 end]
  1627. puts $afp "<DT><A NAME="$k">$k</A><DD>"
  1628. set refs {}
  1629. foreach man $manual(keyword-$k) {
  1630.     set name [lindex $man 0]
  1631.     set file [lindex $man 1]
  1632.     lappend refs "<A HREF="../$file">$name</A>"
  1633. }
  1634. puts $afp [join $refs {, }]
  1635.     }
  1636. }
  1637. puts $afp "</DL><HR><PRE>"
  1638. # insert merged copyrights
  1639. foreach copyright $manual(merge-copyrights) {
  1640.     puts $afp "<A HREF="copyright.htm">Copyright</A> &#169; [lrange $copyright 2 end]"
  1641. }
  1642. puts $afp "<A HREF="copyright.htm">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr."
  1643. puts $afp "</PRE></BODY></HTML>"
  1644. close $afp
  1645.     }
  1646.     puts $keyfp "</H2><HR><PRE>"
  1648.     # insert merged copyrights
  1649.     foreach copyright $manual(merge-copyrights) {
  1650. puts $keyfp "<A HREF="copyright.htm">Copyright</A> &#169; [lrange $copyright 2 end]"
  1651.     }
  1652.     puts $keyfp "<A HREF="copyright.htm">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr."
  1653.     puts $keyfp </PRE><HR></BODY></HTML>
  1654.     close $keyfp
  1656.     ##
  1657.     ## finish off short table of contents
  1658.     ##
  1659.     puts $manual(short-toc-fp) {<DT><A HREF="http://www.elf.org">Source</A><DD>More information about these man pages.}
  1660.     puts $manual(short-toc-fp) "</DL><HR><PRE>"
  1661.     # insert merged copyrights
  1662.     foreach copyright $manual(merge-copyrights) {
  1663. puts $manual(short-toc-fp) "<A HREF="copyright.htm">Copyright</A> &#169; [lrange $copyright 2 end]"
  1664.     }
  1665.     puts $manual(short-toc-fp) "<A HREF="copyright.htm">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr."
  1666.     puts $manual(short-toc-fp) "</PRE></BODY></HTML>"
  1667.     close $manual(short-toc-fp)
  1669.     ##
  1670.     ## output man pages
  1671.     ##
  1672.     unset manual(section)
  1673.     foreach path $manual(all-pages) {
  1674. set manual(wing-file) [file dirname $path]
  1675. set manual(tail) [file tail $path]
  1676. set manual(name) [file root $manual(tail)]
  1677. set text $manual(output-$manual(wing-file)-$manual(name))
  1678. set ntext 0
  1679. foreach item $text {
  1680.     incr ntext [llength [split $item n]]
  1681.     incr ntext
  1682. }
  1683. set toc $manual(toc-$manual(wing-file)-$manual(name))
  1684. set ntoc 0
  1685. foreach item $toc {
  1686.     incr ntoc [llength [split $item n]]
  1687.     incr ntoc
  1688. }
  1689. puts stderr "rescanning page $manual(name) $ntoc/$ntext"
  1690. set manual(outfp) [open $html/$manual(wing-file)/$manual(name).htm w]
  1691. puts $manual(outfp) "<HTML><HEAD><TITLE>$manual($manual(name)-title)</TITLE></HEAD><BODY>"
  1692. if {($ntext > 60) && ($ntoc > 32) || [lsearch {
  1693.     Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType CrtItemType
  1694.     CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetDash
  1695.     GetJustify GetPixels GetVisual ParseArgv QueueEvent
  1696. } $manual(tail)] >= 0} {
  1697.     foreach item $toc {
  1698. puts $manual(outfp) $item
  1699.     }
  1700. }
  1701. foreach item $text {
  1702.     puts $manual(outfp) [insert-cross-references $item]
  1703. }
  1704. puts $manual(outfp) </BODY></HTML>
  1705. close $manual(outfp)
  1706.     }
  1707.     return {}
  1708. }
  1710. parse_command_line
  1712. set tcltkdesc ""; set cmdesc ""; set appdir ""
  1713. if {$build_tcl} {append tcltkdesc "Tcl"; append cmdesc "Tcl"; append appdir "$tcldir"}
  1714. if {$build_tcl && $build_tk} {append tcltkdesc "/"; append cmdesc " and "; append appdir ","}
  1715. if {$build_tk} {append tcltkdesc "Tk"; append cmdesc "Tk"; append appdir "$tkdir"}
  1717. set usercmddesc "The interpreters which implement $cmdesc."
  1718. set tclcmddesc {The commands which the <B>tclsh</B> interpreter implements.}
  1719. set tkcmddesc {The additional commands which the <B>wish</B> interpreter implements.}
  1720. set tcllibdesc {The C functions which a Tcl extended C program may use.}
  1721. set tklibdesc {The additional C functions which a Tk extended C program may use.}
  1723. if {1} {
  1724.     if {[catch {
  1725. make-man-pages $webdir 
  1726.     "$tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd {$usercmddesc}" 
  1727.     [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" : ""}] 
  1728.     [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" : ""}] 
  1729.     [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" : ""}] 
  1730.     [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" : ""}]
  1731.     } error]} {
  1732. puts $errorn$errorInfo
  1733.     }
  1734. }