diff options
Diffstat (limited to 'tools/tcltk-man2html.tcl')
| -rwxr-xr-x | tools/tcltk-man2html.tcl | 1915 |
1 files changed, 1436 insertions, 479 deletions
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index b347abf..59a2a63 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -2,7 +2,7 @@ # The next line is executed by /bin/sh, but not tcl \ exec tclsh "$0" ${1+"$@"} -package require Tcl 8.6 +package require Tcl 8.5 # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -16,23 +16,17 @@ package require Tcl 8.6 # try to use this, you'll be very much on your own. # # Copyright (c) 1995-1997 Roger E. Critchlow Jr -# Copyright (c) 2004-2010 Donal K. Fellows -regexp {\d+\.\d+} {$Revision: 1.49 $} ::Version +set Version "0.40" + set ::CSSFILE "docs.css" -## -## Source the utility functions that provide most of the -## implementation of the transformation from nroff to html. -## -source [file join [file dirname [info script]] tcltk-man2html-utils.tcl] - 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 build_tcl build_tk verbose + global tcltkdir tkdir tcldir webdir build_tcl build_tk # Set defaults based on original code. set tcltkdir ../.. @@ -41,7 +35,6 @@ 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]}}}} @@ -68,7 +61,6 @@ 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 } @@ -95,10 +87,6 @@ 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 @@ -125,7 +113,7 @@ proc parse_command_line {} { if {$build_tk} { # Find Tk. set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ - -directory $tcltkdir tk$useversion]] end] + -directory $tcltkdir tk$useversion]] end] if {$tkdir eq ""} { puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" exit 1 @@ -133,8 +121,6 @@ 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 "" @@ -153,117 +139,1369 @@ proc parse_command_line {} { proc capitalize {string} { return [string toupper $string 0] } - + +## ## -## Returns the style sheet. ## -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" +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 "<A HREF=\"$page\">Copyright</A> © [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 "<div class=\"copy\">" + foreach c $copyrights { + append out "[copyright $c $level]\n" + } + 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]"} { + # XXX hack - assume same level for CSS file + set level "../" + } + set out "[DOCTYPE]\n<HTML>\n<HEAD><TITLE>$title</TITLE>\n[CSS $level]</HEAD>\n" + foreach {uptitle url} $args { + set header "<a href=\"$url\">$uptitle</a> <small>></small> $header" + } + append out "<BODY><H2>$header</H2>" + global manual + if {[info exists manual(subheader)]} { + set subs {} + foreach {name subdir} $manual(subheader) { + if {$name eq $title} { + lappend subs $name + } else { + lappend subs "<A HREF=\"${level}$subdir/[indexfile]\">$name</A>" + } + } + append out "\n<H3>[join $subs { | }]</H3>" + } + return $out } -proc css-stylesheet {} { +proc gencss {} { set hBd "1px dotted #11577b" + return " +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 + set charmap [list \ + {\&} "\t" \ + {\%} {} \ + "\\\n" "\n" \ + {\(+-} "±" \ + {\(co} "©" \ + {\(em} "—" \ + {\(fm} "′" \ + {\(mu} "×" \ + {\(->} "<font size=\"+1\">→</font>" \ + {\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<TT>\2</TT>\3} text]} continue + # B R + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \ + {\1<B>\2</B>\3} text]} continue + # B I + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \ + {\1<B>\2</B>\\fI\3} text]} continue + # I R + if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \ + {\1<I>\2</I>\3} text]} continue + # I B + if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \ + {\1<I>\2</I>\\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] + } then { + 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 there L[incr manual(long-toc-n)] + lappend manual(section-toc) \ + "<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 + if {[string match "*OPTIONS" $manual(section)]} { + if { + $manual(name) ne "ttk_widget" + && $manual(section) ne "WIDGET-SPECIFIC OPTIONS" + } then { + # 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) \ + "<A HREF=\"$manual(name).htm#$here\">$switch, $name, $class</A>" + lappend manual(section-toc) \ + "<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)]} { + lappend manual(section-toc) <DD>$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) "<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 +## +proc output-widget-options {rest} { + global manual + man-puts <DL> + lappend manual(section-toc) <DL> + backup-text 1 + set para {} + while {[next-op-is .OP rest]} { + switch -exact -- [llength $rest] { + 3 { + lassign $rest switch name class + } + 5 { + set switch [lrange $rest 0 2] + set name [lindex $rest 3] + set class [lindex $rest 4] + } + default { + fatal "bad .OP $rest" + } + } + if {![regexp {^(<.>)([-\w ]+)(</.>)$} $switch \ + all oswitch switch cswitch]} { + if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)(</.>)$} $switch \ + all oswitch switch1 switch2 cswitch]} { + error "not Switch: $switch" + } + set switch "$switch1$cswitch or $oswitch$switch2" + } + if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} { + error "not Name: $name" + } + if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} { + error "not Class: $class" + } + man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch" + man-puts "<DT>Database Name: $oname$name$cname" + man-puts "<DT>Database Class: $oclass$class$cclass" + man-puts <DD>[next-text] + set para <P> + + 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 </DL> + lappend manual(section-toc) </DL> +} + +## +## 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 <P>$rest + output-IP-list .RS .IP $rest2 + } + if {[match-text .RE .sp .RS @rest .RE]} { + man-puts <P>$rest + return + } + if {[next-op-is .RE rest]} { + return + } + } + man-puts <DL><DD> + 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 </DL> +} + +## +## 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 <DL><DD> + 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 "<P>" + continue + } + if {$code in {.br .DS .RS}} { + output-directive $line + } else { + backup-text 1 + break + } + } else { + man-puts $line + } + } + man-puts </DL> + } else { + # labelled list, make contents + if {$context ne ".SH" && $context ne ".SS"} { + man-puts <P> + } + set dl "<DL class=\"[string tolower $manual(section)]\">" + man-puts $dl + lappend manual(section-toc) $dl + backup-text 1 + set accept_RE 0 + set para {} + 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) eq "ARGUMENTS" || \ + [regexp {^\[\d+\]$} $rest]} { + man-puts "$para<DT>$rest<DD>" + } elseif {"•" eq $rest} { + man-puts "$para<DT><DD>$rest " + } else { + man-puts "$para<DT>[long-toc $rest]<DD>" + } + if {"$manual(name):$manual(section)" eq \ + "selection:DESCRIPTION"} { + if {[match-text .RE @rest .RS .RS]} { + man-puts <DT>[long-toc $rest]<DD> + } + } + } + .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<DT>[long-toc $rest1]" + man-puts "<DT>[long-toc $rest2]<DD>" + incr accept_RE 1 + } elseif {[match-text @rest .RE]} { + # gad, this is getting ridiculous + if {!$accept_RE} { + man-puts "</DL><P>$rest<DL>" + backup-text 1 + set para {} + break + } else { + man-puts "<P>$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 <P> + } + man-puts "$para</DL>" + lappend manual(section-toc) </DL> + 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) <DL><DD>$line</DD></DL> + # 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 eq "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] && \ + [info exists manual(name-$name)] && \ + $manual(tail) ne "$name.n"} { + return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>" + } + } + if {$lref in {stdin stdout stderr end}} { + # no good place to send these + # tcl tokens? + # also end + } + return $ref + } + ## + ## would be a self reference + ## + foreach name $manual(name-$lref) { + if {"$manual(wing-file)/$manual(name)" in $name} { + 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) eq "TclCmd" + || $manual(wing-file) eq "TclLib"} { + return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" + } + if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd" + || $manual(wing-file) eq "TkLib"} { + return "<A HREF=\"../$tk_ref.htm\">$ref</A>" + } + if {$lref eq "exit" && $manual(tail) eq "tclsh.1" && $tcl_i >= 0} { + return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" + } + 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 -exact -- $manual(tail) { + canvas.n { + if {$lref eq "focus"} { + upvar 1 tail tail + set clue [string first command $tail] + if {$clue < 0 || $clue > 5} { + return $ref + } + } + if {$lref in {bitmap image text}} { + return $ref + } + } + checkbutton.n - radiobutton.n { + if {$lref in {image}} { + return $ref + } + } + menu.n { + if {$lref in {checkbutton radiobutton}} { + return $ref + } + } + options.n { + if {$lref in {bitmap image set}} { + return $ref + } + } + regexp.n { + if {$lref in {string}} { + return $ref + } + } + source.n { + if {$lref in {text}} { + return $ref + } + } + history.n { + if {$lref in {exec}} { + return $ref + } + } + return.n { + if {$lref in {error continue break}} { + return $ref + } + } + scrollbar.n { + if {$lref in {set}} { + return $ref + } + } + safe.n { + if {$lref in {options}} { + return $ref + } + } + } + ## + ## return the cross reference + ## + return "<A HREF=\"../$manual(name-$lref).htm\">$ref</A>" +} +## +## 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'' + ## <B>emboldening</B> + ## 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 {<A } $text] \ + end-anchor [string first {</A>} $text] \ + quote [string first {``} $text] \ + end-quote [string first {''} $text] \ + bold [string first {<B>} $text] \ + end-bold [string first {</B>} $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]) eq "tk"} { + set offsets [lreplace $offsets 1 1] + } + if {$invert([lindex $offsets 1]) eq "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]) eq "tk"} { + set offsets [lreplace $offsets 1 1] + } + if {$invert([lindex $offsets 1]) eq "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<B>[cross-reference $body]</B>[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_\w+)(.*)$} $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_\w+)(.*)$} $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 <HR> + } + .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 "<H3>[long-toc $manual(section)]</H3>" + } else { + man-puts "<H4>[long-toc $manual(section)]</H4>" + } + # 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) <DL> + while {1} { + if { + [next-op-is .nf rest] + || [next-op-is .br rest] + || [next-op-is .fi rest] + } then { + continue + } + if { + [next-op-is .SH rest] + || [next-op-is .SS rest] + || [next-op-is .BE rest] + || [next-op-is .SO rest] + } then { + backup-text 1 + break + } + if {[next-op-is .sp rest]} { + #man-puts <P> + 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<BR> + if {$manual(wing-file) in {TclLib TkLib}} { + lappend manual(section-toc) <DD>$more + } + } + } + lappend manual(section-toc) </DL> + 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 {^<B>.*</B>$} $cr]} { + set cr <B>$cr</B> + } + if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} { + set cr <B>$name</B> + } + 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 "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>" + } + 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 { + set targetPage $rest + if {[match-text @stuff .SE]} { + output-directive {.SH STANDARD OPTIONS} + set opts [split $stuff \n\t] + man-puts <DL> + lappend manual(section-toc) <DL> + foreach option [lsort -dictionary $opts] { + man-puts "<DT><B>[std-option-toc $option $targetPage]</B>" + } + man-puts </DL> + lappend manual(section-toc) </DL> + } 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 <P> + } + .RS { + output-RS-list + return + } + .RE { + manerror "unexpected .RE" + return + } + .br { + man-puts <BR> + 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 "<td><p style=\"font-size:12px;padding-left:.5em;padding-right:.5em;\">" + set bodyText [string map [list \n <tr>$td \t $td] \n$stuff] + man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>" + #man-puts <PRE>$stuff</PRE> + } elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} { + man-puts "<PRE>[lindex $ul1 1][lindex $ul2 1]\n$stuff</PRE>" + } 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 <PRE>$stuff</PRE> + } else { + manerror "unexpected .CS format:\n[expand-next-text 2]" + } + return + } + .CE { + manerror "unexpected .CE" + return + } + .sp { + man-puts <P> + } + .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<BR> + } + } elseif {[match-text .RS @more .RE .fi]} { + man-puts <DL><DD> + foreach more [split $more \n] { + man-puts $more<BR> + } + man-puts </DL> + } elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} { + man-puts <DL><DD> + foreach more [split $more \n] { + man-puts $more<BR> + } + man-puts <DL><DD> + foreach more2 [split $more2 \n] { + man-puts $more2<BR> + } + man-puts </DL></DL> + } elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} { + man-puts <DL><DD> + foreach more [split $more \n] { + man-puts $more<BR> + } + man-puts <DL><DD> + foreach more2 [split $more2 \n] { + man-puts $more2<BR> + } + man-puts </DL><DD> + foreach more3 [split $more3 \n] { + man-puts $more3<BR> + } + man-puts </DL> + } elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} { + man-puts <P><DL><DD> + foreach more [split $more \n] { + man-puts $more<BR> + } + man-puts <DL><DD> + foreach more2 [split $more2 \n] { + man-puts $more2<BR> + } + man-puts </DL></DL><P> + } elseif {[match-text .RS .sp @more .sp .RE .fi]} { + man-puts <P><DL><DD> + foreach more [split $more \n] { + man-puts $more<BR> + } + man-puts </DL><P> + } 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) "" + } +} - css-style body div p th td li dd ul ol dl dt blockquote { - font-family: Verdana, sans-serif; - } - css-style pre code { - font-family: 'Courier New', Courier, monospace; - } - css-style pre { - background-color: #f6fcec; - border-top: 1px solid #6A6A6A; - border-bottom: 1px solid #6A6A6A; - padding: 1em; - overflow: auto; - } - css-style body { - background-color: #FFFFFF; - font-size: 12px; - line-height: 1.25; - letter-spacing: .2px; - padding-left: .5em; - } - css-style h1 h2 h3 h4 { - font-family: Georgia, serif; - padding-left: 1em; - margin-top: 1em; - } - css-style h1 { - font-size: 18px; - color: #11577b; - border-bottom: $hBd; - margin-top: 0px; - } - css-style h2 { - font-size: 14px; - color: #11577b; - background-color: #c5dce8; - padding-left: 1em; - border: 1px solid #6A6A6A; - } - css-style h3 h4 { - color: #1674A4; - background-color: #e8f2f6; - border-bottom: $hBd; - border-top: $hBd; - } - css-style h3 { - font-size: 12px; - } - css-style h4 { - font-size: 11px; - } - css-style ".keylist dt" ".arguments dt" { - width: 20em; - float: left; - padding: 2px; - border-top: 1px solid #999; - } - css-style ".keylist dt" { font-weight: bold; } - css-style ".keylist dd" ".arguments dd" { - margin-left: 20em; - padding: 2px; - border-top: 1px solid #999; - } - css-style .copy { - background-color: #f6fcfc; - white-space: pre; - font-size: 80%; - border-top: 1px solid #6A6A6A; - margin-top: 2em; - } - css-style .tablecell { - font-size: 12px; - padding-left: .5em; - padding-right: .5em; - } -} - ## ## 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 manual overall_title tcltkdesc verbose - global excluded_pages forced_index_pages process_first_patterns - + global manual overall_title tcltkdesc makedirhier $html set cssfd [open $html/$::CSSFILE w] - puts $cssfd [css-stylesheet] + puts $cssfd [gencss] close $cssfd set manual(short-toc-n) 1 set manual(short-toc-fp) [open $html/[indexfile] w] puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title] puts $manual(short-toc-fp) "<DL class=\"keylist\">" set manual(merge-copyrights) {} - - set LQ \u201c - set RQ \u201d - foreach arg $args { # preprocess to set up subheader for the rest of the files if {![llength $arg]} { @@ -298,34 +1536,27 @@ proc make-man-pages {html args} { # 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) [lsort -dictionary [glob $manual(wing-glob)]] + set n [lsearch -glob $manual(pages) */ttk_widget.n] + if {$n >= 0} { + set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" + } + set n [lsearch -glob $manual(pages) */options.n] + if {$n >= 0} { + set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" } # set manual(pages) [lrange $manual(pages) 0 5] + set LQ \u201c + set RQ \u201d foreach manual_page $manual(pages) { - set manual(page) [file normalize $manual_page] + set manual(page) $manual_page # whistle - if {$verbose} { - puts stderr "scanning page $manual(page)" - } else { - puts -nonewline stderr . - } + puts stderr "scanning page $manual(page)" set manual(tail) [file tail $manual(page)] set manual(name) [file root $manual(tail)] set manual(section) {} - if {$manual(name) in $excluded_pages} { + if {$manual(name) in {case pack-old menubar}} { # obsolete - if {!$verbose} { - puts stderr "" - } manerror "discarding $manual(name)" continue } @@ -340,6 +1571,7 @@ proc make-man-pages {html args} { set manual(section-toc) {} set manual(section-toc-n) 1 set manual(copyrights) {} + lappend manual(copyrights) "Copyright © 1995-1997 Roger E. Critchlow Jr." lappend manual(all-pages) $manual(wing-file)/$manual(tail) manreport 100 $manual(name) while {[gets $manual(infp) line] >= 0} { @@ -360,7 +1592,6 @@ proc make-man-pages {html args} { continue } switch -exact -- $code { - .if - .nr - .ti - .in - .ad - .na - .so - .ne - .AS - .VE - .VS - . { # ignore continue @@ -405,9 +1636,6 @@ proc make-man-pages {html args} { .BS - .BE - .br - .fi - .sp - .nf { flushbuffer if {"$rest" ne {}} { - if {!$verbose} { - puts stderr "" - } manerror "unexpected argument: $line" } lappend manual(text) $code @@ -424,9 +1652,6 @@ proc make-man-pages {html args} { .TP { flushbuffer while {[is-a-directive [set next [gets $manual(infp)]]]} { - if {!$verbose} { - puts stderr "" - } manerror "ignoring $next after .TP" } if {"$next" ne {'}} { @@ -494,15 +1719,9 @@ proc make-man-pages {html args} { } } .. { - if {!$verbose} { - puts stderr "" - } error "found .. outside of .de" } default { - if {!$verbose} { - puts stderr "" - } flushbuffer manerror "unrecognized format directive: $line" } @@ -512,43 +1731,27 @@ proc make-man-pages {html args} { 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" + set manual($manual(name)-title) \ + "[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] { }]" + set manual($manual(name)-title) "[lindex $rest 0] manual page - [lrange $rest 4 end]" } else { set haserror 1 - if {!$verbose} { - puts stderr "" - } manerror "no .HS or .TH record found" } if {!$haserror} { @@ -561,17 +1764,12 @@ proc make-man-pages {html args} { } } man-puts [copyout $manual(copyrights) "../"] - set manual(wing-copyrights) [merge-copyrights \ - $manual(wing-copyrights) $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 "" + set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL>] } # @@ -583,7 +1781,7 @@ proc make-man-pages {html args} { set width [string length $name] } } - set perline [expr {118 / $width}] + set perline [expr {120 / $width}] set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] set n 0 catch {unset rows} @@ -595,7 +1793,7 @@ proc make-man-pages {html args} { } set tail [file tail $tail] append rows([expr {$n%$nrows}]) \ - "<td> <a href=\"$tail.htm\">$name</a> </td>" + "<td> <a href=\"$tail.htm\">$name</a>" incr n } puts $manual(wing-toc-fp) <table> @@ -610,8 +1808,7 @@ proc make-man-pages {html args} { 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)] + set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)] } ## @@ -634,7 +1831,7 @@ proc make-man-pages {html args} { lappend keyheader $a } } - set keyheader <H3>[join $keyheader " |\n"]</H3> + set keyheader "<H3>[join $keyheader " |\n"]</H3>" puts $keyfp $keyheader foreach a $letters { set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] @@ -685,321 +1882,81 @@ proc make-man-pages {html args} { ## output man pages ## unset manual(section) - if {!$verbose} { - puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links" - } 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)] - try { - 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 + 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 outfd [open $html/$manual(wing-file)/$manual(name).htm w] + puts $outfd [htmlhead "$manual($manual(name)-title)" \ + $manual(name) $manual(wing-file) "[indexfile]" \ + $overall_title "../[indexfile]"] + if { + (($ntext > 60) && ($ntoc > 32)) || $manual(tail) in { + Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType CrtItemType + CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetDash + GetJustify GetPixels GetVisual ParseArgv QueueEvent } - if {$verbose} { - puts stderr "rescanning page $manual(name) $ntoc/$ntext" - } else { - puts -nonewline stderr . - } - set outfd [open $html/$manual(wing-file)/$manual(name).htm w] - puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \ - $manual(name) $manual(wing-file) "[indexfile]" \ - $overall_title "../[indexfile]"] - if {($ntext > 60) && ($ntoc > 32)} { - foreach item $toc { - puts $outfd $item - } - } elseif {$manual(name) in $forced_index_pages} { - if {!$verbose} {puts stderr ""} - manerror "forcing index generation" - foreach item $toc { - puts $outfd $item - } - } - foreach item $text { - puts $outfd [insert-cross-references $item] - } - puts $outfd "</BODY></HTML>" - } on error msg { - if {$verbose} { - puts stderr $msg - } else { - puts stderr "\nError when processing $manual(name): $msg" + } then { + foreach item $toc { + puts $outfd $item } - } finally { - catch {close $outfd} } - } - if {!$verbose} { - puts stderr "\nDone" + foreach item $text { + puts $outfd [insert-cross-references $item] + } + puts $outfd "</BODY></HTML>" + close $outfd } return {} } - -## -## Helper for assembling the descriptions of base packages (i.e., Tcl and Tk). -## -proc plus-base {var glob name dir desc} { - global tcltkdir - if {$var} { - return [list $tcltkdir/$glob $name $dir $desc] - } + +parse_command_line + +set tcltkdesc ""; set cmdesc ""; set appdir "" +if {$build_tcl} { + append tcltkdesc "Tcl" + append cmdesc "Tcl" + append appdir "$tcldir" +} +if {$build_tcl && $build_tk} { + append tcltkdesc "/" + append cmdesc " and " + append appdir "," +} +if {$build_tk} { + append tcltkdesc "Tk" + append cmdesc "Tk" + append appdir "$tkdir" } -## -## Helper for assembling the descriptions of contributed packages. -## -proc plus-pkgs {type args} { - global build_tcl tcltkdir tcldir - if {$type ni {n 3}} { - error "unknown type \"$type\": must be 3 or n" - } - if {!$build_tcl} return - set result {} - foreach {dir name} $args { - set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/*.$type - if {![llength [glob -nocomplain $globpat]]} { - # Fallback for manpages generated using doctools - set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/man/*.$type - if {![llength [glob -nocomplain $globpat]]} { - continue - } - } - regexp "pkgs/${dir}(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \ - -> version - switch $type { - n { - set title "$name Package Commands" - if {$version ne ""} { - append title ", version $version" - } - set dir [string totitle $dir]Cmd - set desc \ - "The additional commands provided by the $name package." - } - 3 { - set title "$name Package Library" - if {$version ne ""} { - append title ", version $version" - } - set dir [string totitle $dir]Lib - set desc \ - "The additional C functions provided by the $name package." - } - } - lappend result [list $globpat $title $dir $desc] - } - return $result -} - -## -## Set up some special cases. It would be nice if we didn't have them, -## but we do... -## -set excluded_pages {case menubar pack-old} -set forced_index_pages {GetDash} -set process_first_patterns {*/ttk_widget.n */options.n} -set ensemble_commands { - after array binary chan clock dde dict encoding file history info interp - memory namespace package registry self string trace update zlib - clipboard console font grab grid image option pack place selection tk - tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is -} -array set remap_link_target { - stdin Tcl_GetStdChannel - stdout Tcl_GetStdChannel - stderr Tcl_GetStdChannel - style ttk::style - {style map} ttk::style - {tk busy} busy - library auto_execok - safe-tcl safe - tclvars env - tcl_break catch - tcl_continue catch - tcl_error catch - tcl_ok catch - tcl_return catch - int() mathfunc - wide() mathfunc - packagens pkg::create - pkgMkIndex pkg_mkIndex - pkg_mkIndex pkg_mkIndex - Tcl_Obj Tcl_NewObj - Tcl_ObjType Tcl_RegisterObjType - Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel - errorinfo env - errorcode env - tcl_pkgpath env - Tcl_Command Tcl_CreateObjCommand - Tcl_CmdProc Tcl_CreateObjCommand - Tcl_CmdDeleteProc Tcl_CreateObjCommand - Tcl_ObjCmdProc Tcl_CreateObjCommand - Tcl_Channel Tcl_OpenFileChannel - Tcl_WideInt Tcl_NewIntObj - Tcl_ChannelType Tcl_CreateChannel - Tcl_DString Tcl_DStringInit - Tcl_Namespace Tcl_AppendExportList - Tcl_Object Tcl_NewObjectInstance - Tcl_Class Tcl_GetObjectAsClass - Tcl_Event Tcl_QueueEvent - Tcl_Time Tcl_GetTime - Tcl_ThreadId Tcl_CreateThread - Tk_Window Tk_WindowId - Tk_3DBorder Tk_Get3DBorder - Tk_Anchor Tk_GetAnchor - Tk_Cursor Tk_GetCursor - Tk_Dash Tk_GetDash - Tk_Font Tk_GetFont - Tk_Image Tk_GetImage - Tk_ImageMaster Tk_GetImage - Tk_ItemType Tk_CreateItemType - Tk_Justify Tk_GetJustify - Ttk_Theme Ttk_GetTheme -} -array set exclude_refs_map { - bind.n {button destroy option} - clock.n {next} - history.n {exec} - next.n {unknown} - zlib.n {binary close filename text} - canvas.n {bitmap text} - console.n {eval} - checkbutton.n {image} - clipboard.n {string} - entry.n {string} - event.n {return} - font.n {menu} - getOpenFile.n {file open text} - grab.n {global} - interp.n {time} - menu.n {checkbutton radiobutton} - messageBox.n {error info} - options.n {bitmap image set} - radiobutton.n {image} - safe.n {join split} - scale.n {label variable} - scrollbar.n {set} - selection.n {string} - tcltest.n {error} - tkvars.n {tk} - tkwait.n {variable} - tm.n {exec} - ttk_checkbutton.n {variable} - ttk_combobox.n {selection} - ttk_entry.n {focus variable} - ttk_intro.n {focus text} - ttk_label.n {font text} - ttk_labelframe.n {text} - ttk_menubutton.n {flush} - ttk_notebook.n {image text} - ttk_progressbar.n {variable} - ttk_radiobutton.n {variable} - ttk_scale.n {variable} - ttk_scrollbar.n {set} - ttk_spinbox.n {format} - ttk_treeview.n {text open} - ttk_widget.n {image text variable} - TclZlib.3 {binary flush filename text} -} -array set exclude_when_followed_by_map { - canvas.n { - bind widget - focus widget - image are - lower widget - raise widget - } - selection.n { - clipboard selection - clipboard ; - } - ttk_image.n { - image imageSpec - } - fontchooser.n { - tk fontchooser - } -} - -try { - # Parse what the user told us to do - parse_command_line - - # Some strings depend on what options are specified - set tcltkdesc ""; set cmdesc ""; set appdir "" - if {$build_tcl} { - append tcltkdesc "Tcl" - append cmdesc "Tcl" - append appdir "$tcldir" - } - if {$build_tcl && $build_tk} { - append tcltkdesc "/" - append cmdesc " and " - append appdir "," +set usercmddesc "The interpreters which implement $cmdesc." +set tclcmddesc {The commands which the <B>tclsh</B> interpreter implements.} +set tkcmddesc {The additional commands which the <B>wish</B> 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.} + +if {1} { + if {[catch { + make-man-pages $webdir \ + "$tcltkdir/{$appdir}/doc/*.1 \"$tcltkdesc Applications\" UserCmd {$usercmddesc}" \ + [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" : ""}] \ + [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" : ""}] \ + [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" : ""}] \ + [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" : ""}] + } error]} { + puts $error\n$errorInfo } - if {$build_tk} { - append tcltkdesc "Tk" - append cmdesc "Tk" - append appdir "$tkdir" - } - - # Get the list of packages to try, and what their human-readable names - # are. Note that the package directory list should be version-less. - try { - set packageDirNameMap {} - if {$build_tcl} { - set f [open $tcltkdir/$tcldir/pkgs/package.list.txt] - try { - foreach line [split [read $f] \n] { - if {[string trim $line] eq ""} continue - if {[string match #* $line]} continue - lappend packageDirNameMap {*}$line - } - } finally { - close $f - } - } - } trap {POSIX ENOENT} {} { - set packageDirNameMap { - itcl {[incr Tcl]} - tdbc {TDBC} - thread Thread - } - } - - # - # Invoke the scraper/converter engine. - # - make-man-pages $webdir \ - [list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \ - "The interpreters which implement $cmdesc."] \ - [plus-base $build_tcl $tcldir/doc/*.n {Tcl Commands} TclCmd \ - "The commands which the <B>tclsh</B> interpreter implements."] \ - [plus-base $build_tk $tkdir/doc/*.n {Tk Commands} TkCmd \ - "The additional commands which the <B>wish</B> interpreter implements."] \ - {*}[plus-pkgs n {*}$packageDirNameMap] \ - [plus-base $build_tcl $tcldir/doc/*.3 {Tcl Library} TclLib \ - "The C functions which a Tcl extended C program may use."] \ - [plus-base $build_tk $tkdir/doc/*.3 {Tk Library} TkLib \ - "The additional C functions which a Tk extended C program may use."] \ - {*}[plus-pkgs 3 {*}$packageDirNameMap] -} on error {msg opts} { - # On failure make sure we show what went wrong. We're not supposed - # to get here though; it represents a bug in the script. - puts $msg\n[dict get $opts -errorinfo] - exit 1 } - -# Local-Variables: -# mode: tcl -# End: |