#!/usr/local/bin/tclsh8.0 # # Convert Ousterhout format man pages into highly crosslinked # hypertext. # # Along the way detect many unmatched font changes and other odd # things. # # Note well, this program is a hack rather than a piece of software # engineering. In that sense it's probably a good example of things # that a scripting language, like Tcl, can do well. It is offered as # an example of how someone might convert a specific set of man pages # into hypertext, not as a general solution to the problem. If you # try to use this, you'll be very much on your own. # # Copyright (c) 1995-1997 Roger E. Critchlow Jr # # The authors hereby grant permission to use, copy, modify, distribute, # and license this software and its documentation for any purpose, provided # that existing copyright notices are retained in all copies and that this # notice is included verbatim in any distributions. No written agreement, # license, or royalty fee is required for any of the authorized uses. # Modifications to this software may be copyrighted by their authors # and need not follow the licensing terms described here, provided that # the new terms are clearly indicated on the first page of each file where # they apply. # # IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY # FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES # ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY # DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. # # THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE # IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE # NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR # MODIFICATIONS. # # Revisions: # May 15, 1995 - initial release # May 16, 1995 - added a back to home link to toplevel table of # contents. # May 18, 1995 - broke toplevel table of contents into separate # pages for each section, and broke long table of contents # into a one page for each man page. # Mar 10, 1996 - updated for tcl7.5b3/tk4.1b3 # Apr 14, 1996 - incorporated command line parsing from Tom Tromey, # -- thanks Tom. # - updated for tcl7.5/tk4.1 final release. # - converted to same copyright as the man pages. # Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1 # Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions. # Oct 22, 1996 - major hacking on indentation code and elsewhere. # Mar 4, 1997 - # May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions # - cleaned source for tclsh8.0 execution # - renamed output files for windoze installation # - added spaces to tables # Oct 24, 1997 - moved from 8.0b1 to 8.0 release # set Version "0.14" proc parse_command_line {} { global argv Version # These variables determine where the man pages come from and where # the converted pages go to. global tcltkdir tkdir tcldir webdir # Set defaults based on original code. set tcltkdir ../.. set tkdir {} set tcldir {} set webdir ../html # Directory names for Tcl and Tk, in priority order. set tclDirList {tcl8.2 tcl8.1 tcl8.0 tcl tcl7.4 tcl7.5 tcl7.6} set tkDirList {tk8.2 tk8.1 tk8.0 tk tk4.0 tk4.1 tk4.2} # Handle arguments a la GNU: # --version # --help # --srcdir=/path # --htmldir=/path foreach option $argv { switch -glob -- $option { --version { puts "tcltk-man-html $Version" exit 0 } --help { puts "usage: tcltk-man-html \[OPTION\] ...\n" puts " --help print this help, then exit" puts " --version print version number, then exit" puts " --srcdir=DIR find tcl and tk source below DIR" puts " --htmldir=DIR put generated HTML in DIR" exit 0 } --srcdir=* { # length of "--srcdir=" is 9. set tcltkdir [string range $option 9 end] } --htmldir=* { # length of "--htmldir=" is 10 set webdir [string range $option 10 end] } default { puts stderr "tcltk-man-html: unrecognized option -- `$option'" exit 1 } } } # Find Tcl. foreach dir $tclDirList { if {[file isdirectory $tcltkdir/$dir]} then { set tcldir $dir break } } if {$tcldir == ""} then { puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" exit 1 } # Find Tk. foreach dir $tkDirList { if {[file isdirectory $tcltkdir/$dir]} then { set tkdir $dir break } } if {$tkdir == ""} then { puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" exit 1 } # the title for the man pages overall global overall_title set overall_title "[capitalize $tcldir]/[capitalize $tkdir] Manual" } proc capitalize {string} { return [string toupper [string index $string 0]][string range $string 1 end] } ## ## ## set manual(report-level) 1; proc manerror {msg} { global manual; set name {}; set subj {}; if {[info exists manual(name)]} { set name $manual(name); } if {[info exists manual(section)] && "$manual(section)" != {}} { puts stderr "$name: $manual(section): $msg"; } else { puts stderr "$name: $msg"; } } proc manreport {level msg} { global manual; if {$level < $manual(report-level)} { manerror $msg; } } proc fatal {msg} { global manual; manerror $msg; exit 1; } ## ## parsing ## proc unquote arg { regsub -all \" $arg {} arg; return $arg; } proc parse-directive {line codename restname} { upvar $codename code $restname rest; return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest]; } proc process-text {text} { global manual; # preprocess text regsub -all {\\&} $text \t text; # some kind of tab? regsub -all {&} $text {\&} text; regsub -all {\\\\} $text {\\} text; # reverse solidus, ie backslash regsub -all {\\ } $text {\ } text; # non breaking space regsub -all {\\%} $text {} text; # don't break word following? regsub -all "\\\\\n" $text "\n" text; # regsub -all \" $text {\"} text; regsub -all {<} $text {\<} text; regsub -all {>} $text {\>} text; regsub -all {\\-\\\|\\-} $text -- text; # two hyphens regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens regsub -all {\\-} $text - text; # a hyphen regsub -all {\\0} $text { } text; # a space # regsub -all {\\\|} $text | text; # a very thin space regsub -all {\\e} $text {\\} text; # reverse solidus, ie backslash regsub -all {\\\(\+-} $text {\±} text; # plus or minus sign regsub -all {\\fP} $text {\\fR} text; # a funky font in expr.n regsub -all {\\\.} $text . text; # a plain . regsub -all "\\\\\n" $text "\\&\#92;\n" text; # an escaped newline while {[regexp {\\} $text]} { # C R if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue # B R if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue # B I if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text {\1\2\\fI\3} text]} continue # I R if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue # I B if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text {\1\2\\fB\3} text]} continue # B B, I I, R R if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text {\1\\fB\2\3} ntext] || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text {\1\\fI\2\3} ntext] || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text {\1\\fR\2\3} ntext]} { manerror "process-text: impotent font change: $text"; set text $ntext; continue; } # unrecognized manerror "process-text: uncaught backslash: $text" regsub -all {\\} $text {#92;} text } return $text } ## ## pass 2 text input and matching ## proc open-text {} { global manual; set manual(text-length) [llength $manual(text)]; set manual(text-pointer) 0; } proc more-text {} { global manual; return [expr $manual(text-pointer) < $manual(text-length)]; } proc next-text {} { global manual; if {[more-text]} { set text [lindex $manual(text) $manual(text-pointer)]; incr manual(text-pointer); return $text; } manerror "read past end of text"; error "fatal"; } proc is-a-directive {line} { return [expr {[string first . $line] == 0}] } proc split-directive {line opname restname} { upvar $opname op $restname rest set op [string range $line 0 2]; set rest [string trim [string range $line 3 end]]; } proc next-op-is {op restname} { global manual; upvar $restname rest; if {[more-text]} { set text [lindex $manual(text) $manual(text-pointer)]; if {[string compare [string range $text 0 2] $op] == 0} { set rest [string range $text 4 end]; incr manual(text-pointer); return 1; } } return 0; } proc backup-text {n} { global manual; if {$manual(text-pointer)-$n >= 0} { incr manual(text-pointer) -$n; } } proc match-text args { global manual; set nargs [llength $args]; if {$manual(text-pointer) + $nargs > $manual(text-length)} { return 0; } set nback 0; foreach arg $args { if { ! [more-text]} { backup-text $nback; return 0; } set arg [string trim $arg]; set targ [string trim [lindex $manual(text) $manual(text-pointer)]]; if {"$arg" == "$targ"} { incr nback; incr manual(text-pointer); continue; } if {[regexp {^@([_a-zA-Z0-9]+)$} $arg all name]} { upvar $name var; set var $targ; incr nback; incr manual(text-pointer); continue; } if {[regexp {^(\.[a-zA-Z][a-zA-Z])@([_a-zA-Z0-9]+)$} $arg all op name] && "$op" == "[lindex $targ 0]"} { upvar $name var; set var [lrange $targ 1 end]; incr nback; incr manual(text-pointer); continue; } backup-text $nback; return 0; } return 1; } proc expand-next-text {n} { global manual; return [join [lrange $manual(text) $manual(text-pointer) [expr $manual(text-pointer)+$n-1]] \n\n]; } ## ## pass 2 output ## proc man-puts {text} { global manual; lappend manual(output-$manual(wing-file)-$manual(name)) $text; } ## ## build hypertext links to tables of contents ## proc long-toc {text} { global manual; set here M[incr manual(section-toc-n)] set there L[incr manual(long-toc-n)]; lappend manual(section-toc) "
$text"; return "$text"; } proc option-toc {name class switch} { global manual; if {"$manual(section)" == {WIDGET-SPECIFIC OPTIONS}} { # link the defined option into the long table of contents set link [long-toc "$switch, $name, $class"]; regsub -- "$switch, $name, $class" $link "$switch" link; return $link; } elseif {"$manual(name):$manual(section)" == {options:DESCRIPTION}} { # link the defined standard option to the long table of # contents and make a target for the standard option references # from other man pages. set first [lindex $switch 0]; set here M$first; set there L[incr manual(long-toc-n)]; set manual(standard-option-$first) "$switch, $name, $class"; lappend manual(section-toc) "
$switch, $name, $class"; return "$switch"; } else { error "option-toc in $manual(name) section $manual(section)"; } } proc std-option-toc {name} { global manual; if {[info exists manual(standard-option-$name)]} { lappend manual(section-toc)
$manual(standard-option-$name); return $manual(standard-option-$name); } set here M[incr manual(section-toc-n)] set there L[incr manual(long-toc-n)]; set other M$name; lappend manual(section-toc) "
$name"; return "$name"; } ## ## process the widget option section ## in widget and options man pages ## proc output-widget-options {rest} { global manual man-puts
; lappend manual(section-toc)
; backup-text 1; set para {} while {[next-op-is .OP rest]} { switch -exact [llength $rest] { 3 { set switch [lindex $rest 0]; set name [lindex $rest 1]; set class [lindex $rest 2]; } 5 { set switch [lrange $rest 0 2]; set name [lindex $rest 3]; set class [lindex $rest 4]; } default { fatal "bad .OP $rest"; } } if { ! [regexp {^(<.>)([-a-zA-Z0-9 ]+)()$} $switch all oswitch switch cswitch]} { if { ! [regexp {^(<.>)([-a-zA-Z0-9 ]+) or ([-a-zA-Z0-9 ]+)()$} $switch all oswitch switch1 switch2 cswitch]} { error "not Switch: $switch"; } else { set switch "$switch1$cswitch or $oswitch$switch2"; } } if { ! [regexp {^(<.>)([a-zA-Z0-9]*)()$} $name all oname name cname]} { error "not Name: $name"; } if { ! [regexp {^(<.>)([a-zA-Z0-9]*)()$} $class all oclass class cclass]} { error "not Class: $class"; } man-puts "$para
Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"; man-puts "
Database Name: $oname$name$cname"; man-puts "
Database Class: $oclass$class$cclass"; man-puts
[next-text]; set para

} man-puts

