diff options
Diffstat (limited to 'tools/tcltk-man2html-utils.tcl')
| -rw-r--r-- | tools/tcltk-man2html-utils.tcl | 388 |
1 files changed, 383 insertions, 5 deletions
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index ef1f62a..c0c6a75 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -35,7 +35,7 @@ proc fatal {msg} { uplevel 1 [list manerror $msg] exit 1 } - + ## ## templating ## @@ -46,6 +46,7 @@ proc indexfile {} { return "contents.htm" } } + proc copyright {copyright {level {}}} { # We don't actually generate a separate copyright page anymore #set page "${level}copyright.htm" @@ -54,6 +55,7 @@ proc copyright {copyright {level {}}} { set who [string map {@ (at)} [lrange $copyright 2 end]] return "Copyright © [htmlize-text $who]" } + proc copyout {copyrights {level {}}} { set out "<div class=\"copy\">" foreach c $copyrights { @@ -62,12 +64,15 @@ proc copyout {copyrights {level {}}} { append out "</div>" return $out } + proc CSS {{level ""}} { return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n" } + proc DOCTYPE {} { return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" } + proc htmlhead {title header args} { set level "" if {[lindex $args end] eq "../[indexfile]"} { @@ -93,7 +98,7 @@ proc htmlhead {title header args} { } return $out } - + ## ## parsing ## @@ -187,6 +192,7 @@ proc process-text {text} { } return $text } + ## ## pass 2 text input and matching ## @@ -195,10 +201,12 @@ proc open-text {} { 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]} { @@ -209,14 +217,17 @@ proc next-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 @@ -230,12 +241,14 @@ proc next-op-is {op restname} { } 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] @@ -275,11 +288,13 @@ proc match-text args { } 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 ## @@ -287,7 +302,7 @@ proc man-puts {text} { global manual lappend manual(output-$manual(wing-file)-$manual(name)) $text } - + ## ## build hypertext links to tables of contents ## @@ -300,6 +315,7 @@ proc long-toc {text} { "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>" return "<A NAME=\"$here\">$text</A>" } + proc option-toc {name class switch} { global manual # Special case handling, oh we hate it but must do it @@ -327,6 +343,7 @@ proc option-toc {name class switch} { "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>" return "<A NAME=\"$here\">$switch</A>" } + proc std-option-toc {name page} { global manual if {[info exists manual(standard-option-$page-$name)]} { @@ -340,6 +357,7 @@ proc std-option-toc {name page} { lappend manual(section-toc) "<DD><A HREF=\"$page.htm#$other\">$name</A>" return "<A HREF=\"$page.htm#$other\">$name</A>" } + ## ## process the widget option section ## in widget and options man pages @@ -411,7 +429,7 @@ proc output-widget-options {rest} { man-puts </DL> lappend manual(section-toc) </DL> } - + ## ## process .RS lists ## @@ -455,7 +473,7 @@ proc output-RS-list {} { } man-puts </DL> } - + ## ## process .IP lists which may be plain indents, ## numeric lists, or definition lists @@ -594,6 +612,7 @@ proc output-IP-list {context code rest} { } } } + ## ## handle the NAME section lines ## there's only one line in the NAME section, @@ -618,6 +637,7 @@ proc output-name {line} { lappend manual(name-$name) $manual(wing-file)/$manual(name) } } + ## ## build a cross-reference link if appropriate ## @@ -726,6 +746,7 @@ proc cross-reference {ref} { ## return "<A HREF=\"../$manref.htm\">$ref</A>" } + ## ## reference generation errors ## @@ -734,6 +755,7 @@ proc reference-error {msg text} { puts stderr "$manual(tail): $msg: {$text}" return $text } + ## ## insert as many cross references into this text string as are appropriate ## @@ -888,6 +910,7 @@ proc insert-cross-references {text} { } } } + ## ## process formatting directives ## @@ -1169,6 +1192,7 @@ proc output-directive {line} { } } } + ## ## merge copyright listings ## @@ -1206,7 +1230,361 @@ proc merge-copyrights {l1 l2} { } return [lsort -dictionary $merge] } + +## +## foreach of the man pages in the section specified by +## sectionDescriptor, convert manpages into hypertext in +## the directory specified by outputDir. +## +proc make-manpage-section {outputDir sectionDescriptor} { + global manual overall_title tcltkdesc verbose + global excluded_pages forced_index_pages process_first_patterns + + set LQ \u201c + set RQ \u201d + lassign $sectionDescriptor \ + manual(wing-glob) \ + manual(wing-name) \ + manual(wing-file) \ + manual(wing-description) + set manual(wing-copyrights) {} + makedirhier $outputDir/$manual(wing-file) + set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] 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) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>" + # initialize the wing table of contents + puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \ + $manual(wing-name) $overall_title "../[indexfile]"] + # initialize the short table of contents for this section + set manual(wing-toc) {} + # initialize the man directory for this section + makedirhier $outputDir/$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 -dictionary [glob -nocomplain $manual(wing-glob)]] + # Some pages have to go first so that their links override others + foreach pat $process_first_patterns { + set n [lsearch -glob $manual(pages) $pat] + if {$n >= 0} { + set f [lindex $manual(pages) $n] + puts stderr "shuffling [file tail $f] to front of processing queue" + set manual(pages) \ + [linsert [lreplace $manual(pages) $n $n] 0 $f] + } + } + # set manual(pages) [lrange $manual(pages) 0 5] + foreach manual_page $manual(pages) { + set manual(page) [file normalize $manual_page] + # whistle + if {$verbose} { + puts stderr "scanning page $manual(page)" + } else { + puts -nonewline stderr . + } + set manual(tail) [file tail $manual(page)] + set manual(name) [file root $manual(tail)] + set manual(section) {} + if {$manual(name) in $excluded_pages} { + # obsolete + if {!$verbose} { + puts stderr "" + } + 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) + lappend manual(all-page-domains) $manual(wing-name) + manreport 100 $manual(name) + while {[gets $manual(infp) line] >= 0} { + manreport 100 $line + if {[regexp {^[`'][/\\]} $line]} { + if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} { + lappend manual(copyrights) $copyright + } + # comment + continue + } + if {"$line" eq {'}} { + # comment + continue + } + if {![parse-directive $line code rest]} { + addbuffer $line + continue + } + switch -exact -- $code { + .if - .nr - .ti - .in - .ie - .el - + .ad - .na - .so - .ne - .AS - .VE - .VS - . { + # ignore + continue + } + } + switch -exact -- $code { + .SH - .SS { + flushbuffer + if {[llength $rest] == 0} { + gets $manual(infp) rest + } + lappend manual(text) "$code [unquote $rest]" + } + .TH { + flushbuffer + lappend manual(text) "$code [unquote $rest]" + } + .QW { + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote afterwards + addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards] + } + .PQ { + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote punctuation afterwards + addbuffer ( $LQ [unquote $inQuote] $RQ \ + [unquote $punctuation] ) [unquote $afterwards] + } + .QR { + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + rangeFrom rangeTo afterwards + addbuffer $LQ [unquote $rangeFrom] "–" \ + [unquote $rangeTo] $RQ [unquote $afterwards] + } + .MT { + addbuffer $LQ$RQ + } + .HS - .UL - .ta { + flushbuffer + lappend manual(text) "$code [unquote $rest]" + } + .BS - .BE - .br - .fi - .sp - .nf { + flushbuffer + if {$rest ne ""} { + if {!$verbose} { + puts stderr "" + } + manerror "unexpected argument: $line" + } + lappend manual(text) $code + } + .AP { + flushbuffer + lappend manual(text) [concat .IP [process-text \ + "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]] + } + .IP { + flushbuffer + regexp {^(.*) +\d+$} $rest all rest + lappend manual(text) ".IP [process-text \ + [unquote [string trim $rest]]]" + } + .TP { + flushbuffer + while {[is-a-directive [set next [gets $manual(infp)]]]} { + if {!$verbose} { + puts stderr "" + } + manerror "ignoring $next after .TP" + } + if {"$next" ne {'}} { + lappend manual(text) ".IP [process-text $next]" + } + } + .OP { + flushbuffer + lassign $rest cmdName dbName dbClass + lappend manual(text) [concat .OP [process-text \ + "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]] + } + .PP - .LP { + flushbuffer + lappend manual(text) {.PP} + } + .RS { + flushbuffer + incr manual(.RS) + lappend manual(text) $code + } + .RE { + flushbuffer + incr manual(.RS) -1 + lappend manual(text) $code + } + .SO { + flushbuffer + incr manual(.SO) + if {[llength $rest] == 0} { + lappend manual(text) "$code options" + } else { + lappend manual(text) "$code [unquote $rest]" + } + } + .SE { + flushbuffer + incr manual(.SO) -1 + lappend manual(text) $code + } + .DS { + flushbuffer + incr manual(.DS) + lappend manual(text) $code + } + .DE { + flushbuffer + incr manual(.DS) -1 + lappend manual(text) $code + } + .CS { + flushbuffer + incr manual(.CS) + lappend manual(text) $code + } + .CE { + flushbuffer + incr manual(.CS) -1 + lappend manual(text) $code + } + .de { + while {[gets $manual(infp) line] >= 0} { + if {[string match "..*" $line]} { + break + } + } + } + .. { + if {!$verbose} { + puts stderr "" + } + error "found .. outside of .de" + } + default { + if {!$verbose} { + puts stderr "" + } + flushbuffer + manerror "unrecognized format directive: $line" + } + } + } + flushbuffer + close $manual(infp) + # fixups + if {$manual(.RS) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .RS .RE" + } + if {$manual(.DS) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .DS .DE" + } + if {$manual(.CS) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .CS .CE" + } + if {$manual(.SO) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .SO .SE" + } + # output conversion + open-text + set haserror 0 + if {[next-op-is .HS rest]} { + set manual($manual(wing-file)-$manual(name)-title) \ + "[join [lrange $rest 1 end] { }] [lindex $rest 0] manual page" + } elseif {[next-op-is .TH rest]} { + set manual($manual(wing-file)-$manual(name)-title) \ + "[lindex $rest 0] manual page - [join [lrange $rest 4 end] { }]" + } else { + set haserror 1 + if {!$verbose} { + puts stderr "" + } + manerror "no .HS or .TH record found" + } + if {!$haserror} { + while {[more-text]} { + set line [next-text] + if {[is-a-directive $line]} { + output-directive $line + } else { + man-puts $line + } + } + man-puts [copyout $manual(copyrights) "../"] + set manual(wing-copyrights) [merge-copyrights \ + $manual(wing-copyrights) $manual(copyrights)] + } + # + # make the long table of contents for this page + # + set manual(toc-$manual(wing-file)-$manual(name)) \ + [concat <DL> $manual(section-toc) </DL>] + } + if {!$verbose} { + puts stderr "" + } + + # + # 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 {118 / $width}] + set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] + set n 0 + catch {unset rows} + foreach name [lsort -dictionary $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}]) \ + "<td> <a href=\"$tail.htm\">$name</a> </td>" + incr n + } + puts $manual(wing-toc-fp) <table> + foreach row [lsort -integer [array names rows]] { + puts $manual(wing-toc-fp) <tr>$rows($row)</tr> + } + puts $manual(wing-toc-fp) </table> + + # + # insert wing copyrights + # + puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"] + puts $manual(wing-toc-fp) "</BODY></HTML>" + close $manual(wing-toc-fp) + set manual(merge-copyrights) \ + [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)] +} + proc makedirhier {dir} { try { if {![file isdirectory $dir]} { |