diff options
Diffstat (limited to 'tools/tcltk-man2html.tcl')
| -rwxr-xr-x | tools/tcltk-man2html.tcl | 2140 |
1 files changed, 582 insertions, 1558 deletions
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index b9c8280..89e8e5c 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -1,14 +1,16 @@ -#!/bin/sh -# The next line is executed by /bin/sh, but not tcl \ -exec tclsh8.4 "$0" ${1+"$@"} +#!/usr/bin/env tclsh -package require Tcl 8.4 +if {[catch {package require Tcl 8.6} msg]} { + puts stderr "ERROR: $msg" + puts stderr "If running this script from 'make html', set the\ + NATIVE_TCLSH environment\nvariable to point to an installed\ + tclsh8.6 (or the equivalent tclsh86.exe\non Windows)." + exit 1 +} -# Convert Ousterhout format man pages into highly crosslinked -# hypertext. +# Convert Ousterhout format man pages into highly crosslinked hypertext. # -# Along the way detect many unmatched font changes and other odd -# things. +# Along the way detect many unmatched font changes and other odd things. # # Note well, this program is a hack rather than a piece of software # engineering. In that sense it's probably a good example of things @@ -18,61 +20,23 @@ package require Tcl 8.4 # try to use this, you'll be very much on your own. # # Copyright (c) 1995-1997 Roger E. Critchlow Jr -# -# The authors hereby grant permission to use, copy, modify, distribute, -# and license this software and its documentation for any purpose, provided -# that existing copyright notices are retained in all copies and that this -# notice is included verbatim in any distributions. No written agreement, -# license, or royalty fee is required for any of the authorized uses. -# Modifications to this software may be copyrighted by their authors -# and need not follow the licensing terms described here, provided that -# the new terms are clearly indicated on the first page of each file where -# they apply. -# -# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -# POSSIBILITY OF SUCH DAMAGE. -# -# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -# MODIFICATIONS. -# -# Revisions: -# May 15, 1995 - initial release -# May 16, 1995 - added a back to home link to toplevel table of -# contents. -# May 18, 1995 - broke toplevel table of contents into separate -# pages for each section, and broke long table of contents -# into a one page for each man page. -# Mar 10, 1996 - updated for tcl7.5b3/tk4.1b3 -# Apr 14, 1996 - incorporated command line parsing from Tom Tromey, -# <tromey@creche.cygnus.com> -- thanks Tom. -# - updated for tcl7.5/tk4.1 final release. -# - converted to same copyright as the man pages. -# Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1 -# Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions. -# Oct 22, 1996 - major hacking on indentation code and elsewhere. -# Mar 4, 1997 - -# May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions -# - cleaned source for tclsh8.0 execution -# - renamed output files for windoze installation -# - added spaces to tables -# Oct 24, 1997 - moved from 8.0b1 to 8.0 release -# +# Copyright (c) 2004-2010 Donal K. Fellows -set Version "0.32" +set ::Version "50/8.6" +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 + global tcltkdir tkdir tcldir webdir build_tcl build_tk verbose # Set defaults based on original code. set tcltkdir ../.. @@ -81,9 +45,13 @@ 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]}}}} # Handle arguments a la GNU: # --version + # --useversion=<version> # --help # --srcdir=/path # --htmldir=/path @@ -103,6 +71,8 @@ proc parse_command_line {} { puts " --htmldir=DIR put generated HTML in DIR" 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 } @@ -116,6 +86,11 @@ proc parse_command_line {} { set webdir [string range $option 10 end] } + --useversion=* { + # length of "--useversion=" is 13 + set useversion [string range $option 13 end] + } + --tcl { set build_tcl 1 } @@ -124,6 +99,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 @@ -131,1594 +110,639 @@ proc parse_command_line {} { } } - if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1} + if {!$build_tcl && !$build_tk} { + set build_tcl 1; + set build_tk 1 + } if {$build_tcl} { - # Find Tcl. - set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ - -directory $tcltkdir {tcl{,[8-9].[0-9]{,.[0-9]}}}]] end] - if {$tcldir == ""} then { - puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" - exit 1 - } - puts "using Tcl source directory $tcldir" + # Find Tcl. + set tcldir [lindex [lsort [glob -nocomplain -tails -type d \ + -directory $tcltkdir tcl$useversion]] end] + if {$tcldir eq ""} { + puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" + exit 1 + } + puts "using Tcl source directory $tcldir" } if {$build_tk} { - # Find Tk. - set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ - -directory $tcltkdir {tk{,[8-9].[0-9]{,.[0-9]}}}]] end] - if {$tkdir == ""} then { - puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" - exit 1 - } - puts "using Tk source directory $tkdir" + # Find Tk. + set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ + -directory $tcltkdir tk$useversion]] end] + if {$tkdir eq ""} { + puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" + exit 1 + } + 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 "" - if {$build_tcl} {append overall_title "[capitalize $tcldir]"} - if {$build_tcl && $build_tk} {append overall_title "/"} - if {$build_tk} {append overall_title "[capitalize $tkdir]"} - append overall_title " Manual" + if {$build_tcl} { + append overall_title "[capitalize $tcldir]" + } + if {$build_tcl && $build_tk} { + append overall_title "/" + } + if {$build_tk} { + append overall_title "[capitalize $tkdir]" + } + append overall_title " Documentation" } 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" +} +proc css-stylesheet {} { + set hBd "1px dotted #11577b" + + 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; + } +} + ## -set manual(report-level) 1 - -proc manerror {msg} { - global manual - set name {} - set subj {} - if {[info exists manual(name)]} { - set name $manual(name) - } - if {[info exists manual(section)] && [string length $manual(section)]} { - puts stderr "$name: $manual(section): $msg" - } else { - puts stderr "$name: $msg" - } -} - -proc manreport {level msg} { - global manual - if {$level < $manual(report-level)} { - manerror $msg - } -} - -proc fatal {msg} { - global manual - manerror $msg - exit 1 -} -## -## parsing +## foreach of the man directories specified by args +## convert manpages into hypertext in the directory +## specified by html. ## -proc unquote arg { - return [string map [list \" {}] $arg] -} +proc make-man-pages {html args} { + global manual overall_title tcltkdesc verbose + global excluded_pages forced_index_pages process_first_patterns -proc parse-directive {line codename restname} { - upvar $codename code $restname rest - return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] -} + makedirhier $html + set cssfd [open $html/$::CSSFILE w] + puts $cssfd [css-stylesheet] + 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) {} -proc process-text {text} { - global manual - # preprocess text - set text [string map [list \ - {\&} "\t" \ - {&} {&} \ - {\\} {\} \ - {\e} {\} \ - {\ } { } \ - {\|} { } \ - {\0} { } \ - {\%} {} \ - "\\\n" "\n" \ - \" {"} \ - {<} {<} \ - {>} {>} \ - {\(+-} {±} \ - {\fP} {\fR} \ - {\.} . \ - {\(bu} {•} \ - ] $text] - regsub -all {\\o'o\^'} $text {\ô} text; # o-circumflex in re_syntax.n - regsub -all {\\-\\\|\\-} $text -- text; # two hyphens - regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens - regsub -all {\\-} $text - text; # a hyphen - regsub -all "\\\\\n" $text "\\\\n" text; # backslashed newline - 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]} { - manerror "process-text: impotent font change: $text" - set text $ntext - continue - } - # unrecognized - manerror "process-text: uncaught backslash: $text" - set text [string map [list "\\" "#92;"] $text] - } - return $text -} -## -## pass 2 text input and matching -## -proc open-text {} { - global manual - set manual(text-length) [llength $manual(text)] - set manual(text-pointer) 0 -} -proc more-text {} { - global manual - return [expr {$manual(text-pointer) < $manual(text-length)}] -} -proc next-text {} { - global manual - if {[more-text]} { - set text [lindex $manual(text) $manual(text-pointer)] - incr manual(text-pointer) - return $text - } - manerror "read past end of text" - error "fatal" -} -proc is-a-directive {line} { - return [string match .* $line] -} -proc split-directive {line opname restname} { - upvar $opname op $restname rest - set op [string range $line 0 2] - set rest [string trim [string range $line 3 end]] -} -proc next-op-is {op restname} { - global manual - upvar $restname rest - if {[more-text]} { - set text [lindex $manual(text) $manual(text-pointer)] - if {[string 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 {[string equal $arg $targ]} { - incr nback - incr manual(text-pointer) - continue - } - if {[regexp {^@(\w+)$} $arg all name]} { - upvar $name var - set var $targ - incr nback - incr manual(text-pointer) + # preprocess to set up subheader for the rest of the files + if {![llength $arg]} { continue } - if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\ - && [string equal $op [lindex $targ 0]]} { - upvar $name var - set var [lrange $targ 1 end] - incr nback - incr manual(text-pointer) - continue + lassign $arg -> name file + if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name -> pkg]} { + set name "$pkg Commands" + } elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name -> pkg]} { + set name "$pkg C API" } - backup-text $nback - return 0 + lappend manual(subheader) $name $file } - 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 equal $manual(section) "WIDGET-SPECIFIC OPTIONS"]} { - # link the defined option into the long table of contents - set link [long-toc "$switch, $name, $class"] - regsub -- "$switch, $name, $class" $link "$switch" link - return $link - } elseif {[string equal $manual(name):$manual(section) \ - "options:DESCRIPTION"]} { - # link the defined standard option to the long table of - # contents and make a target for the standard option references - # from other man pages. - set first [lindex $switch 0] - set here M$first - set there L[incr manual(long-toc-n)] - set manual(standard-option-$first) "<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>" - } else { - error "option-toc in $manual(name) section $manual(section)" - } -} -proc std-option-toc {name} { - global manual - if {[info exists manual(standard-option-$name)]} { - lappend manual(section-toc) <DD>$manual(standard-option-$name) - return $manual(standard-option-$name) - } - set here M[incr manual(section-toc-n)] - set there L[incr manual(long-toc-n)] - set other M$name - lappend manual(section-toc) "<DD><A HREF=\"options.htm#$other\">$name</A>" - return "<A HREF=\"options.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 { foreach {switch name class} $rest { break } } - 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" - } else { - 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" + ## + ## parse the manpages in a section of the docs (split by + ## package) and construct formatted manpages + ## + foreach arg $args { + if {[llength $arg]} { + make-manpage-section $html $arg } - 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> } - 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 - } + ## + ## build the keyword index. + ## + if {!$verbose} { + puts stderr "Assembling index" } - 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 - } - } + file delete -force -- $html/Keywords + makedirhier $html/Keywords + set keyfp [open $html/Keywords/[indexfile] w] + puts $keyfp [htmlhead "$tcltkdesc Keywords" "$tcltkdesc Keywords" \ + $overall_title "../[indexfile]"] + set letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} + # Create header first + set keyheader {} + foreach a $letters { + set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] + if {[llength $keys]} { + lappend keyheader "<A HREF=\"$a.htm\">$a</A>" } 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 {[string equal $code ".IP"] && [string equal $rest {}]} { - man-puts "<P>" - continue - } - if {[lsearch {.br .DS .RS} $code] >= 0} { - output-directive $line - } else { - backup-text 1 - break - } - } else { - man-puts $line - } + # No keywords for this letter + lappend keyheader $a } - man-puts </DL> - } else { - # labelled list, make contents - if { - [string compare $context ".SH"] && - [string compare $context ".SS"] - } then { - man-puts <P> + } + set keyheader <H3>[join $keyheader " |\n"]</H3> + puts $keyfp $keyheader + foreach a $letters { + set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] + if {![llength $keys]} { + continue } - 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 {[string equal $manual(section) "ARGUMENTS"] || \ - [regexp {^\[\d+\]$} $rest]} { - man-puts "$para<DT>$rest<DD>" - } elseif {[string equal {•} $rest]} { - man-puts "$para<DT><DD>$rest " - } else { - man-puts "$para<DT>[long-toc $rest]<DD>" - } - if {[string equal $manual(name):$manual(section) \ - "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 + # Per-keyword page + set afp [open $html/Keywords/$a.htm w] + puts $afp [htmlhead "$tcltkdesc Keywords - $a" \ + "$tcltkdesc Keywords - $a" \ + $overall_title "../[indexfile]"] + puts $afp $keyheader + puts $afp "<DL class=\"keylist\">" + foreach k [lsort -dictionary $keys] { + set k [string range $k 8 end] + puts $afp "<DT><A NAME=\"$k\">$k</A></DT>" + puts $afp "<DD>" + set refs {} + foreach man $manual(keyword-$k) { + set name [lindex $man 0] + set file [lindex $man 1] + if {[info exists manual(tooltip-$file)]} { + set tooltip $manual(tooltip-$file) + if {[string match {*[<>""]*} $tooltip]} { + manerror "bad tooltip for $file: \"$tooltip\"" } + lappend refs "<A HREF=\"../$file\" TITLE=\"$tooltip\">$name</A>" + } else { + lappend refs "<A HREF=\"../$file\">$name</A>" } - } 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</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 {[string equal $ref "Tcl"]} { - set lref $ref - } else { - set lref [string tolower $ref] - } - ## - ## nothing to reference - ## - if {![info exists manual(name-$lref)]} { - foreach name {array file history info interp string trace - after clipboard grab image option pack place selection tk tkwait update winfo wm} { - if {[regexp "^$name \[a-z0-9]*\$" $lref] && \ - [info exists manual(name-$name)] && \ - [string compare $manual(tail) "$name.n"]} { - return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>" - } - } - if {[lsearch {stdin stdout stderr end} $lref] >= 0} { - # no good place to send these - # tcl tokens? - # also end + puts $afp "[join $refs {, }]</DD>" } - return $ref + puts $afp "</DL>" + # insert merged copyrights + puts $afp [copyout $manual(merge-copyrights)] + puts $afp "</BODY></HTML>" + close $afp } + # insert merged copyrights + puts $keyfp [copyout $manual(merge-copyrights)] + puts $keyfp "</BODY></HTML>" + close $keyfp + ## - ## would be a self reference + ## finish off short table of contents ## - foreach name $manual(name-$lref) { - if {[lsearch $name $manual(wing-file)/$manual(name)] >= 0} { - return $ref - } - } + puts $manual(short-toc-fp) "<DT><A HREF=\"Keywords/[indexfile]\">Keywords</A><DD>The keywords from the $tcltkdesc man pages." + puts $manual(short-toc-fp) "</DL>" + # insert merged copyrights + puts $manual(short-toc-fp) [copyout $manual(merge-copyrights)] + puts $manual(short-toc-fp) "</BODY></HTML>" + close $manual(short-toc-fp) + ## - ## multiple choices for reference + ## output man pages ## - if {[llength $manual(name-$lref)] > 1} { - set tcl_i [lsearch -glob $manual(name-$lref) *TclCmd*] - set tcl_ref [lindex $manual(name-$lref) $tcl_i] - set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*] - set tk_ref [lindex $manual(name-$lref) $tk_i] - if {$tcl_i >= 0 && "$manual(wing-file)" == {TclCmd} \ - || "$manual(wing-file)" == {TclLib}} { - return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" - } - if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} \ - || "$manual(wing-file)" == {TkLib}} { - return "<A HREF=\"../$tk_ref.htm\">$ref</A>" - } - if {"$lref" == {exit} && "$manual(tail)" == {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 + unset manual(section) + if {!$verbose} { + puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links and write out" } - ## - ## exceptions, sigh, to the rule - ## - switch $manual(tail) { - canvas.n { - if {$lref == {focus}} { - upvar tail tail - set clue [string first command $tail] - if {$clue < 0 || $clue > 5} { - return $ref - } - } - if {[lsearch {bitmap image text} $lref] >= 0} { - return $ref - } - } - checkbutton.n - - radiobutton.n { - if {[lsearch {image} $lref] >= 0} { - return $ref - } - } - menu.n { - if {[lsearch {checkbutton radiobutton} $lref] >= 0} { - return $ref - } - } - options.n { - if {[lsearch {bitmap image set} $lref] >= 0} { - return $ref - } - } - regexp.n { - if {[lsearch {string} $lref] >= 0} { - return $ref - } - } - source.n { - if {[lsearch {text} $lref] >= 0} { - return $ref - } - } - history.n { - if {[lsearch {exec} $lref] >= 0} { - return $ref - } - } - return.n { - if {[lsearch {error continue break} $lref] >= 0} { - return $ref + foreach path $manual(all-pages) wing_name $manual(all-page-domains) { + 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 } - } - scrollbar.n { - if {[lsearch {set} $lref] >= 0} { - return $ref + 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) $wing_name "[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" } + } finally { + catch {close $outfd} } } - ## - ## 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 + if {!$verbose} { + puts stderr "\nDone" + } + return {} } + ## -## insert as many cross references into this text string as are appropriate +## Helper for assembling the descriptions of base packages (i.e., Tcl and Tk). ## -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]) == "tk"} { - set offsets [lreplace $offsets 1 1] - } - if {$invert([lindex $offsets 1]) == "tcl"} { - set offsets [lreplace $offsets 1 1] - } - switch -exact $invert([lindex $offsets 1]) { - end-quote { - set head [string range $text 0 [expr {$offset(quote)-1}]] - set body [string range $text [expr {$offset(quote)+2}] \ - [expr {$offset(end-quote)-1}]] - set tail [string range $text \ - [expr {$offset(end-quote)+2}] end] - return "$head``[cross-reference $body]''[insert-cross-references $tail]" - } - bold - - anchor { - set head [string range $text \ - 0 [expr {$offset(end-quote)+1}]] - set tail [string range $text \ - [expr {$offset(end-quote)+2}] end] - return "$head[insert-cross-references $tail]" - } +proc plus-base {var root glob name dir desc} { + global tcltkdir + if {$var} { + if {[file exists $tcltkdir/$root/README]} { + set f [open $tcltkdir/$root/README] + set d [read $f] + close $f + if {[regexp {This is the \w+ (\S+) source distribution} $d -> version]} { + append name ", version $version" } - return [reference-error "Uncaught quote case" $text] - } - bold { - if {$offset(end-bold) < 0} { return $text } - if {$invert([lindex $offsets 1]) == "tk"} { - set offsets [lreplace $offsets 1 1] - } - if {$invert([lindex $offsets 1]) == "tcl"} { - set offsets [lreplace $offsets 1 1] - } - switch -exact $invert([lindex $offsets 1]) { - end-bold { - set head [string range $text 0 [expr {$offset(bold)-1}]] - set body [string range $text [expr {$offset(bold)+3}] \ - [expr {$offset(end-bold)-1}]] - set tail [string range $text \ - [expr {$offset(end-bold)+4}] end] - return "$head<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] } + set glob $root/$glob + return [list $tcltkdir/$glob $name $dir $desc] } } + ## -## process formatting directives +## Helper for assembling the descriptions of contributed packages. ## -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 {[string compare .SS $code]} { - 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 {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} { - # these manual pages have two NAME sections - if {[info exists manual($manual(tail)-NAME)]} { - return - } - set manual($manual(tail)-NAME) 1 - } - set names {} - while {1} { - set line [next-text] - if {[is-a-directive $line]} { - backup-text 1 - output-name [join $names { }] - return - } else { - lappend names [string trim $line] - } - } - } - SYNOPSIS { - lappend manual(section-toc) <DL> - 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 <P> - continue - } - set more [next-text] - if {[is-a-directive $more]} { - manerror "in SYNOPSIS found $more" - backup-text 1 - break - } else { - foreach more [split $more \n] { - man-puts $more<BR> - if {[lsearch {TclLib TkLib} $manual(wing-file)] < 0} { - 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 { - if {[match-text @stuff .SE]} { - output-directive {.SH STANDARD OPTIONS} - set opts {} - foreach line [split $stuff \n] { - foreach option [split $line \t] { - lappend opts $option - } - } - man-puts <DL> - lappend manual(section-toc) <DL> - foreach option [lsort $opts] { - man-puts "<DT><B>[std-option-toc $option]</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]} { - - } - if {[match-text @stuff .DE]} { - 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]" +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 {} + set pkgsdir $tcltkdir/$tcldir/pkgs + foreach {dir name version} $args { + set globpat $pkgsdir/$dir/doc/*.$type + if {![llength [glob -type f -nocomplain $globpat]]} { + # Fallback for manpages generated using doctools + set globpat $pkgsdir/$dir/doc/man/*.$type + if {![llength [glob -type f -nocomplain $globpat]]} { + continue } - 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" + set dir [string trimright $dir "0123456789-."] + 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." } - } - .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> + 3 { + set title "$name Package C API" + if {$version ne ""} { + append title ", version $version" } - 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" + set dir [string totitle $dir]Lib + set desc \ + "The additional C functions provided by the $name package." } } - .fi { - manerror "ignoring $line" - } - .na - - .ad - - .UL - - .ne { - manerror "ignoring $line" - } - default { - manerror "unrecognized format directive: $line" - } + lappend result [list $globpat $title $dir $desc] } + return $result } + ## -## merge copyright listings -## -proc merge-copyrights {l1 l2} { - foreach copyright [concat $l1 $l2] { - if {[regexp {^Copyright +\(c\) +(\d+) +(by +)?(\w.*)$} $copyright all date by who]} { - lappend dates($who) $date - continue - } - if {[regexp {^Copyright +\(c\) +(\d+)-(\d+) +(by +)?(\w.*)$} $copyright all from to by who]} { - for {set date $from} {$date <= $to} {incr date} { - lappend dates($who) $date - } - continue - } - if {[regexp {^Copyright +\(c\) +(\d+), *(\d+) +(by +)?(\w.*)$} $copyright all date1 date2 by who]} { - lappend dates($who) $date1 $date2 - continue - } - puts "oops: $copyright" +## 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" } - foreach who [array names dates] { - set list [lsort $dates($who)] - if {[llength $list] == 1 || [lindex $list 0] == [lrange $list end end]} { - lappend merge "Copyright (c) [lindex $list 0] $who" - } else { - lappend merge "Copyright (c) [lindex $list 0]-[lrange $list end end] $who" - } + if {$build_tcl && $build_tk} { + append tcltkdesc "/" + append cmdesc " and " + append appdir "," } - return [lsort $merge] -} - -proc makedirhier {dir} { - if {![file isdirectory $dir] && \ - [catch {file mkdir $dir} error]} { - return -code error "cannot create directory $dir: $error" + if {$build_tk} { + append tcltkdesc "Tk" + append cmdesc "Tk" + append appdir "$tkdir" } -} -## -## foreach of the man directories specified by args -## convert manpages into hypertext in the directory -## specified by html. -## -proc make-man-pages {html args} { - global env manual overall_title tcltkdesc - makedirhier $html - set manual(short-toc-n) 1 - set manual(short-toc-fp) [open $html/contents.htm w] - puts $manual(short-toc-fp) "<HTML><HEAD><TITLE>$overall_title</TITLE></HEAD>" - puts $manual(short-toc-fp) "<BODY><HR><H3>$overall_title</H3><HR><DL>" - set manual(merge-copyrights) {} - foreach arg $args { - if {$arg == ""} {continue} - set manual(wing-glob) [lindex $arg 0] - set manual(wing-name) [lindex $arg 1] - set manual(wing-file) [lindex $arg 2] - set manual(wing-description) [lindex $arg 3] - set manual(wing-copyrights) {} - makedirhier $html/$manual(wing-file) - set manual(wing-toc-fp) [open $html/$manual(wing-file)/contents.htm w] - # whistle - puts stderr "scanning section $manual(wing-name)" - # put the entry for this section into the short table of contents - puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/contents.htm\">$manual(wing-name)</A><DD>$manual(wing-description)" - # initialize the wing table of contents - puts $manual(wing-toc-fp) "<HTML><HEAD><TITLE>$manual(wing-name) Manual</TITLE></HEAD>" - puts $manual(wing-toc-fp) "<BODY><HR><H3>$manual(wing-name)</H3><HR>" - # initialize the short table of contents for this section - set manual(wing-toc) {} - # initialize the man directory for this section - makedirhier $html/$manual(wing-file) - # initialize the long table of contents for this section - set manual(long-toc-n) 1 - # get the manual pages for this section - set manual(pages) [lsort [glob $manual(wing-glob)]] - if {[lsearch -glob $manual(pages) */options.n] >= 0} { - set n [lsearch $manual(pages) */options.n] - set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" - } - # set manual(pages) [lrange $manual(pages) 0 5] - foreach manual(page) $manual(pages) { - # whistle - puts stderr "scanning page $manual(page)" - set manual(tail) [file tail $manual(page)] - set manual(name) [file root $manual(tail)] - set manual(section) {} - if {[lsearch {case pack-old menubar} $manual(name)] >= 0} { - # obsolete - manerror "discarding $manual(name)" - continue - } - set manual(infp) [open $manual(page)] - set manual(text) {} - set manual(partial-text) {} - foreach p {.RS .DS .CS .SO} { - set manual($p) 0 - } - set manual(stack) {} - set manual(section) {} - set manual(section-toc) {} - set manual(section-toc-n) 1 - set manual(copyrights) {} - lappend manual(all-pages) $manual(wing-file)/$manual(tail) - manreport 100 $manual(name) - while {[gets $manual(infp) line] >= 0} { - manreport 100 $line - if {[regexp {^[`'][/\\]} $line]} { - if {[regexp {Copyright \(c\).*$} $line copyright]} { - lappend manual(copyrights) $copyright - } - # comment - continue - } - if {"$line" == {'}} { - # comment - continue - } - if {[parse-directive $line code rest]} { - switch -exact $code { - .ad - .na - .so - .ne - .AS - .VE - .VS - - . { - # ignore - continue - } - } - if {"$manual(partial-text)" != {}} { - lappend manual(text) [process-text $manual(partial-text)] - set manual(partial-text) {} - } - switch -exact $code { - .SH - .SS { - if {[llength $rest] == 0} { - gets $manual(infp) rest - } - lappend manual(text) "$code [unquote $rest]" - } - .TH { - lappend manual(text) "$code [unquote $rest]" - } - .HS - .UL - - .ta { - lappend manual(text) "$code [unquote $rest]" - } - .BS - .BE - .br - .fi - .sp - - .nf { - if {"$rest" != {}} { - manerror "unexpected argument: $line" - } - lappend manual(text) $code - } - .AP { - lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]] - } - .IP { - regexp {^(.*) +\d+$} $rest all rest - lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]" - } - .TP { - while {[is-a-directive [set next [gets $manual(infp)]]]} { - manerror "ignoring $next after .TP" - } - if {"$next" != {'}} { - lappend manual(text) ".IP [process-text $next]" - } - } - .OP { - lappend manual(text) [concat .OP [process-text \ - "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]] - } - .PP - - .LP { - lappend manual(text) {.PP} - } - .RS { - incr manual(.RS) - lappend manual(text) $code - } - .RE { - incr manual(.RS) -1 - lappend manual(text) $code - } - .SO { - incr manual(.SO) - lappend manual(text) $code - } - .SE { - incr manual(.SO) -1 - lappend manual(text) $code - } - .DS { - incr manual(.DS) - lappend manual(text) $code - } - .DE { - incr manual(.DS) -1 - lappend manual(text) $code - } - .CS { - incr manual(.CS) - lappend manual(text) $code - } - .CE { - incr manual(.CS) -1 - lappend manual(text) $code - } - .de { - while {[gets $manual(infp) line] >= 0} { - if {[string match "..*" $line]} { - break - } - } - } - .. { - error "found .. outside of .de" - } - default { - manerror "unrecognized format directive: $line" - } - } - } else { - if {$manual(partial-text) == ""} { - set manual(partial-text) $line - } else { - append manual(partial-text) \n$line + apply {{} { + global packageBuildList tcltkdir tcldir build_tcl + + # When building docs for Tcl, try to build docs for bundled packages too + set packageBuildList {} + if {$build_tcl} { + set pkgsDir [file join $tcltkdir $tcldir pkgs] + set subdirs [glob -nocomplain -types d -tails -directory $pkgsDir *] + + foreach dir [lsort $subdirs] { + # Parse the subdir name into (name, version) as fallback... + set description [split $dir -] + if {2 != [llength $description]} { + regexp {([^0-9]*)(.*)} $dir -> n v + set description [list $n $v] + } + + # ... but try to extract (name, version) from subdir contents + try { + set f [open [file join $pkgsDir $dir configure.in]] + foreach line [split [read $f] \n] { + if {2 == [scan $line \ + { AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} { + set description [list $n $v] + break } } + } finally { + catch {close $f; unset f} } - if {$manual(partial-text) != ""} { - lappend manual(text) [process-text $manual(partial-text)] - } - close $manual(infp) - # fixups - if {$manual(.RS) != 0} { - if {$manual(name) != "selection"} { - puts "unbalanced .RS .RE" - } - } - if {$manual(.DS) != 0} { - puts "unbalanced .DS .DE" - } - if {$manual(.CS) != 0} { - puts "unbalanced .CS .CE" - } - if {$manual(.SO) != 0} { - puts "unbalanced .SO .SE" - } - # output conversion - open-text - if {[next-op-is .HS rest]} { - set manual($manual(name)-title) \ - "[lrange $rest 1 end] [lindex $rest 0] manual page" - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - output-directive $line - } else { - man-puts $line - } - } - man-puts <HR><PRE> - foreach copyright $manual(copyrights) { - man-puts "<A HREF=\"../copyright.htm\">Copyright</A> © [lrange $copyright 2 end]" - } - man-puts "<A HREF=\"../copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr.</PRE>" - set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)] - } elseif {[next-op-is .TH rest]} { - set manual($manual(name)-title) "[lrange $rest 4 end] - [lindex $rest 0] manual page" - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - output-directive $line - } else { - man-puts $line - } - } - man-puts <HR><PRE> - foreach copyright $manual(copyrights) { - man-puts "<A HREF=\"../copyright.htm\">Copyright</A> © [lrange $copyright 2 end]" - } - man-puts "<A HREF=\"../copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr.</PRE>" - set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)] - } else { - manerror "no .HS or .TH record found" - } - # - # make the long table of contents for this page - # - set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL><HR>] - } - # - # 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] + if {[file exists [file join $pkgsDir $dir configure]]} { + # Looks like a package, record our best extraction attempt + lappend packageBuildList $dir {*}$description } } - set perline [expr {120 / $width}] - set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] - set n 0 - catch {unset rows} - foreach name [lsort $manual(wing-toc)] { - set tail $manual(name-$name) - if {[llength $tail] > 1} { - manerror "$name is defined in more than one file: $tail" - set tail [lindex $tail [expr {[llength $tail]-1}]] - } - set tail [file tail $tail] - append rows([expr {$n%$nrows}]) \ - "<td> <a href=\"$tail.htm\">$name</a>" - 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) "<HR><PRE>" - foreach copyright $manual(wing-copyrights) { - puts $manual(wing-toc-fp) "<A HREF=\"../copyright.htm\">Copyright</A> © [lrange $copyright 2 end]" - } - puts $manual(wing-toc-fp) "<A HREF=\"../copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr." - puts $manual(wing-toc-fp) "</PRE></BODY></HTML>" - close $manual(wing-toc-fp) - set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)] } - ## - ## build the keyword index. - ## - proc strcasecmp {a b} { return [string compare -nocase $a $b] } - set keys [lsort -command strcasecmp [array names manual keyword-*]] - makedirhier $html/Keywords - catch {eval file delete -- [glob $html/Keywords/*]} - puts $manual(short-toc-fp) "<DT><A HREF=\"Keywords/contents.htm\">Keywords</A><DD>The keywords from the $tcltkdesc man pages." - set keyfp [open $html/Keywords/contents.htm w] - puts $keyfp "<HTML><HEAD><TITLE>$tcltkdesc Keywords</TITLE></HEAD>" - puts $keyfp "<BODY><HR><H3>$tcltkdesc Keywords</H3><HR><H2>" - foreach a {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { - puts $keyfp "<A HREF=\"$a.htm\">$a</A>" - set afp [open $html/Keywords/$a.htm w] - puts $afp "<HTML><HEAD><TITLE>$tcltkdesc Keywords - $a</TITLE></HEAD>" - puts $afp "<BODY><HR><H3>$tcltkdesc Keywords - $a</H3><HR><H2>" - foreach b {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { - puts $afp "<A HREF=\"$b.htm\">$b</A>" - } - puts $afp "</H2><HR><DL>" - foreach k $keys { - if {[string match -nocase "keyword-${a}*" $k]} { - set k [string range $k 8 end] - puts $afp "<DT><A NAME=\"$k\">$k</A><DD>" - set refs {} - foreach man $manual(keyword-$k) { - set name [lindex $man 0] - set file [lindex $man 1] - lappend refs "<A HREF=\"../$file\">$name</A>" + # 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 + lassign $line dir name + lappend packageDirNameMap $dir $name } - puts $afp [join $refs {, }] + } finally { + close $f } } - puts $afp "</DL><HR><PRE>" - # insert merged copyrights - foreach copyright $manual(merge-copyrights) { - puts $afp "<A HREF=\"copyright.htm\">Copyright</A> © [lrange $copyright 2 end]" + } trap {POSIX ENOENT} {} { + set packageDirNameMap { + itcl {[incr Tcl]} + tdbc {TDBC} + thread Thread } - puts $afp "<A HREF=\"copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr." - puts $afp "</PRE></BODY></HTML>" - close $afp - } - puts $keyfp "</H2><HR><PRE>" - - # insert merged copyrights - foreach copyright $manual(merge-copyrights) { - puts $keyfp "<A HREF=\"copyright.htm\">Copyright</A> © [lrange $copyright 2 end]" - } - puts $keyfp "<A HREF=\"copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr." - puts $keyfp </PRE><HR></BODY></HTML> - close $keyfp - - ## - ## finish off short table of contents - ## - puts $manual(short-toc-fp) {<DT><A HREF="http://www.elf.org">Source</A><DD>More information about these man pages.} - puts $manual(short-toc-fp) "</DL><HR><PRE>" - # insert merged copyrights - foreach copyright $manual(merge-copyrights) { - puts $manual(short-toc-fp) "<A HREF=\"copyright.htm\">Copyright</A> © [lrange $copyright 2 end]" } - puts $manual(short-toc-fp) "<A HREF=\"copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr." - puts $manual(short-toc-fp) "</PRE></BODY></HTML>" - close $manual(short-toc-fp) - ## - ## output man pages - ## - unset manual(section) - foreach path $manual(all-pages) { - set manual(wing-file) [file dirname $path] - set manual(tail) [file tail $path] - set manual(name) [file root $manual(tail)] - set text $manual(output-$manual(wing-file)-$manual(name)) - set ntext 0 - foreach item $text { - incr ntext [llength [split $item \n]] - incr ntext + # Convert to human readable names, if applicable + for {set idx 0} {$idx < [llength $packageBuildList]} {incr idx 3} { + lassign [lrange $packageBuildList $idx $idx+2] d n v + if {[dict exists $packageDirNameMap $n]} { + lset packageBuildList $idx+1 [dict get $packageDirNameMap $n] } - set toc $manual(toc-$manual(wing-file)-$manual(name)) - set ntoc 0 - foreach item $toc { - incr ntoc [llength [split $item \n]] - incr ntoc - } - puts stderr "rescanning page $manual(name) $ntoc/$ntext" - set manual(outfp) [open $html/$manual(wing-file)/$manual(name).htm w] - puts $manual(outfp) "<HTML><HEAD><TITLE>$manual($manual(name)-title)</TITLE></HEAD><BODY>" - if {($ntext > 60) && ($ntoc > 32) || [lsearch { - Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType CrtItemType - CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetDash - GetJustify GetPixels GetVisual ParseArgv QueueEvent - } $manual(tail)] >= 0} { - foreach item $toc { - puts $manual(outfp) $item - } - } - foreach item $text { - puts $manual(outfp) [insert-cross-references $item] - } - puts $manual(outfp) </BODY></HTML> - close $manual(outfp) } - return {} -} - -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"} + }} -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 - } + # + # 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 {*}$packageBuildList] \ + [plus-base $build_tcl $tcldir doc/*.3 {Tcl C API} TclLib \ + "The C functions which a Tcl extended C program may use."] \ + [plus-base $build_tk $tkdir doc/*.3 {Tk C API} TkLib \ + "The additional C functions which a Tk extended C program may use."] \ + {*}[plus-pkgs 3 {*}$packageBuildList] +} 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: |