; lappend manual(section-toc)
; } ## ## process .RS lists ## proc output-RS-list {} { global manual; if {[next-op-is .IP rest]} { output-IP-list .RS .IP $rest; if {[match-text .RE .sp .RS @rest .IP @rest2]} { man-puts

$rest output-IP-list .RS .IP $rest2 } if {[match-text .RE .sp .RS @rest .RE]} { man-puts

$rest return; } if {[next-op-is .RE rest]} { return; } } man-puts

; while {[more-text]} { set line [next-text]; if {[is-a-directive $line]} { split-directive $line code rest switch -exact $code { .RE { break; } .SH { manerror "unbalanced .RS at section end"; backup-text 1; break; } default { output-directive $line; } } } else { man-puts $line; } } man-puts
; } ## ## process .IP lists which may be plain indents, ## numeric lists, or definition lists ## proc output-IP-list {context code rest} { global manual; if {"$rest" == {}} { # blank label, plain indent, no contents entry man-puts

while {[more-text]} { set line [next-text]; if {[is-a-directive $line]} { split-directive $line code rest if {"$code" == {.IP} && "$rest" == {}} { man-puts "

"; continue; } if {[lsearch {.br .DS .RS} $code] >= 0} { output-directive $line; } else { backup-text 1; break; } } else { man-puts $line; } } man-puts

; } else { # labelled list, make contents if {"$context" != {.SH}} { man-puts

; } man-puts

lappend manual(section-toc)
; backup-text 1 set accept_RE 0 while {[more-text]} { set line [next-text]; if {[is-a-directive $line]} { split-directive $line code rest switch -exact $code { .IP { if {$accept_RE} { output-IP-list .IP $code $rest continue; } if {"$manual(section)" == {ARGUMENTS} || [regexp {^\[[0-9]+\]$} $rest]} { man-puts "

$rest
"; } else { man-puts "

[long-toc $rest]
"; } if {"$manual(name):$manual(section)" == {selection:DESCRIPTION}} { if {[match-text .RE @rest .RS .RS]} { man-puts
[long-toc $rest]
; } } } .sp - .br - .DS - .CS { output-directive $line; } .RS { if {[match-text .RS]} { output-directive $line; incr accept_RE 1; } elseif {[match-text .CS]} { output-directive .CS incr accept_RE 1; } elseif {[match-text .PP]} { output-directive .PP incr accept_RE 1; } elseif {[match-text .DS]} { output-directive .DS incr accept_RE 1; } else { output-directive $line; } } .PP { if {[match-text @rest1 .br @rest2 .RS]} { # yet another nroff kludge as above man-puts "

[long-toc $rest1]" man-puts "
[long-toc $rest2]
" incr accept_RE 1; } elseif {[match-text @rest .RE]} { # gad, this is getting ridiculous if { ! $accept_RE} { man-puts "

$rest

" backup-text 1 break; } else { man-puts "

$rest" incr accept_RE -1 } } elseif {$accept_RE} { output-directive $line } else { backup-text 1 break; } } .RE { if { ! $accept_RE} { backup-text 1; break; } incr accept_RE -1 } default { backup-text 1; break; } } } else { man-puts $line; } } man-puts

; lappend manual(section-toc)
; if {$accept_RE} { manerror "missing .RE in output-IP-list" } } } ## ## handle the NAME section lines ## there's only one line in the NAME section, ## consisting of a comma separated list of names, ## followed by a hyphen and a short description. ## proc output-name {line} { global manual; # split name line into pieces regexp {^([^-]+) - (.*)$} $line all head tail; # output line to manual page untouched man-puts $line # output line to long table of contents lappend manual(section-toc)
$line
# separate out the names for future reference foreach name [split $head ,] { set name [string trim $name]; if {[llength $name] > 1} { manerror "name has a space: {$name}\nfrom: $line"; } lappend manual(wing-toc) $name; lappend manual(name-$name) $manual(wing-file)/$manual(name); } } ## ## build a cross-reference link if appropriate ## proc cross-reference {ref} { global manual; if {[string match Tcl_* $ref]} { set lref $ref; } elseif {[string match Tk_* $ref]} { set lref $ref; } elseif {"$ref" == {Tcl}} { set lref $ref; } else { set lref [string tolower $ref]; } ## ## nothing to reference ## if { ! [info exists manual(name-$lref)]} { foreach name {array file history info interp string trace after clipboard grab image option pack place selection tk tkwait update winfo wm} { if {[regexp "^$name \[a-z0-9]*\$" $lref] && "$manual(tail)" != "$name.n"} { return "$ref"; } } if {[lsearch {stdin stdout stderr end} $lref] >= 0} { # no good place to send these # tcl tokens? # also end } return $ref; } ## ## would be a self reference ## foreach name $manual(name-$lref) { if {[lsearch $name $manual(wing-file)/$manual(name)] >= 0} { return $ref; } } ## ## multiple choices for reference ## if {[llength $manual(name-$lref)] > 1} { set tcl_i [lsearch -glob $manual(name-$lref) *TclCmd*]; set tcl_ref [lindex $manual(name-$lref) $tcl_i]; set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*]; set tk_ref [lindex $manual(name-$lref) $tk_i]; if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} || "$manual(wing-file)" == {TclLib}} { return "$ref"; } if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} || "$manual(wing-file)" == {TkLib}} { return "$ref"; } if {"$lref" == {exit} && "$manual(tail)" == {tclsh.1} && $tcl_i >= 0} { return "$ref"; } puts stderr "multiple cross reference to $ref in $manual(name-$lref) from $manual(wing-file)/$manual(tail)"; return $ref; } ## ## exceptions, sigh, to the rule ## switch $manual(tail) { canvas.n { if {$lref == {focus}} { upvar tail tail; set clue [string first command $tail]; if {$clue < 0 || $clue > 5} { return $ref; } } if {[lsearch {bitmap image text} $lref] >= 0} { return $ref; } } checkbutton.n - radiobutton.n { if {[lsearch {image} $lref] >= 0} { return $ref; } } menu.n { if {[lsearch {checkbutton radiobutton} $lref] >= 0} { return $ref; } } options.n { if {[lsearch {bitmap image set} $lref] >= 0} { return $ref; } } regexp.n { if {[lsearch {string} $lref] >= 0} { return $ref; } } source.n { if {[lsearch {text} $lref] >= 0} { return $ref; } } history.n { if {[lsearch {exec} $lref] >= 0} { return $ref; } } return.n { if {[lsearch {error continue break} $lref] >= 0} { return $ref; } } scrollbar.n { if {[lsearch {set} $lref] >= 0} { return $ref; } } } ## ## return the cross reference ## return "$ref"; } ## ## reference generation errors ## proc reference-error {msg text} { global manual; puts stderr "$manual(tail): $msg: {$text}"; return $text; } ## ## insert as many cross references into this text string as are appropriate ## proc insert-cross-references {text} { global manual; ## ## we identify cross references by: ## ``quotation'' ## emboldening ## Tcl_ prefix ## Tk_ prefix ## [a-zA-Z0-9]+ manual entry ## and we avoid messing with already anchored text ## ## ## find where each item lives ## array set offset [list \ anchor [string first {} $text] \ quote [string first {``} $text] \ end-quote [string first {''} $text] \ bold [string first {} $text] \ end-bold [string first {} $text] \ tcl [string first {Tcl_} $text] \ tk [string first {Tk_} $text] \ Tcl1 [string first {Tcl manual entry} $text] \ Tcl2 [string first {Tcl overview manual entry} $text] \ ]; ## ## accumulate a list ## foreach name [array names offset] { if {$offset($name) >= 0} { set invert($offset($name)) $name; lappend offsets $offset($name); } } ## ## if nothing, then we're done. ## if { ! [info exists offsets]} { return $text; } ## ## sort the offsets ## set offsets [lsort -integer $offsets]; ## ## see which we want to use ## switch -exact $invert([lindex $offsets 0]) { anchor { if {$offset(end-anchor) < 0} { return [reference-error {Missing end anchor} $text]; } set head [string range $text 0 $offset(end-anchor)]; set tail [string range $text [expr $offset(end-anchor)+1] end]; return $head[insert-cross-references $tail] } quote { if {$offset(end-quote) < 0} { return [reference-error {Missing end quote} $text]; } if {"$invert([lindex $offsets 1])" == {tk}} { set offsets [lreplace $offsets 1 1]; } if {"$invert([lindex $offsets 1])" == {tcl}} { set offsets [lreplace $offsets 1 1]; } switch -exact $invert([lindex $offsets 1]) { end-quote { set head [string range $text 0 [expr $offset(quote)-1]] set body [string range $text [expr $offset(quote)+2] [expr $offset(end-quote)-1]]; set tail [string range $text [expr $offset(end-quote)+2] end]; return $head``[cross-reference $body]''[insert-cross-references $tail]; } bold - anchor { set head [string range $text 0 [expr $offset(end-quote)+1]] set tail [string range $text [expr $offset(end-quote)+2] end]; return $head[insert-cross-references $tail]; } } return [reference-error {Uncaught quote case} $text]; } bold { if {$offset(end-bold) < 0} { return $text; } if {"$invert([lindex $offsets 1])" == {tk}} { set offsets [lreplace $offsets 1 1]; } if {"$invert([lindex $offsets 1])" == {tcl}} { set offsets [lreplace $offsets 1 1]; } switch -exact $invert([lindex $offsets 1]) { end-bold { set head [string range $text 0 [expr $offset(bold)-1]] set body [string range $text [expr $offset(bold)+3] [expr $offset(end-bold)-1]]; set tail [string range $text [expr $offset(end-bold)+4] end]; return $head[cross-reference $body][insert-cross-references $tail]; } anchor { set head [string range $text 0 [expr $offset(end-bold)+3]] set tail [string range $text [expr $offset(end-bold)+4] end]; return $head[insert-cross-references $tail]; } } return [reference-error {Uncaught bold case} $text]; } tk { set head [string range $text 0 [expr $offset(tk)-1]] set tail [string range $text $offset(tk) end]; if { ! [regexp {^(Tk_[a-zA-Z0-9_]+)(.*)$} $tail all body tail]} { return [reference-error {Tk regexp failed} $text]; } return $head[cross-reference $body][insert-cross-references $tail]; } tcl { set head [string range $text 0 [expr $offset(tcl)-1]] set tail [string range $text $offset(tcl) end]; if { ! [regexp {^(Tcl_[a-zA-Z0-9_]+)(.*)$} $tail all body tail]} { return [reference-error {Tcl regexp failed} $text]; } return $head[cross-reference $body][insert-cross-references $tail]; } Tcl1 - Tcl2 { set off [lindex $offsets 0]; set head [string range $text 0 [expr $off-1]]; set body Tcl set tail [string range $text [expr $off+3] end]; return $head[cross-reference $body][insert-cross-references $tail]; } end-anchor - end-bold - end-quote { return [reference-error "Out of place $invert([lindex $offsets 0])" $text]; } } } ## ## process formatting directives ## proc output-directive {line} { global manual; # process format directive split-directive $line code rest switch -exact $code { .BS - .BE { # man-puts
; } .SH { # drain any open lists # announce the subject set manual(section) $rest; # start our own stack of stuff set manual($manual(name)-$manual(section)) {}; lappend manual(has-$manual(section)) $manual(name); man-puts "

[long-toc $manual(section)]

"; # some sections can simply free wheel their way through the text # some sections can be processed in their own loops switch -exact $manual(section) { NAME { if {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} { # these manual pages have two NAME sections if {[info exists manual($manual(tail)-NAME)]} { return; } set manual($manual(tail)-NAME) 1 } set names {} while {1} { set line [next-text]; if {[is-a-directive $line]} { backup-text 1; output-name [join $names { }] return; } else { lappend names [string trim $line] } } } SYNOPSIS { lappend manual(section-toc)
; while {1} { if {[next-op-is .nf rest] || [next-op-is .br rest] || [next-op-is .fi rest]} { continue; } if {[next-op-is .SH rest] || [next-op-is .BE rest] || [next-op-is .SO rest]} { backup-text 1; break; } if {[next-op-is .sp rest]} { #man-puts

; continue; } set more [next-text]; if {[is-a-directive $more]} { manerror "in SYNOPSIS found $more"; backup-text 1; break; } else { foreach more [split $more \n] { man-puts $more
; if {[lsearch {TclLib TkLib} $manual(wing-file)] < 0} { lappend manual(section-toc)

$more; } } } } lappend manual(section-toc)
; return; } {SEE ALSO} { while {[more-text]} { if {[next-op-is .SH rest]} { backup-text 1; return; } set more [next-text]; if {[is-a-directive $more]} { manerror "$more"; backup-text 1; return; } set nmore {}; foreach cr [split $more ,] { set cr [string trim $cr]; if { ! [regexp {^.*$} $cr]} { set cr $cr; } if {[regexp {^(.*)\([13n]\)$} $cr all name]} { set cr $name } lappend nmore $cr; } man-puts [join $nmore {, }]; } return; } KEYWORDS { while {[more-text]} { if {[next-op-is .SH rest]} { backup-text 1; return; } set more [next-text]; if {[is-a-directive $more]} { manerror "$more"; backup-text 1; return; } set keys {} foreach key [split $more ,] { set key [string trim $key] lappend manual(keyword-$key) [list $manual(name) $manual(wing-file)/$manual(name).htm]; set initial [string toupper [string index $key 0]] lappend keys "
$key" } man-puts [join $keys {, }] } return; } } if {[next-op-is .IP rest]} { output-IP-list .SH .IP $rest; return; } if {[next-op-is .PP rest]} { return; } return; } .SO { if {[match-text @stuff .SE]} { output-directive {.SH STANDARD OPTIONS}; set opts {}; foreach line [split $stuff \n] { foreach option [split $line \t] { lappend opts $option; } } man-puts
; lappend manual(section-toc)
; foreach option [lsort $opts] { man-puts "
[std-option-toc $option]"; } man-puts
; lappend manual(section-toc)
; } else { manerror "unexpected .SO format:\n[expand-next-text 2]"; } } .OP { output-widget-options $rest; return; } .IP { output-IP-list .IP .IP $rest; return; } .PP { man-puts

; } .RS { output-RS-list; return; } .RE { manerror "unexpected .RE"; return; } .br { man-puts
; return; } .DE { manerror "unexpected .DE"; return; } .DS { if {[next-op-is .ta rest]} { ; } if {[match-text @stuff .DE]} { man-puts

$stuff
; } elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} { man-puts "
[lindex $ul1 1][lindex $ul2 1]\n$stuff
"; } else { manerror "unexpected .DS format:\n[expand-next-text 2]"; } return; } .CS { if {[next-op-is .ta rest]} { ; } if {[match-text @stuff .CE]} { man-puts
$stuff
; } else { manerror "unexpected .CS format:\n[expand-next-text 2]"; } return; } .CE { manerror "unexpected .CE"; return; } .sp { man-puts

; } .ta { # these are tab stop settings for short tables switch -exact $manual(name):$manual(section) { {bind:MODIFIERS} - {bind:EVENT TYPES} - {bind:BINDING SCRIPTS AND SUBSTITUTIONS} - {expr:OPERANDS} - {expr:MATH FUNCTIONS} - {history:DESCRIPTION} - {history:HISTORY REVISION} - {switch:DESCRIPTION} - {upvar:DESCRIPTION} { return; # fix.me } default { manerror "ignoring $line"; } } } .nf { if {[match-text @more .fi]} { foreach more [split $more \n] { man-puts $more
; } } elseif {[match-text .RS @more .RE .fi]} { man-puts

; foreach more [split $more \n] { man-puts $more
; } man-puts
; } elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} { man-puts
; foreach more [split $more \n] { man-puts $more
; } man-puts
; foreach more2 [split $more2 \n] { man-puts $more2
; } man-puts
; } elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} { man-puts
; foreach more [split $more \n] { man-puts $more
; } man-puts
; foreach more2 [split $more2 \n] { man-puts $more2
; } man-puts
; foreach more3 [split $more3 \n] { man-puts $more3
; } man-puts
; } elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} { man-puts

; foreach more [split $more \n] { man-puts $more
; } man-puts
; foreach more2 [split $more2 \n] { man-puts $more2
; } man-puts

; } elseif {[match-text .RS .sp @more .sp .RE .fi]} { man-puts

; foreach more [split $more \n] { man-puts $more
; } man-puts

; } else { manerror "ignoring $line"; } } .fi { manerror "ignoring $line"; } .na - .ad - .UL - .ne { manerror "ignoring $line"; } default { manerror "unrecognized format directive: $line"; } } } ## ## merge copyright listings ## proc merge-copyrights {l1 l2} { foreach copyright [concat $l1 $l2] { if {[regexp {^Copyright +\(c\) +([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all date by who]} { lappend dates($who) $date; continue; } if {[regexp {^Copyright +\(c\) +([0-9]+)-([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all from to by who]} { for {set date $from} {$date <= $to} {incr date} { lappend dates($who) $date; } continue; } if {[regexp {^Copyright +\(c\) +([0-9]+), *([0-9]+) +(by +)?([A-Za-z].*)$} $copyright all date1 date2 by who]} { lappend dates($who) $date1 $date2; continue; } puts "oops: $copyright"; } foreach who [array names dates] { set list [lsort $dates($who)]; if {[llength $list] == 1 || [lindex $list 0] == [lrange $list end end]} { lappend merge "Copyright (c) [lindex $list 0] $who"; } else { lappend merge "Copyright (c) [lindex $list 0]-[lrange $list end end] $who"; } } return [lsort $merge]; } proc makedirhier {dir} { if { ! [file isdirectory $dir]} { makedirhier [file dirname $dir]; if { ! [file isdirectory $dir]} { if {[catch {exec mkdir $dir} error]} { error "cannot create directory $dir: $error"; } } } } ## ## foreach of the man directories specified by args ## convert manpages into hypertext in the directory ## specified by html. ## proc make-man-pages {html args} { global env manual overall_title; makedirhier $html; if { ! [file isdirectory $html]} { exec mkdir $html; } set manual(short-toc-n) 1; set manual(short-toc-fp) [open $html/contents.htm w]; puts $manual(short-toc-fp) "$overall_title" puts $manual(short-toc-fp) "


