$title

From 84a0ece24e8b25066d445fd2001ab751f9f8112d Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 10 Jan 2010 13:19:30 +0000 Subject: Split man2html converter up for ease of maintenance. --- ChangeLog | 6 + tools/tcltk-man2html-utils.tcl | 1285 ++++++++++++++++++++++++++++++++ tools/tcltk-man2html.tcl | 1589 +++++----------------------------------- 3 files changed, 1492 insertions(+), 1388 deletions(-) create mode 100644 tools/tcltk-man2html-utils.tcl diff --git a/ChangeLog b/ChangeLog index 54a592d..ecaa73a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2010-01-10 Donal K. Fellows + + * tools/tcltk-man2html.tcl: Split the man->html converter into + * tools/tcltk-man2html-utils.tcl: two pieces for easier maintenance. + Also made it much less verbose in its printed messages by default. + 2010-01-09 Donal K. Fellows * tools/tcltk-man2html.tcl: Added basic support for building the docs diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl new file mode 100644 index 0000000..bf5d37b --- /dev/null +++ b/tools/tcltk-man2html-utils.tcl @@ -0,0 +1,1285 @@ +## +## Utility functions for Man->HTML converter. Note that these +## functions are specifically intended to work with the format as used +## by Tcl and Tk; they do not cope with arbitrary nroff markup. +## + +set ::manual(report-level) 1 + +proc manerror {msg} { + global manual + set name {} + set subj {} + set procname [lindex [info level -1] 0] + if {[info exists manual(name)]} { + set name $manual(name) + } + if {[info exists manual(section)] && [string length $manual(section)]} { + puts stderr "$name: $manual(section): $procname: $msg" + } else { + puts stderr "$name: $procname: $msg" + } +} + +proc manreport {level msg} { + global manual + if {$level < $manual(report-level)} { + uplevel 1 [list manerror $msg] + } +} + +proc fatal {msg} { + global manual + uplevel 1 [list manerror $msg] + exit 1 +} + +## +## templating +## +proc indexfile {} { + if {[info exists ::TARGET] && $::TARGET eq "devsite"} { + return "index.tml" + } else { + return "contents.htm" + } +} +proc copyright {copyright {level {}}} { + # We don't actually generate a separate copyright page anymore + #set page "${level}copyright.htm" + #return "Copyright © [htmlize-text [lrange $copyright 2 end]]" + # obfuscate any email addresses that may appear in name + set who [string map {@ (at)} [lrange $copyright 2 end]] + return "Copyright © [htmlize-text $who]" +} +proc copyout {copyrights {level {}}} { + set out "

" + foreach c $copyrights { + append out "[copyright $c $level]\n" + } + append out "

" + return $out +} +proc CSS {{level ""}} { + return "\n" +} +proc DOCTYPE {} { + return "" +} +proc htmlhead {title header args} { + set level "" + if {[lindex $args end] eq "../[indexfile]"} { + # XXX hack - assume same level for CSS file + set level "../" + } + set out "[DOCTYPE]\n\n$title\n[CSS $level]\n" + foreach {uptitle url} $args { + set header "$uptitle > $header" + } + append out "

$header

" + global manual + if {[info exists manual(subheader)]} { + set subs {} + foreach {name subdir} $manual(subheader) { + if {$name eq $title} { + lappend subs $name + } else { + lappend subs "$name" + } + } + append out "\n

[join $subs { | }]

