From 671c6e58fccb3a31aaaa79897e8c664ffb21fe82 Mon Sep 17 00:00:00 2001 From: hobbs Date: Tue, 21 Dec 1999 23:59:28 +0000 Subject: renamed tcl8.1-tk8.1-man-html.tcl tcltk-man2html.tcl, and rewrote the internals to use 8.2+ string functions tcl.wse.in moved to 8.3b1 --- tools/man2help.tcl | 12 +- tools/man2help2.tcl | 79 +- tools/tcl.wse.in | 2 +- tools/tcl8.1-tk8.1-man-html.tcl | 1663 -------------------------------------- tools/tcltk-man2html.tcl | 1675 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 1721 insertions(+), 1710 deletions(-) delete mode 100644 tools/tcl8.1-tk8.1-man-html.tcl create mode 100755 tools/tcltk-man2html.tcl diff --git a/tools/man2help.tcl b/tools/man2help.tcl index e86e78b..efe254b 100644 --- a/tools/man2help.tcl +++ b/tools/man2help.tcl @@ -6,7 +6,7 @@ # # Copyright (c) 1996 by Sun Microsystems, Inc. # -# RCS: @(#) $Id: man2help.tcl,v 1.4 1999/02/19 02:14:56 stanton Exp $ +# RCS: @(#) $Id: man2help.tcl,v 1.5 1999/12/21 23:59:28 hobbs Exp $ # # @@ -17,7 +17,6 @@ proc generateContents {basename version files} { global curID topics set curID 0 foreach f $files { - regsub -all -- {-} [file tail $f] {} curFile puts "Pass 1 -- $f" flush stdout doFile $f @@ -30,7 +29,7 @@ proc generateContents {basename version files} { puts $fd "1 $section" set lastTopic {} foreach topic [getTopics $package $section] { - if {[string compare $lastTopic $topic] != 0} { + if {[string equal $lastTopic $topic]} { set id $topics($package,$section,$topic) puts $fd "2 $topic=$id" set lastTopic $topic @@ -55,12 +54,11 @@ proc generateHelp {basename files} { lappend id_keywords($id) $key } } - + set file [open "$basename.rtf" w] fconfigure $file -translation crlf puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\}" foreach f $files { - regsub -all -- {-} [file tail $f] {} curFile puts "Pass 2 -- $f" flush stdout initGlobals @@ -117,11 +115,11 @@ set version [lindex $argv 1] set files {} foreach i [lrange $argv 2 end] { set i [file join $i] - if [file isdir $i] { + if {[file isdir $i]} { foreach f [lsort [glob [file join $i *.\[13n\]]]] { lappend files $f } - } elseif [file exists $i] { + } elseif {[file exists $i]} { lappend files $i } } diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index dce162f..df04a6c 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: man2help2.tcl,v 1.3 1998/09/14 18:40:15 stanton Exp $ +# RCS: @(#) $Id: man2help2.tcl,v 1.4 1999/12/21 23:59:29 hobbs Exp $ # # Global variables used by these scripts: @@ -82,7 +82,7 @@ proc beginFont {font} { global file state textSetup - if {$state(curFont) == $font} { + if {[string equal $state(curFont) $font]} { return } endFont @@ -101,7 +101,7 @@ proc beginFont {font} { proc endFont {} { global state file - if {$state(curFont) != ""} { + if {[string compare $state(curFont) ""]} { puts -nonewline $file $state(end$state(curFont)) set state(curFont) "" } @@ -144,14 +144,18 @@ proc text {string} { global file state chars textSetup - regsub -all "(\[\\\\\{\}\])" $string {\\\1} string - regsub -all { } $string {\\tab } string - regsub -all '' $string \" string - regsub -all `` $string \" string - -# Check if this is the beginning of an international character string. -# If so, look up the sequence in the chars table and substitute the -# appropriate hex value. + set string [string map [list \ + "\\" "\\\\" \ + "\{" "\\\{" \ + "\}" "\}" \ + "\t" {\tab } \ + '' \" \ + `` \" \ + ] $string] + + # Check if this is the beginning of an international character string. + # If so, look up the sequence in the chars table and substitute the + # appropriate hex value. if {$state(intl)} { if {[regexp {^'([^']*)'} $string dummy ch]} { @@ -173,10 +177,10 @@ proc text {string} { SEE { global topics curPkg curSect foreach i [split $string] { - if ![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ] { + if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} { continue } - if ![catch {set ref $topics($curPkg,$curSect,$i)} ] { + if {![catch {set ref $topics($curPkg,$curSect,$i)} ]} { regsub $i $string [link $i $ref] string } } @@ -204,7 +208,7 @@ proc insertRef {string} { set path {} set string [string trim $string] set ref {} - if [info exists topics($curPkg,$curSect,$string)] { + if {[info exists topics($curPkg,$curSect,$string)]} { set ref $topics($curPkg,$curSect,$string) } else { set sites [array names topics "$curPkg,*,$string"] @@ -220,7 +224,7 @@ proc insertRef {string} { } } - if {([string compare $ref {}] != 0) && ($ref != $curID)} { + if {([string equal $ref {}]) && ($ref != $curID)} { set string [link $string $ref] } return $string @@ -476,39 +480,38 @@ proc formattedText {text} { text $text return } - text [string range $text 0 [expr $index-1]] - set c [string index $text [expr $index+1]] + text [string range $text 0 [expr {$index-1}]] + set c [string index $text [expr {$index+1}]] switch -- $c { f { - font [string index $text [expr $index+2]] - set text [string range $text [expr $index+3] end] + font [string index $text [expr {$index+2}]] + set text [string range $text [expr {$index+3}] end] } e { - text \\ - set text [string range $text [expr $index+2] end] + text "\\" + set text [string range $text [expr {$index+2}] end] } - { dash - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } | { - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } o { - text \\' + text "\\'" regexp "'([^']*)'(.*)" $text all ch text text $chars($ch) } default { puts stderr "Unknown sequence: \\$c" - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index+2}] end] } } } } - # dash -- # # This procedure is invoked to handle dash characters ("\-" in @@ -519,7 +522,7 @@ proc formattedText {text} { proc dash {} { global state - if {$state(textState) == "NAME"} { + if {[string equal $state(textState) "NAME"]} { set state(textState) 0 } text "-" @@ -554,10 +557,9 @@ proc setTabs {tabList} { global file state foreach arg $tabList { - set distance [expr $state(leftMargin) \ - + $state(offset) * $state(nestingLevel) \ - + [getTwips $arg]] - puts $file [format "\\tx%.0f" [expr round($distance)]] + set distance [expr {$state(leftMargin) \ + + ($state(offset) * $state(nestingLevel)) + [getTwips $arg]}] + puts $file [format "\\tx%.0f" [expr {round($distance)}]] } } @@ -590,10 +592,10 @@ proc lineBreak {} { proc newline {} { global state - if $state(inTP) { + if {$state(inTP)} { set state(inTP) 0 lineBreak - } elseif $state(noFill) { + } elseif {$state(noFill)} { lineBreak } else { text " " @@ -792,7 +794,7 @@ proc TPmacro {argList} { if {$length == 0} { set val 0.5i } else { - set val [expr ([lindex $argList 0] * 100.0)/1440]i + set val [expr {([lindex $argList 0] * 100.0)/1440}]i } newPara $val -$val setTabs $val @@ -887,9 +889,8 @@ proc newPara {leftIndent {firstIndent 0i}} { if $state(paragraph) { puts -nonewline $file "\\line\n" } - set state(leftIndent) [expr $state(leftMargin) \ - + $state(offset) * $state(nestingLevel) \ - + [getTwips $leftIndent]] + set state(leftIndent) [expr {$state(leftMargin) \ + + ($state(offset) * $state(nestingLevel)) +[getTwips $leftIndent]}] set state(firstIndent) [getTwips $firstIndent] set state(paragraphPending) 1 } @@ -911,10 +912,10 @@ proc getTwips {arg} { } switch -- $units { c { - set distance [expr $distance * 567] + set distance [expr {$distance * 567}] } i { - set distance [expr $distance * 1440] + set distance [expr {$distance * 1440}] } default { puts stderr "bad units in distance \"$arg\"" diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index 20e7a2c..61de5cf 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.3a1 + Disk Label=tcl8.3b1 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 diff --git a/tools/tcl8.1-tk8.1-man-html.tcl b/tools/tcl8.1-tk8.1-man-html.tcl deleted file mode 100644 index cb51f34..0000000 --- a/tools/tcl8.1-tk8.1-man-html.tcl +++ /dev/null @@ -1,1663 +0,0 @@ -#!/usr/local/bin/tclsh8.0 -# -# Convert Ousterhout format man pages into highly crosslinked -# hypertext. -# -# Along the way detect many unmatched font changes and other odd -# things. -# -# Note well, this program is a hack rather than a piece of software -# engineering. In that sense it's probably a good example of things -# that a scripting language, like Tcl, can do well. It is offered as -# an example of how someone might convert a specific set of man pages -# into hypertext, not as a general solution to the problem. If you -# try to use this, you'll be very much on your own. -# -# Copyright (c) 1995-1997 Roger E. Critchlow Jr -# -# The authors hereby grant permission to use, copy, modify, distribute, -# and license this software and its documentation for any purpose, provided -# that existing copyright notices are retained in all copies and that this -# notice is included verbatim in any distributions. No written agreement, -# license, or royalty fee is required for any of the authorized uses. -# Modifications to this software may be copyrighted by their authors -# and need not follow the licensing terms described here, provided that -# the new terms are clearly indicated on the first page of each file where -# they apply. -# -# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE -# POSSIBILITY OF SUCH DAMAGE. -# -# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR -# MODIFICATIONS. -# -# Revisions: -# May 15, 1995 - initial release -# May 16, 1995 - added a back to home link to toplevel table of -# contents. -# May 18, 1995 - broke toplevel table of contents into separate -# pages for each section, and broke long table of contents -# into a one page for each man page. -# Mar 10, 1996 - updated for tcl7.5b3/tk4.1b3 -# Apr 14, 1996 - incorporated command line parsing from Tom Tromey, -# -- thanks Tom. -# - updated for tcl7.5/tk4.1 final release. -# - converted to same copyright as the man pages. -# Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1 -# Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions. -# Oct 22, 1996 - major hacking on indentation code and elsewhere. -# Mar 4, 1997 - -# May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions -# - cleaned source for tclsh8.0 execution -# - renamed output files for windoze installation -# - added spaces to tables -# Oct 24, 1997 - moved from 8.0b1 to 8.0 release -# - -set Version "0.14" - -proc parse_command_line {} { - global argv Version - - # These variables determine where the man pages come from and where - # the converted pages go to. - global tcltkdir tkdir tcldir webdir - - # Set defaults based on original code. - set tcltkdir ../.. - set tkdir {} - set tcldir {} - set webdir ../html - - # Directory names for Tcl and Tk, in priority order. - set tclDirList {tcl8.2 tcl8.1 tcl8.0 tcl tcl7.4 tcl7.5 tcl7.6} - set tkDirList {tk8.2 tk8.1 tk8.0 tk tk4.0 tk4.1 tk4.2} - - # Handle arguments a la GNU: - # --version - # --help - # --srcdir=/path - # --htmldir=/path - - foreach option $argv { - switch -glob -- $option { - --version { - puts "tcltk-man-html $Version" - exit 0 - } - - --help { - puts "usage: tcltk-man-html \[OPTION\] ...\n" - puts " --help print this help, then exit" - puts " --version print version number, then exit" - puts " --srcdir=DIR find tcl and tk source below DIR" - puts " --htmldir=DIR put generated HTML in DIR" - exit 0 - } - - --srcdir=* { - # length of "--srcdir=" is 9. - set tcltkdir [string range $option 9 end] - } - - --htmldir=* { - # length of "--htmldir=" is 10 - set webdir [string range $option 10 end] - } - - default { - puts stderr "tcltk-man-html: unrecognized option -- `$option'" - exit 1 - } - } - } - - # Find Tcl. - foreach dir $tclDirList { - if {[file isdirectory $tcltkdir/$dir]} then { - set tcldir $dir - break - } - } - if {$tcldir == ""} then { - puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" - exit 1 - } - - # Find Tk. - foreach dir $tkDirList { - if {[file isdirectory $tcltkdir/$dir]} then { - set tkdir $dir - break - } - } - if {$tkdir == ""} then { - puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" - exit 1 - } - - # the title for the man pages overall - global overall_title - set overall_title "[capitalize $tcldir]/[capitalize $tkdir] Manual" -} - -proc capitalize {string} { - return [string toupper [string index $string 0]][string range $string 1 end] -} - -## -## -## -set manual(report-level) 1; - -proc manerror {msg} { - global manual; - set name {}; - set subj {}; - if {[info exists manual(name)]} { - set name $manual(name); - } - if {[info exists manual(section)] && "$manual(section)" != {}} { - puts stderr "$name: $manual(section): $msg"; - } else { - puts stderr "$name: $msg"; - } -} - -proc manreport {level msg} { - global manual; - if {$level < $manual(report-level)} { - manerror $msg; - } -} - -proc fatal {msg} { - global manual; - manerror $msg; - exit 1; -} -## -## parsing -## -proc unquote arg { - regsub -all \" $arg {} arg; - return $arg; -} - -proc parse-directive {line codename restname} { - upvar $codename code $restname rest; - return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest]; -} - -proc process-text {text} { - global manual; - # preprocess text - regsub -all {\\&} $text \t text; # some kind of tab? - regsub -all {&} $text {\&} text; - regsub -all {\\\\} $text {\\} text; # reverse solidus, ie backslash - regsub -all {\\ } $text {\ } text; # non breaking space - regsub -all {\\%} $text {} text; # don't break word following? - regsub -all "\\\\\n" $text "\n" text; # - regsub -all \" $text {\"} text; - regsub -all {<} $text {\<} text; - regsub -all {>} $text {\>} text; - regsub -all {\\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 {\\0} $text { } text; # a space - regsub -all {\\\|} $text {\ } text; # a very thin space - regsub -all {\\e} $text {\\} text; # reverse solidus, ie backslash - regsub -all {\\\(\+-} $text {\±} text; # plus or minus sign - regsub -all {\\fP} $text {\\fR} text; # a funky font in expr.n - regsub -all {\\\.} $text . text; # a plain . - regsub -all "\\\\\n" $text "\\&\#92;\n" text; # an escaped newline - while {[regexp {\\} $text]} { - # C R - if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue - # B R - if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue - # B I - if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text {\1\2\\fI\3} text]} continue - # I R - if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue - # I B - if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text {\1\2\\fB\3} text]} continue - # B B, I I, R R - if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text {\1\\fB\2\3} ntext] - || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text {\1\\fI\2\3} ntext] - || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text {\1\\fR\2\3} ntext]} { - manerror "process-text: impotent font change: $text"; - set text $ntext; - continue; - } - # unrecognized - manerror "process-text: uncaught backslash: $text" - regsub -all {\\} $text {#92;} text - } - return $text -} -## -## pass 2 text input and matching -## -proc open-text {} { - global manual; - set manual(text-length) [llength $manual(text)]; - set manual(text-pointer) 0; -} -proc more-text {} { - global manual; - return [expr $manual(text-pointer) < $manual(text-length)]; -} -proc next-text {} { - global manual; - if {[more-text]} { - set text [lindex $manual(text) $manual(text-pointer)]; - incr manual(text-pointer); - return $text; - } - manerror "read past end of text"; - error "fatal"; -} -proc is-a-directive {line} { - return [expr {[string first . $line] == 0}] -} -proc split-directive {line opname restname} { - upvar $opname op $restname rest - set op [string range $line 0 2]; - set rest [string trim [string range $line 3 end]]; -} -proc next-op-is {op restname} { - global manual; - upvar $restname rest; - if {[more-text]} { - set text [lindex $manual(text) $manual(text-pointer)]; - if {[string compare [string range $text 0 2] $op] == 0} { - set rest [string range $text 4 end]; - incr manual(text-pointer); - return 1; - } - } - return 0; -} -proc backup-text {n} { - global manual; - if {$manual(text-pointer)-$n >= 0} { - incr manual(text-pointer) -$n; - } -} -proc match-text args { - global manual; - set nargs [llength $args]; - if {$manual(text-pointer) + $nargs > $manual(text-length)} { - return 0; - } - set nback 0; - foreach arg $args { - if { ! [more-text]} { - backup-text $nback; - return 0; - } - set arg [string trim $arg]; - set targ [string trim [lindex $manual(text) $manual(text-pointer)]]; - if {"$arg" == "$targ"} { - incr nback; - incr manual(text-pointer); - continue; - } - if {[regexp {^@([_a-zA-Z0-9]+)$} $arg all name]} { - upvar $name var; - set var $targ; - incr nback; - incr manual(text-pointer); - continue; - } - if {[regexp {^(\.[a-zA-Z][a-zA-Z])@([_a-zA-Z0-9]+)$} $arg all op name] && "$op" == "[lindex $targ 0]"} { - upvar $name var; - set var [lrange $targ 1 end]; - incr nback; - incr manual(text-pointer); - continue; - } - backup-text $nback; - return 0; - } - return 1; -} -proc expand-next-text {n} { - global manual; - return [join [lrange $manual(text) $manual(text-pointer) [expr $manual(text-pointer)+$n-1]] \n\n]; -} -## -## pass 2 output -## -proc man-puts {text} { - global manual; - lappend manual(output-$manual(wing-file)-$manual(name)) $text; -} - -## -## build hypertext links to tables of contents -## -proc long-toc {text} { - global manual; - set here M[incr manual(section-toc-n)] - set there L[incr manual(long-toc-n)]; - lappend manual(section-toc) "
$text"; - return "$text"; -} -proc option-toc {name class switch} { - global manual; - if {"$manual(section)" == {WIDGET-SPECIFIC OPTIONS}} { - # link the defined option into the long table of contents - set link [long-toc "$switch, $name, $class"]; - regsub -- "$switch, $name, $class" $link "$switch" link; - return $link; - } elseif {"$manual(name):$manual(section)" == {options:DESCRIPTION}} { - # link the defined standard option to the long table of - # contents and make a target for the standard option references - # from other man pages. - set first [lindex $switch 0]; - set here M$first; - set there L[incr manual(long-toc-n)]; - set manual(standard-option-$first) "$switch, $name, $class"; - lappend manual(section-toc) "
$switch, $name, $class"; - return "$switch"; - } else { - error "option-toc in $manual(name) section $manual(section)"; - } -} -proc std-option-toc {name} { - global manual; - if {[info exists manual(standard-option-$name)]} { - lappend manual(section-toc)
$manual(standard-option-$name); - return $manual(standard-option-$name); - } - set here M[incr manual(section-toc-n)] - set there L[incr manual(long-toc-n)]; - set other M$name; - lappend manual(section-toc) "
$name"; - return "$name"; -} -## -## process the widget option section -## in widget and options man pages -## -proc output-widget-options {rest} { - global manual - man-puts
; - lappend manual(section-toc)
; - backup-text 1; - set para {} - while {[next-op-is .OP rest]} { - switch -exact [llength $rest] { - 3 { - set switch [lindex $rest 0]; - set name [lindex $rest 1]; - set class [lindex $rest 2]; - } - 5 { - set switch [lrange $rest 0 2]; - set name [lindex $rest 3]; - set class [lindex $rest 4]; - } - default { - fatal "bad .OP $rest"; - } - } - if { ! [regexp {^(<.>)([-a-zA-Z0-9 ]+)()$} $switch all oswitch switch cswitch]} { - if { ! [regexp {^(<.>)([-a-zA-Z0-9 ]+) or ([-a-zA-Z0-9 ]+)()$} $switch all oswitch switch1 switch2 cswitch]} { - error "not Switch: $switch"; - } else { - set switch "$switch1$cswitch or $oswitch$switch2"; - } - } - if { ! [regexp {^(<.>)([a-zA-Z0-9]*)()$} $name all oname name cname]} { - error "not Name: $name"; - } - if { ! [regexp {^(<.>)([a-zA-Z0-9]*)()$} $class all oclass class cclass]} { - error "not Class: $class"; - } - man-puts "$para
Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"; - man-puts "
Database Name: $oname$name$cname"; - man-puts "
Database Class: $oclass$class$cclass"; - man-puts
[next-text]; - set para

- } - man-puts

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

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

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

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

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

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

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