$overall_title


"; set manual(merge-copyrights) {} foreach arg $args { set manual(wing-glob) [lindex $arg 0]; set manual(wing-name) [lindex $arg 1]; set manual(wing-file) [lindex $arg 2]; set manual(wing-description) [lindex $arg 3]; set manual(wing-copyrights) {}; makedirhier $html/$manual(wing-file); set manual(wing-toc-fp) [open $html/$manual(wing-file)/contents.htm w]; # whistle puts stderr "scanning section $manual(wing-name)"; # put the entry for this section into the short table of contents puts $manual(short-toc-fp) "
$manual(wing-name)
$manual(wing-description)"; # initialize the wing table of contents puts $manual(wing-toc-fp) "$manual(wing-name) Manual" puts $manual(wing-toc-fp) "

$manual(wing-name)


"; # initialize the short table of contents for this section set manual(wing-toc) {}; # initialize the man directory for this section makedirhier $html/$manual(wing-file); # initialize the long table of contents for this section set manual(long-toc-n) 1; # get the manual pages for this section set manual(pages) [lsort [glob $manual(wing-glob)]]; if {[lsearch -glob $manual(pages) */options.n] >= 0} { set n [lsearch $manual(pages) */options.n]; set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]"; } # set manual(pages) [lrange $manual(pages) 0 5]; foreach manual(page) $manual(pages) { # whistle puts stderr "scanning page $manual(page)"; set manual(tail) [file tail $manual(page)]; set manual(name) [file root $manual(tail)]; set manual(section) {}; if {[lsearch {case pack-old menubar} $manual(name)] >= 0} { # obsolete manerror "discarding $manual(name)"; continue; } set manual(infp) [open "$manual(page)"]; set manual(text) {}; set manual(partial-text) {}; foreach p {.RS .DS .CS .SO} { set manual($p) 0; } set manual(stack) {}; set manual(section) {}; set manual(section-toc) {}; set manual(section-toc-n) 1; set manual(copyrights) {}; lappend manual(all-pages) $manual(wing-file)/$manual(tail); manreport 100 "$manual(name)"; while {[gets $manual(infp) line] >= 0} { manreport 100 $line; if {[regexp {^[`'][/\\]} $line]} { if {[regexp {Copyright \(c\).*$} $line copyright]} { lappend manual(copyrights) $copyright; } # comment continue; } if {"$line" == {'}} { # comment continue; } if {[parse-directive $line code rest]} { switch -exact $code { .ad - .na - .so - .ne - .AS - .VE - .VS - . { # ignore continue; } } if {"$manual(partial-text)" != {}} { lappend manual(text) [process-text $manual(partial-text)]; set manual(partial-text) {}; } switch -exact $code { .SH { if {[llength $rest] == 0} { gets $manual(infp) rest; } lappend manual(text) ".SH [unquote $rest]"; } .TH { lappend manual(text) "$code [unquote $rest]"; } .HS - .UL - .ta { lappend manual(text) "$code [unquote $rest]"; } .BS - .BE - .br - .fi - .sp - .nf { if {"$rest" != {}} { manerror "unexpected argument: $line"; } lappend manual(text) $code; } .AP { lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]; } .IP { regexp {^(.*) +[0-9]+$} $rest all rest lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"; } .TP { set next [gets $manual(infp)]; if {"$next" != {'}} { lappend manual(text) ".IP [process-text $next]"; } } .OP { lappend manual(text) [concat .OP [process-text \ "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]; } .PP - .LP { lappend manual(text) {.PP}; } .RS { incr manual(.RS); lappend manual(text) $code; } .RE { incr manual(.RS) -1; lappend manual(text) $code; } .SO { incr manual(.SO); lappend manual(text) $code; } .SE { incr manual(.SO) -1; lappend manual(text) $code; } .DS { incr manual(.DS); lappend manual(text) $code; } .DE { incr manual(.DS) -1; lappend manual(text) $code; } .CS { incr manual(.CS); lappend manual(text) $code; } .CE { incr manual(.CS) -1; lappend manual(text) $code; } .de { while {[gets $manual(infp) line] >= 0} { if {[regexp {^\.\.} $line]} { break; } } } .. { error "found .. outside of .de"; } default { manerror "unrecognized format directive: $line"; } } } else { if {"$manual(partial-text)" == {}} { set manual(partial-text) $line; } else { append manual(partial-text) \n$line; } } } if {"$manual(partial-text)" != {}} { lappend manual(text) [process-text $manual(partial-text)]; } close $manual(infp); # fixups if {$manual(.RS) != 0} { if {"$manual(name)" != {selection}} { puts "unbalanced .RS .RE"; } } if {$manual(.DS) != 0} { puts "unbalanced .DS .DE"; } if {$manual(.CS) != 0} { puts "unbalanced .CS .CE"; } if {$manual(.SO) != 0} { puts "unbalanced .SO .SE"; } # output conversion open-text; if {[next-op-is .HS rest]} { set manual($manual(name)-title) "[lrange $rest 1 end] [lindex $rest 0] manual page"; while {[more-text]} { set line [next-text]; if {[is-a-directive $line]} { output-directive $line; } else { man-puts $line; } } man-puts
;
		foreach copyright $manual(copyrights) {
		    man-puts "Copyright © [lrange $copyright 2 end]";
		}
		man-puts "Copyright © 1995-1997 Roger E. Critchlow Jr.