" + } + return $out +} + +## +## parsing +## +proc unquote arg { + return [string map [list \" {}] $arg] +} + +proc parse-directive {line codename restname} { + upvar 1 $codename code $restname rest + return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] +} + +proc htmlize-text {text {charmap {}}} { + # contains some extras for use in nroff->html processing + # build on the list passed in, if any + lappend charmap \ + {&} {&} \ + {\\} "\" \ + {\e} "\" \ + {\ } { } \ + {\|} { } \ + {\0} { } \ + \" {"} \ + {<} {<} \ + {>} {>} \ + \u201c "“" \ + \u201d "”" + + return [string map $charmap $text] +} + +proc process-text {text} { + global manual + # preprocess text; note that this is an incomplete map, and will probably + # need to have things added to it as the manuals expand to use them. + set charmap [list \ + {\&} "\t" \ + {\%} {} \ + "\\\n" "\n" \ + {\(+-} "±" \ + {\(co} "©" \ + {\(em} "—" \ + {\(fm} "′" \ + {\(mu} "×" \ + {\(mi} "−" \ + {\(->} "→" \ + {\fP} {\fR} \ + {\.} . \ + {\(bu} "•" \ + ] + lappend charmap {\o'o^'} {ô} ; # o-circumflex in re_syntax.n + lappend charmap {\-\|\-} -- ; # two hyphens + lappend charmap {\-} - ; # a hyphen + + set text [htmlize-text $text $charmap] + # General quoted entity + regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text + while {[string first "\\" $text] >= 0} { + # 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 "impotent font change: $text" + set text $ntext + continue + } + # unrecognized + manerror "uncaught backslash: $text" + set text [string map [list "\\" "\"] $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 [string match .* $line] +} +proc split-directive {line opname restname} { + upvar 1 $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 1 $restname rest + if {[more-text]} { + set text [lindex $manual(text) $manual(text-pointer)] + if {[string equal -length 3 $text $op]} { + 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 eq $targ} { + incr nback + incr manual(text-pointer) + continue + } + if {[regexp {^@(\w+)$} $arg all name]} { + upvar 1 $name var + set var $targ + incr nback + incr manual(text-pointer) + continue + } + if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\ + && [string equal $op [lindex $targ 0]]} { + upvar 1 $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 manual($manual(name)-id-$text) $here + set there L[incr manual(long-toc-n)] + lappend manual(section-toc) \ + "

$text" + return "$text" +} +proc option-toc {name class switch} { + global manual + if {[string match "*OPTIONS" $manual(section)]} { + if {$manual(name) ne "ttk_widget" && ($manual(name) ne "ttk_entry" || + ![string match validate* $name])} { + # 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)" ne "options:DESCRIPTION"} { + error "option-toc in $manual(name) section $manual(section)" + } + + # 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-$manual(name)-$first) \ + "$switch, $name, $class" + lappend manual(section-toc) \ + "

$switch, $name, $class" + return "$switch" +} +proc std-option-toc {name page} { + global manual + if {[info exists manual(standard-option-$page-$name)]} { + lappend manual(section-toc)

$manual(standard-option-$page-$name) + return $manual(standard-option-$page-$name) + } + manerror "missing reference to \"$name\" in $page.n" + 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)

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
+ + if {[next-op-is .RS rest]} { + while {[more-text]} { + set line [next-text] + if {[is-a-directive $line]} { + split-directive $line code rest + switch -exact -- $code { + .RE { + break + } + .SH - .SS { + manerror "unbalanced .RS at section end" + backup-text 1 + break + } + default { + output-directive $line + } + } + } else { + man-puts $line + } + } + } + } + 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 - .SS { + 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 {![string length $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 eq ".IP" && $rest eq {}} { + man-puts "

" + continue + } + if {$code in {.br .DS .RS}} { + output-directive $line + } else { + backup-text 1 + break + } + } else { + man-puts $line + } + } + man-puts

+ } else { + # labelled list, make contents + if {$context ne ".SH" && $context ne ".SS"} { + man-puts

+ } + set dl "

$rest: " + } elseif {"•" eq $rest} { + man-puts "$para
: $rest " + } else { + man-puts "$para
[long-toc $rest]: " + } + if {"$manual(name):$manual(section)" eq \ + "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 "$para
[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 + set para {} + 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 + } + set para

+ } + man-puts "$para

" + 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

+ } + .SH - .SS { + # 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) + if {$code ne ".SS"} { + man-puts "

[long-toc $manual(section)]

" + } else { + 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 {$manual(tail) in {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3}} { + # 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 .SS 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 + } + foreach more [split $more \n] { + regexp {^(\s*)(.*)} $more -> spaces more + set spaces [string map {" " " "} $spaces] + if {[string length $spaces]} { + set spaces $spaces + } + man-puts $spaces$more
+ if {$manual(wing-file) in {TclLib TkLib}} { + lappend manual(section-toc)

$more + } + } + } + lappend manual(section-toc)