; - } - man-puts

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

$rest
"; - } else { - man-puts "

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

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

$rest

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

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

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

[long-toc $manual(section)]

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

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

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

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

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

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

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

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

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

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

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


$overall_title


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

$manual(wing-name)


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

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

Tcl/Tk Keywords


" - foreach a {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { - puts $keyfp "$a" - set afp [open $html/Keywords/$a.htm w]; - puts $afp "Tcl/Tk Keywords - $a" - puts $afp "

Tcl/Tk Keywords - $a


" - foreach b {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { - puts $afp "$b" - } - puts $afp "


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

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

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

";
-    # insert merged copyrights
-    foreach copyright $manual(merge-copyrights) {
-	puts $manual(short-toc-fp) "Copyright © [lrange $copyright 2 end]";
-    }
-    puts $manual(short-toc-fp) "Copyright © 1995-1997 Roger E. Critchlow Jr.";
-    puts $manual(short-toc-fp) "
"; - close $manual(short-toc-fp); - - ## - ## output man pages - ## - unset manual(section); - foreach path $manual(all-pages) { - set manual(wing-file) [file dirname $path]; - set manual(tail) [file tail $path]; - set manual(name) [file root $manual(tail)]; - set text $manual(output-$manual(wing-file)-$manual(name)); - set ntext 0; - foreach item $text { - incr ntext [llength [split $item \n]]; - incr ntext; - } - set toc $manual(toc-$manual(wing-file)-$manual(name)); - set ntoc 0; - foreach item $toc { - incr ntoc [llength [split $item \n]]; - incr ntoc; - } - puts stderr "rescanning page $manual(name) $ntoc/$ntext"; - set manual(outfp) [open $html/$manual(wing-file)/$manual(name).htm w]; - puts $manual(outfp) "$manual($manual(name)-title)" - if {$ntext > 60 && $ntoc > 32 - || [lsearch {Hash LinkVar SetVar TraceVar - ConfigWidg CrtImgType CrtItemType CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetJustify GetPixels GetVisual - ParseArgv QueueEvent} $manual(tail)] >= 0} { - foreach item $toc { - puts $manual(outfp) $item; - } - } - foreach item $text { - puts $manual(outfp) [insert-cross-references $item]; - } - puts $manual(outfp) ; - close $manual(outfp); - } - return {}; -} - -set usercmddesc {The interpreters which implement Tcl and Tk.} -set tclcmddesc {The commands which the tclsh interpreter implements.} -set tkcmddesc {The additional commands which the wish interpreter implements.} -set tcllibdesc {The C functions which a Tcl extended C program may use.} -set tklibdesc {The additional C functions which a Tk extended C program may use.} - -parse_command_line - -if {1} { - if {[catch { - make-man-pages $webdir \ - "$tcltkdir/{$tkdir,$tcldir}/doc/*.1 {Tcl/Tk Applications} UserCmd {$usercmddesc}" \ - "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" \ - "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" \ - "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" \ - "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" - } error]} { - puts $error\n$errorInfo; - } -} - diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl new file mode 100755 index 0000000..3893e55 --- /dev/null +++ b/tools/tcltk-man2html.tcl @@ -0,0 +1,1675 @@ +#!/bin/sh +# The next line is executed by /bin/sh, but not tcl \ +exec tclsh8.2 "$0" ${1+"$@"} + +package require Tcl 8.2 + +# Convert Ousterhout format man pages into highly crosslinked +# hypertext. +# +# Along the way detect many unmatched font changes and other odd +# things. +# +# Note well, this program is a hack rather than a piece of software +# engineering. In that sense it's probably a good example of things +# that a scripting language, like Tcl, can do well. It is offered as +# an example of how someone might convert a specific set of man pages +# into hypertext, not as a general solution to the problem. If you +# try to use this, you'll be very much on your own. +# +# Copyright (c) 1995-1997 Roger E. Critchlow Jr +# +# The authors hereby grant permission to use, copy, modify, distribute, +# and license this software and its documentation for any purpose, provided +# that existing copyright notices are retained in all copies and that this +# notice is included verbatim in any distributions. No written agreement, +# license, or royalty fee is required for any of the authorized uses. +# Modifications to this software may be copyrighted by their authors +# and need not follow the licensing terms described here, provided that +# the new terms are clearly indicated on the first page of each file where +# they apply. +# +# IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +# FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +# ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +# DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. +# +# THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +# FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +# IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +# NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +# MODIFICATIONS. +# +# Revisions: +# May 15, 1995 - initial release +# May 16, 1995 - added a back to home link to toplevel table of +# contents. +# May 18, 1995 - broke toplevel table of contents into separate +# pages for each section, and broke long table of contents +# into a one page for each man page. +# Mar 10, 1996 - updated for tcl7.5b3/tk4.1b3 +# Apr 14, 1996 - incorporated command line parsing from Tom Tromey, +# -- thanks Tom. +# - updated for tcl7.5/tk4.1 final release. +# - converted to same copyright as the man pages. +# Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1 +# Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions. +# Oct 22, 1996 - major hacking on indentation code and elsewhere. +# Mar 4, 1997 - +# May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions +# - cleaned source for tclsh8.0 execution +# - renamed output files for windoze installation +# - added spaces to tables +# Oct 24, 1997 - moved from 8.0b1 to 8.0 release +# + +set Version "0.20" + +proc parse_command_line {} { + global argv Version + + # These variables determine where the man pages come from and where + # the converted pages go to. + global tcltkdir tkdir tcldir webdir + + # Set defaults based on original code. + set tcltkdir ../.. + set tkdir {} + set tcldir {} + set webdir ../html + + # Directory names for Tcl and Tk, in priority order. + set tclDirList {tcl8.3 tcl8.2 tcl8.1 tcl8.0 tcl} + set tkDirList {tk8.3 tk8.2 tk8.1 tk8.0 tk} + + # Handle arguments a la GNU: + # --version + # --help + # --srcdir=/path + # --htmldir=/path + + foreach option $argv { + switch -glob -- $option { + --version { + puts "tcltk-man-html $Version" + exit 0 + } + + --help { + puts "usage: tcltk-man-html \[OPTION\] ...\n" + puts " --help print this help, then exit" + puts " --version print version number, then exit" + puts " --srcdir=DIR find tcl and tk source below DIR" + puts " --htmldir=DIR put generated HTML in DIR" + exit 0 + } + + --srcdir=* { + # length of "--srcdir=" is 9. + set tcltkdir [string range $option 9 end] + } + + --htmldir=* { + # length of "--htmldir=" is 10 + set webdir [string range $option 10 end] + } + + default { + puts stderr "tcltk-man-html: unrecognized option -- `$option'" + exit 1 + } + } + } + + # Find Tcl. + foreach dir $tclDirList { + if {[file isdirectory $tcltkdir/$dir]} then { + set tcldir $dir + break + } + } + if {$tcldir == ""} then { + puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir" + exit 1 + } + + # Find Tk. + foreach dir $tkDirList { + if {[file isdirectory $tcltkdir/$dir]} then { + set tkdir $dir + break + } + } + if {$tkdir == ""} then { + puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" + exit 1 + } + + # the title for the man pages overall + global overall_title + set overall_title "[capitalize $tcldir]/[capitalize $tkdir] Manual" +} + +proc capitalize {string} { + return [string toupper $string 0] +} + +## +## +## +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 +## +proc unquote arg { + return [string map [list \" {}] $arg] +} + +proc parse-directive {line codename restname} { + upvar $codename code $restname rest + return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] +} + +proc process-text {text} { + global manual + # preprocess text + set text [string map [list \ + {\&} "\t" \ + {&} {&} \ + {\\} {\} \ + {\e} {\} \ + {\ } { } \ + {\|} { } \ + {\0} { } \ + {\%} {} \ + "\\\n" "\n" \ + \" {"} \ + {<} {<} \ + {>} {>} \ + {\(+-} {±} \ + {\fP} {\fR} \ + {\.} . \ + ] $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 "\\&\#92;\n" text; # backslashed newline + while {[regexp {\\} $text]} { + # C R + if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue + # B R + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue + # B I + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text {\1\2\\fI\3} text]} continue + # I R + if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text {\1\2\3} text]} continue + # I B + if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text {\1\2\\fB\3} text]} continue + # B B, I I, R R + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text {\1\\fB\2\3} ntext] + || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text {\1\\fI\2\3} ntext] + || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text {\1\\fR\2\3} ntext]} { + manerror "process-text: impotent font change: $text" + set text $ntext + continue + } + # unrecognized + manerror "process-text: uncaught backslash: $text" + 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 [expr {[string first . $line] == 0}] +} +proc split-directive {line opname restname} { + upvar $opname op $restname rest + set op [string range $line 0 2] + set rest [string trim [string range $line 3 end]] +} +proc next-op-is {op restname} { + global manual + upvar $restname rest + if {[more-text]} { + set text [lindex $manual(text) $manual(text-pointer)] + if {[string 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 {^@([_a-zA-Z0-9]+)$} $arg all name]} { + upvar $name var + set var $targ + incr nback + incr manual(text-pointer) + continue + } + if {[regexp {^(\.[a-zA-Z][a-zA-Z])@([_a-zA-Z0-9]+)$} $arg all op name]\ + && [string equal $op [lindex $targ 0]]} { + upvar $name var + set var [lrange $targ 1 end] + incr nback + incr manual(text-pointer) + continue + } + backup-text $nback + return 0 + } + return 1 +} +proc expand-next-text {n} { + global manual + return [join [lrange $manual(text) $manual(text-pointer) \ + [expr {$manual(text-pointer)+$n-1}]] \n\n] +} +## +## pass 2 output +## +proc man-puts {text} { + global manual + lappend manual(output-$manual(wing-file)-$manual(name)) $text +} + +## +## build hypertext links to tables of contents +## +proc long-toc {text} { + global manual + set here M[incr manual(section-toc-n)] + set there L[incr manual(long-toc-n)] + lappend manual(section-toc) "
$text" + return "$text" +} +proc option-toc {name class switch} { + global manual + if {[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) "$switch, $name, $class" + lappend manual(section-toc) "
$switch, $name, $class" + return "$switch" + } else { + error "option-toc in $manual(name) section $manual(section)" + } +} +proc std-option-toc {name} { + global manual + if {[info exists manual(standard-option-$name)]} { + lappend manual(section-toc)
$manual(standard-option-$name) + return $manual(standard-option-$name) + } + set here M[incr manual(section-toc-n)] + set there L[incr manual(long-toc-n)] + set other M$name + lappend manual(section-toc) "
$name" + return "$name" +} +## +## process the widget option section +## in widget and options man pages +## +proc output-widget-options {rest} { + global manual + man-puts
+ lappend manual(section-toc)
+ backup-text 1 + set para {} + while {[next-op-is .OP rest]} { + switch -exact [llength $rest] { + 3 { + set switch [lindex $rest 0] + set name [lindex $rest 1] + set class [lindex $rest 2] + } + 5 { + set switch [lrange $rest 0 2] + set name [lindex $rest 3] + set class [lindex $rest 4] + } + default { + fatal "bad .OP $rest" + } + } + if {![regexp {^(<.>)([-a-zA-Z0-9 ]+)()$} $switch all oswitch switch cswitch]} { + if {![regexp {^(<.>)([-a-zA-Z0-9 ]+) or ([-a-zA-Z0-9 ]+)()$} $switch all oswitch switch1 switch2 cswitch]} { + error "not Switch: $switch" + } else { + set switch "$switch1$cswitch or $oswitch$switch2" + } + } + if {![regexp {^(<.>)([a-zA-Z0-9]*)()$} $name all oname name cname]} { + error "not Name: $name" + } + if {![regexp {^(<.>)([a-zA-Z0-9]*)()$} $class all oclass class cclass]} { + error "not Class: $class" + } + man-puts "$para
Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch" + man-puts "
Database Name: $oname$name$cname" + man-puts "
Database Class: $oclass$class$cclass" + man-puts
[next-text] + set para

+ } + man-puts

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

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

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

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

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

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

+ } else { + # labelled list, make contents + if {[string compare $context ".SH"]} { + man-puts

+ } + man-puts

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

$rest
" + } else { + man-puts "

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

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

$rest

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

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

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

[long-toc $manual(section)]

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

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

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

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

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

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

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

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

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

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

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


$overall_title


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

$manual(wing-name)


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

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

Tcl/Tk Keywords


" + foreach a {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { + puts $keyfp "$a" + set afp [open $html/Keywords/$a.htm w] + puts $afp "Tcl/Tk Keywords - $a" + puts $afp "

Tcl/Tk Keywords - $a


" + foreach b {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { + puts $afp "$b" + } + puts $afp "


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

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

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

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