"; set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)]; } elseif {[next-op-is .TH rest]} { set manual($manual(name)-title) "[lrange $rest 4 end] - [lindex $rest 0] manual page"; while {[more-text]} { set line [next-text]; if {[is-a-directive $line]} { output-directive $line; } else { man-puts $line; } } man-puts
;
		foreach copyright $manual(copyrights) {
		    man-puts "Copyright © [lrange $copyright 2 end]";
		}
		man-puts "Copyright © 1995-1997 Roger E. Critchlow Jr.
"; set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)]; } else { manerror "no .HS or .TH record found"; } # # make the long table of contents for this page # set manual(toc-$manual(wing-file)-$manual(name)) [concat
$manual(section-toc)

]; } # # make the wing table of contents for the section # set width 0; foreach name $manual(wing-toc) { if {[string length $name] > $width} { set width [string length $name]; } } set perline [expr 120 / $width]; set nrows [expr ([llength $manual(wing-toc)]+$perline)/$perline] set n 0; catch {unset rows} foreach name [lsort $manual(wing-toc)] { set tail $manual(name-$name); if {[llength $tail] > 1} { manerror "$name is defined in more than one file: $tail"; set tail [lindex $tail [expr [llength $tail]-1]]; } set tail [file tail $tail]; append rows([expr $n%$nrows]) " $name" incr n; } puts $manual(wing-toc-fp) ; foreach row [lsort -integer [array names rows]] { puts $manual(wing-toc-fp) $rows($row) } puts $manual(wing-toc-fp)
; # # insert wing copyrights # puts $manual(wing-toc-fp) "
"
	foreach copyright $manual(wing-copyrights) {
	    puts $manual(wing-toc-fp) "Copyright © [lrange $copyright 2 end]";
	}
	puts $manual(wing-toc-fp) "Copyright © 1995-1997 Roger E. Critchlow Jr.";
	puts $manual(wing-toc-fp) "