+ return + } + {SEE ALSO} { + while {[more-text]} { + if {[next-op-is .SH rest] || [next-op-is .SS 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] || [next-op-is .SS 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 $code .IP $rest + return + } + if {[next-op-is .PP rest]} { + return + } + return + } + .SO { + # When there's a sequence of multiple .SO chunks, process into one + set optslist {} + while 1 { + if {[match-text @stuff .SE]} { + foreach opt [split $stuff \n\t] { + lappend optslist [list $opt $rest] + } + } else { + manerror "unexpected .SO format:\n[expand-next-text 2]" + } + if {![next-op-is .SO rest]} { + break + } + } + output-directive {.SH STANDARD OPTIONS} + man-puts

+ lappend manual(section-toc)

[std-option-toc $option $targetPage]" + } + man-puts

+ lappend manual(section-toc) + } + .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]} { + # skip the leading .ta directive if it is there + } + if {[match-text @stuff .DE]} { + set td "

" + set bodyText [string map [list \n $td \t $td] \n$stuff] + man-puts "

$bodyText

" + #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} { + set merge {} + set re1 {^Copyright +(?:$c$|\\\(co|©) +(\w.*?)(?:all rights reserved)?(?:\. )*$} + set re2 {^(\d+) +(?:by +)?(\w.*)$} ;# date who + set re3 {^(\d+)-(\d+) +(?:by +)?(\w.*)$} ;# from to who + set re4 {^(\d+), *(\d+) +(?:by +)?(\w.*)$} ;# date1 date2 who + foreach copyright [concat $l1 $l2] { + if {[regexp -nocase -- $re1 $copyright -> info]} { + set info [string trimright $info ". "] ; # remove extra period + if {[regexp -- $re2 $info -> date who]} { + lappend dates($who) $date + continue + } elseif {[regexp -- $re3 $info -> from to who]} { + for {set date $from} {$date <= $to} {incr date} { + lappend dates($who) $date + } + continue + } elseif {[regexp -- $re3 $info -> date1 date2 who]} { + lappend dates($who) $date1 $date2 + continue + } + } + puts "oops: $copyright" + } + foreach who [array names dates] { + set list [lsort -dictionary $dates($who)] + if {[llength $list] == 1 || [lindex $list 0] eq [lrange $list end end]} { + lappend merge "Copyright © [lindex $list 0] $who" + } else { + lappend merge "Copyright © [lindex $list 0]-[lrange $list end end] $who" + } + } + return [lsort -dictionary $merge] +} + +proc makedirhier {dir} { + if {![file isdirectory $dir] && \ + [catch {file mkdir $dir} error]} { + return -code error "cannot create directory $dir: $error" + } +} + +proc addbuffer {args} { + global manual + if {$manual(partial-text) ne ""} { + append manual(partial-text) \n + } + append manual(partial-text) [join $args ""] +} +proc flushbuffer {} { + global manual + if {$manual(partial-text) ne ""} { + lappend manual(text) [process-text $manual(partial-text)] + set manual(partial-text) "" + } +} + +return diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index c0c2ce5..ba4fad6 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -26,7 +26,7 @@ proc parse_command_line {} { # These variables determine where the man pages come from and where # the converted pages go to. - global tcltkdir tkdir tcldir webdir build_tcl build_tk + global tcltkdir tkdir tcldir webdir build_tcl build_tk verbose # Set defaults based on original code. set tcltkdir ../.. @@ -35,6 +35,7 @@ proc parse_command_line {} { set webdir ../html set build_tcl 0 set build_tk 0 + set verbose 0 # Default search version is a glob pattern set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}} @@ -61,6 +62,7 @@ proc parse_command_line {} { puts " --tcl build tcl help" puts " --tk build tk help" puts " --useversion version of tcl/tk to search for" + puts " --verbose whether to print longer messages" exit 0 } @@ -87,6 +89,10 @@ proc parse_command_line {} { set build_tk 1 } + --verbose=* { + set verbose [string range $option \ + [string length --verbose=] end] + } default { puts stderr "tcltk-man-html: unrecognized option -- `$option'" exit 1 @@ -121,6 +127,8 @@ proc parse_command_line {} { puts "using Tk source directory $tkdir" } + puts "verbose messages are [expr {$verbose ? {on} : {off}}]" + # the title for the man pages overall global overall_title set overall_title "" @@ -141,1358 +149,91 @@ proc capitalize {string} { } ## +## Source the utility functions that provide most of the +## implementation of the transformation from nroff to html. ## -## -set manual(report-level) 1 - -proc manerror {msg} { - global manual - set name {} - set subj {} - set procname [lindex [info level -1] 0] - if {[info exists manual(name)]} { - set name $manual(name) - } - if {[info exists manual(section)] && [string length $manual(section)]} { - puts stderr "$name: $manual(section): $procname: $msg" - } else { - puts stderr "$name: $procname: $msg" - } -} - -proc manreport {level msg} { - global manual - if {$level < $manual(report-level)} { - uplevel 1 [list manerror $msg] - } -} - -proc fatal {msg} { - global manual - uplevel 1 [list manerror $msg] - exit 1 -} +source [file join [file dirname [info script]] tcltk-man2html-utils.tcl] ## -## templating +## Returns the style sheet. ## -proc indexfile {} { - if {[info exists ::TARGET] && $::TARGET eq "devsite"} { - return "index.tml" - } else { - return "contents.htm" - } -} -proc copyright {copyright {level {}}} { - # We don't actually generate a separate copyright page anymore - #set page "${level}copyright.htm" - #return "Copyright © [htmlize-text [lrange $copyright 2 end]]" - # obfuscate any email addresses that may appear in name - set who [string map {@ (at)} [lrange $copyright 2 end]] - return "Copyright © [htmlize-text $who]" -} -proc copyout {copyrights {level {}}} { - set out "

" - foreach c $copyrights { - append out "[copyright $c $level]\n" - } - append out "

" - return $out -} -proc CSS {{level ""}} { - return "\n" -} -proc DOCTYPE {} { - return "" +proc css-style args { + upvar 1 style style + set body [uplevel 1 [list subst [lindex $args end]]] + set tokens [join [lrange $args 0 end-1] ", "] + append style $tokens " \{" $body "\}\n" } -proc htmlhead {title header args} { - set level "" - if {[lindex $args end] eq "../[indexfile]"} { - # XXX hack - assume same level for CSS file - set level "../" - } - set out "[DOCTYPE]\n\n$title\n[CSS $level]\n" - foreach {uptitle url} $args { - set header "$uptitle > $header" - } - append out "

$header

" - global manual - if {[info exists manual(subheader)]} { - set subs {} - foreach {name subdir} $manual(subheader) { - if {$name eq $title} { - lappend subs $name - } else { - lappend subs "$name" - } - } - append out "\n

[join $subs { | }]

" - } - return $out -} -proc gencss {} { +proc css-stylesheet {} { set hBd "1px dotted #11577b" - return [subst { -body, div, p, th, td, li, dd, ul, ol, dl, dt, blockquote { - font-family: Verdana, sans-serif; -} - -pre, code { font-family: 'Courier New', Courier, monospace; } - -pre { - background-color: #f6fcec; - border-top: 1px solid #6A6A6A; - border-bottom: 1px solid #6A6A6A; - padding: 1em; - overflow: auto; -} - -body { - background-color: #FFFFFF; - font-size: 12px; - line-height: 1.25; - letter-spacing: .2px; - padding-left: .5em; -} - -h1, h2, h3, h4 { - font-family: Georgia, serif; - padding-left: 1em; - margin-top: 1em; -} - -h1 { - font-size: 18px; - color: #11577b; - border-bottom: $hBd; - margin-top: 0px; -} - -h2 { - font-size: 14px; - color: #11577b; - background-color: #c5dce8; - padding-left: 1em; - border: 1px solid #6A6A6A; -} - -h3, h4 { - color: #1674A4; - background-color: #e8f2f6; - border-bottom: $hBd; - border-top: $hBd; -} - -h3 { font-size: 12px; } -h4 { font-size: 11px; } - -.keylist dt, .arguments dt { - width: 20em; - float: left; - padding: 2px; - border-top: 1px solid #999; -} - -.keylist dt { font-weight: bold; } - -.keylist dd, .arguments dd { - margin-left: 20em; - padding: 2px; - border-top: 1px solid #999; -} - -.copy { - background-color: #f6fcfc; - white-space: pre; - font-size: 80%; - border-top: 1px solid #6A6A6A; - margin-top: 2em; -} -}] -} - -## -## parsing -## -proc unquote arg { - return [string map [list \" {}] $arg] -} -proc parse-directive {line codename restname} { - upvar 1 $codename code $restname rest - return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] -} - -proc htmlize-text {text {charmap {}}} { - # contains some extras for use in nroff->html processing - # build on the list passed in, if any - lappend charmap \ - {&} {&} \ - {\\} "\" \ - {\e} "\" \ - {\ } { } \ - {\|} { } \ - {\0} { } \ - \" {"} \ - {<} {<} \ - {>} {>} \ - \u201c "“" \ - \u201d "”" - - return [string map $charmap $text] -} - -proc process-text {text} { - global manual - # preprocess text; note that this is an incomplete map, and will probably - # need to have things added to it as the manuals expand to use them. - set charmap [list \ - {\&} "\t" \ - {\%} {} \ - "\\\n" "\n" \ - {\(+-} "±" \ - {\(co} "©" \ - {\(em} "—" \ - {\(fm} "′" \ - {\(mu} "×" \ - {\(mi} "−" \ - {\(->} "→" \ - {\fP} {\fR} \ - {\.} . \ - {\(bu} "•" \ - ] - lappend charmap {\o'o^'} {ô} ; # o-circumflex in re_syntax.n - lappend charmap {\-\|\-} -- ; # two hyphens - lappend charmap {\-} - ; # a hyphen - - set text [htmlize-text $text $charmap] - # General quoted entity - regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text - while {[string first "\\" $text] >= 0} { - # 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 "impotent font change: $text" - set text $ntext - continue - } - # unrecognized - manerror "uncaught backslash: $text" - set text [string map [list "\\" "\"] $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 [string match .* $line] -} -proc split-directive {line opname restname} { - upvar 1 $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 1 $restname rest - if {[more-text]} { - set text [lindex $manual(text) $manual(text-pointer)] - if {[string equal -length 3 $text $op]} { - 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 eq $targ} { - incr nback - incr manual(text-pointer) - continue - } - if {[regexp {^@(\w+)$} $arg all name]} { - upvar 1 $name var - set var $targ - incr nback - incr manual(text-pointer) - continue - } - if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\ - && [string equal $op [lindex $targ 0]]} { - upvar 1 $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 manual($manual(name)-id-$text) $here - set there L[incr manual(long-toc-n)] - lappend manual(section-toc) \ - "

$text" - return "$text" -} -proc option-toc {name class switch} { - global manual - if {[string match "*OPTIONS" $manual(section)]} { - if {$manual(name) ne "ttk_widget" && ($manual(name) ne "ttk_entry" || - ![string match validate* $name])} { - # 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)" ne "options:DESCRIPTION"} { - error "option-toc in $manual(name) section $manual(section)" - } - - # 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-$manual(name)-$first) \ - "$switch, $name, $class" - lappend manual(section-toc) \ - "

$switch, $name, $class" - return "$switch" -} -proc std-option-toc {name page} { - global manual - if {[info exists manual(standard-option-$page-$name)]} { - lappend manual(section-toc)

$manual(standard-option-$page-$name) - return $manual(standard-option-$page-$name) - } - manerror "missing reference to \"$name\" in $page.n" - 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)

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
- - if {[next-op-is .RS rest]} { - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - split-directive $line code rest - switch -exact -- $code { - .RE { - break - } - .SH - .SS { - manerror "unbalanced .RS at section end" - backup-text 1 - break - } - default { - output-directive $line - } - } - } else { - man-puts $line - } - } - } - } - 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 - .SS { - 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 {![string length $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 eq ".IP" && $rest eq {}} { - man-puts "

" - continue - } - if {$code in {.br .DS .RS}} { - output-directive $line - } else { - backup-text 1 - break - } - } else { - man-puts $line - } - } - man-puts

- } else { - # labelled list, make contents - if {$context ne ".SH" && $context ne ".SS"} { - man-puts

- } - set dl "

$rest: " - } elseif {"•" eq $rest} { - man-puts "$para
: $rest " - } else { - man-puts "$para
[long-toc $rest]: " - } - if {"$manual(name):$manual(section)" eq \ - "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 "$para
[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 - set para {} - 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 - } - set para

- } - man-puts "$para

" - 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

- } - .SH - .SS { - # 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) - if {$code ne ".SS"} { - man-puts "

[long-toc $manual(section)]

" - } else { - 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 {$manual(tail) in {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3}} { - # 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 .SS 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 - } - foreach more [split $more \n] { - man-puts $more
- if {$manual(wing-file) in {TclLib TkLib}} { - lappend manual(section-toc)

$more - } - } - } - lappend manual(section-toc)

- return - } - {SEE ALSO} { - while {[more-text]} { - if {[next-op-is .SH rest] || [next-op-is .SS 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] || [next-op-is .SS 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 $code .IP $rest - return - } - if {[next-op-is .PP rest]} { - return - } - return - } - .SO { - # When there's a sequence of multiple .SO chunks, process into one - set optslist {} - while 1 { - if {[match-text @stuff .SE]} { - foreach opt [split $stuff \n\t] { - lappend optslist [list $opt $rest] - } - } else { - manerror "unexpected .SO format:\n[expand-next-text 2]" - } - if {![next-op-is .SO rest]} { - break - } - } - output-directive {.SH STANDARD OPTIONS} - man-puts

- lappend manual(section-toc)

[std-option-toc $option $targetPage]" - } - man-puts

- lappend manual(section-toc) - } - .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]} { - # skip the leading .ta directive if it is there - } - if {[match-text @stuff .DE]} { - set td "

" - set bodyText [string map [list \n $td \t $td] \n$stuff] - man-puts "

$bodyText

" - #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