"; close $manual(wing-toc-fp); set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]; } ## ## build the keyword index. ## proc strcasecmp {a b} { return [string compare [string tolower $a] [string tolower $b]]; } set keys [lsort -command strcasecmp [array names manual keyword-*]]; makedirhier $html/Keywords catch {eval exec rm -f [glob $html/Keywords/*]} puts $manual(short-toc-fp) {
Keywords
The keywords from the Tcl/Tk man pages.}; set keyfp [open $html/Keywords/contents.htm w]; puts $keyfp "Tcl/Tk Keywords" puts $keyfp "

Tcl/Tk Keywords


" 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} { puts $keyfp "$a" set afp [open $html/Keywords/$a.htm w]; puts $afp "Tcl/Tk Keywords - $a" puts $afp "

Tcl/Tk Keywords - $a


" 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} { puts $afp "$b" } puts $afp "


" foreach k $keys { if {[regexp -nocase -- "^keyword-$a" $k]} { set k [string range $k 8 end] puts $afp "
$k
" set refs {} foreach man $manual(keyword-$k) { set name [lindex $man 0]; set file [lindex $man 1] lappend refs "$name"; } puts $afp [join $refs {, }]; } } puts $afp "

"
	# insert merged copyrights
	foreach copyright $manual(merge-copyrights) {
	    puts $afp "Copyright © [lrange $copyright 2 end]";
	}
	puts $afp "Copyright © 1995-1997 Roger E. Critchlow Jr.";
	puts $afp "
" close $afp } puts $keyfp "
"

    # insert merged copyrights
    foreach copyright $manual(merge-copyrights) {
	puts $keyfp "Copyright © [lrange $copyright 2 end]";
    }
    puts $keyfp "Copyright © 1995-1997 Roger E. Critchlow Jr.";
    puts $keyfp 

close $keyfp; ## ## finish off short table of contents ## puts $manual(short-toc-fp) {
Source
More information about these man pages.} puts $manual(short-toc-fp) "

";
    # insert merged copyrights
    foreach copyright $manual(merge-copyrights) {
	puts $manual(short-toc-fp) "Copyright © [lrange $copyright 2 end]";
    }
    puts $manual(short-toc-fp) "Copyright © 1995-1997 Roger E. Critchlow Jr.";
    puts $manual(short-toc-fp) "
"; close $manual(short-toc-fp); ## ## output man pages ## unset manual(section); foreach path $manual(all-pages) { set manual(wing-file) [file dirname $path]; set manual(tail) [file tail $path]; set manual(name) [file root $manual(tail)]; set text $manual(output-$manual(wing-file)-$manual(name)); set ntext 0; foreach item $text { incr ntext [llength [split $item \n]]; incr ntext; } set toc $manual(toc-$manual(wing-file)-$manual(name)); set ntoc 0; foreach item $toc { incr ntoc [llength [split $item \n]]; incr ntoc; } puts stderr "rescanning page $manual(name) $ntoc/$ntext"; set manual(outfp) [open $html/$manual(wing-file)/$manual(name).htm w]; puts $manual(outfp) "$manual($manual(name)-title)" if {$ntext > 60 && $ntoc > 32 || [lsearch {Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType CrtItemType CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetJustify GetPixels GetVisual ParseArgv QueueEvent} $manual(tail)] >= 0} { foreach item $toc { puts $manual(outfp) $item; } } foreach item $text { puts $manual(outfp) [insert-cross-references $item]; } puts $manual(outfp) ; close $manual(outfp); } return {}; } set usercmddesc {The interpreters which implement Tcl and Tk.} set tclcmddesc {The commands which the tclsh interpreter implements.} set tkcmddesc {The additional commands which the wish interpreter implements.} set tcllibdesc {The C functions which a Tcl extended C program may use.} set tklibdesc {The additional C functions which a Tk extended C program may use.} parse_command_line if {1} { if {[catch { make-man-pages $webdir \ "$tcltkdir/{$tkdir,$tcldir}/doc/*.1 {Tcl/Tk Applications} UserCmd {$usercmddesc}" \ "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" \ "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" \ "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" \ "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" } error]} { puts $error\n$errorInfo; } }