summaryrefslogtreecommitdiffstats
path: root/tools/tcl8.1-tk8.1-man-html.tcl
diff options
context:
space:
mode:
authorhobbs <hobbs>1999-12-21 23:59:28 (GMT)
committerhobbs <hobbs>1999-12-21 23:59:28 (GMT)
commit671c6e58fccb3a31aaaa79897e8c664ffb21fe82 (patch)
tree90375e3be8b6d06160b927c509f469b4b085fc89 /tools/tcl8.1-tk8.1-man-html.tcl
parent569c90e5035bd0fbfc62dfd81479cea91d46fa61 (diff)
downloadtcl-671c6e58fccb3a31aaaa79897e8c664ffb21fe82.zip
tcl-671c6e58fccb3a31aaaa79897e8c664ffb21fe82.tar.gz
tcl-671c6e58fccb3a31aaaa79897e8c664ffb21fe82.tar.bz2
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
Diffstat (limited to 'tools/tcl8.1-tk8.1-man-html.tcl')
-rw-r--r--tools/tcl8.1-tk8.1-man-html.tcl1663
1 files changed, 0 insertions, 1663 deletions
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,
-# <tromey@creche.cygnus.com> -- thanks Tom.
-# - updated for tcl7.5/tk4.1 final release.
-# - converted to same copyright as the man pages.
-# Sep 14, 1996 - made various modifications for tcl7.6b1/tk4.2b1
-# Oct 18, 1996 - added tcl7.6/tk4.2 to the list of distributions.
-# Oct 22, 1996 - major hacking on indentation code and elsewhere.
-# Mar 4, 1997 -
-# May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions
-# - cleaned source for tclsh8.0 execution
-# - renamed output files for windoze installation
-# - added spaces to tables
-# Oct 24, 1997 - moved from 8.0b1 to 8.0 release
-#
-
-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 {\&amp;} text;
- regsub -all {\\\\} $text {\&#92;} text; # reverse solidus, ie backslash
- regsub -all {\\ } $text {\&nbsp;} text; # non breaking space
- regsub -all {\\%} $text {} text; # don't break word following?
- regsub -all "\\\\\n" $text "\n" text; #
- regsub -all \" $text {\&quot;} text;
- regsub -all {<} $text {\&lt;} text;
- regsub -all {>} $text {\&gt;} text;
- regsub -all {\\o'o\^'} $text {\&ocirc;} 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 {\&nbsp;} text; # a very thin space
- regsub -all {\\e} $text {\&#92;} text; # reverse solidus, ie backslash
- regsub -all {\\\(\+-} $text {\&#177;} 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<TT>\2</TT>\3} text]} continue
- # B R
- if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text {\1<B>\2</B>\3} text]} continue
- # B I
- if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text {\1<B>\2</B>\\fI\3} text]} continue
- # I R
- if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text {\1<I>\2</I>\3} text]} continue
- # I B
- if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text {\1<I>\2</I>\\fB\3} text]} continue
- # B B, I I, R R
- if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text {\1\\fB\2\3} ntext]
- || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text {\1\\fI\2\3} ntext]
- || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text {\1\\fR\2\3} ntext]} {
- manerror "process-text: impotent font change: $text";
- set text $ntext;
- continue;
- }
- # unrecognized
- manerror "process-text: uncaught backslash: $text"
- 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) "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>";
- return "<A NAME=\"$here\">$text</A>";
-}
-proc option-toc {name class switch} {
- global manual;
- if {"$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) "<A HREF=\"$manual(name).htm#$here\">$switch, $name, $class</A>";
- lappend manual(section-toc) "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>";
- return "<A NAME=\"$here\">$switch</A>";
- } else {
- error "option-toc in $manual(name) section $manual(section)";
- }
-}
-proc std-option-toc {name} {
- global manual;
- if {[info exists manual(standard-option-$name)]} {
- lappend manual(section-toc) <DD>$manual(standard-option-$name);
- return $manual(standard-option-$name);
- }
- set here M[incr manual(section-toc-n)]
- set there L[incr manual(long-toc-n)];
- set other M$name;
- lappend manual(section-toc) "<DD><A HREF=\"options.htm#$other\">$name</A>";
- return "<A HREF=\"options.htm#$other\">$name</A>";
-}
-##
-## process the widget option section
-## in widget and options man pages
-##
-proc output-widget-options {rest} {
- global manual
- man-puts <DL>;
- lappend manual(section-toc) <DL>;
- backup-text 1;
- set para {}
- while {[next-op-is .OP rest]} {
- switch -exact [llength $rest] {
- 3 {
- 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<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch";
- man-puts "<DT>Database Name: $oname$name$cname";
- man-puts "<DT>Database Class: $oclass$class$cclass";
- man-puts <DD>[next-text];
- set para <P>
- }
- man-puts </DL>;
- lappend manual(section-toc) </DL>;
-}
-
-##
-## process .RS lists
-##
-proc output-RS-list {} {
- global manual;
- if {[next-op-is .IP rest]} {
- output-IP-list .RS .IP $rest;
- if {[match-text .RE .sp .RS @rest .IP @rest2]} {
- man-puts <P>$rest
- output-IP-list .RS .IP $rest2
- }
- if {[match-text .RE .sp .RS @rest .RE]} {
- man-puts <P>$rest
- return;
- }
- if {[next-op-is .RE rest]} {
- return;
- }
- }
- man-puts <DL><P><DD>;
- 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 </DL>;
-}
-
-##
-## 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 <DL><P><DD>
- while {[more-text]} {
- set line [next-text];
- if {[is-a-directive $line]} {
- split-directive $line code rest
- if {"$code" == {.IP} && "$rest" == {}} {
- man-puts "<P>";
- continue;
- }
- if {[lsearch {.br .DS .RS} $code] >= 0} {
- output-directive $line;
- } else {
- backup-text 1;
- break;
- }
- } else {
- man-puts $line;
- }
- }
- man-puts </DL>;
- } else {
- # labelled list, make contents
- if {"$context" != {.SH}} {
- man-puts <P>;
- }
- man-puts <DL>
- lappend manual(section-toc) <DL>;
- 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 "<P><DT>$rest<DD>";
- } else {
- man-puts "<P><DT>[long-toc $rest]<DD>";
- }
- if {"$manual(name):$manual(section)" == {selection:DESCRIPTION}} {
- if {[match-text .RE @rest .RS .RS]} {
- man-puts <DT>[long-toc $rest]<DD>;
- }
- }
- }
- .sp -
- .br -
- .DS -
- .CS {
- output-directive $line;
- }
- .RS {
- if {[match-text .RS]} {
- output-directive $line;
- incr accept_RE 1;
- } elseif {[match-text .CS]} {
- output-directive .CS
- incr accept_RE 1;
- } elseif {[match-text .PP]} {
- output-directive .PP
- incr accept_RE 1;
- } elseif {[match-text .DS]} {
- output-directive .DS
- incr accept_RE 1;
- } else {
- output-directive $line;
- }
- }
- .PP {
- if {[match-text @rest1 .br @rest2 .RS]} {
- # yet another nroff kludge as above
- man-puts "<P><DT>[long-toc $rest1]"
- man-puts "<DT>[long-toc $rest2]<DD>"
- incr accept_RE 1;
- } elseif {[match-text @rest .RE]} {
- # gad, this is getting ridiculous
- if { ! $accept_RE} {
- man-puts "</DL><P>$rest<DL>"
- backup-text 1
- break;
- } else {
- man-puts "<P>$rest"
- incr accept_RE -1
- }
- } elseif {$accept_RE} {
- output-directive $line
- } else {
- backup-text 1
- break;
- }
- }
- .RE {
- if { ! $accept_RE} {
- backup-text 1;
- break;
- }
- incr accept_RE -1
- }
- default {
- backup-text 1;
- break;
- }
- }
- } else {
- man-puts $line;
- }
- }
- man-puts <P></DL>;
- lappend manual(section-toc) </DL>;
- if {$accept_RE} {
- manerror "missing .RE in output-IP-list"
- }
- }
-}
-##
-## handle the NAME section lines
-## there's only one line in the NAME section,
-## consisting of a comma separated list of names,
-## followed by a hyphen and a short description.
-##
-proc output-name {line} {
- global manual;
- # split name line into pieces
- regexp {^([^-]+) - (.*)$} $line all head tail;
- # output line to manual page untouched
- man-puts $line
- # output line to long table of contents
- lappend manual(section-toc) <DL><DD>$line</DL>
- # separate out the names for future reference
- foreach name [split $head ,] {
- set name [string trim $name];
- if {[llength $name] > 1} {
- manerror "name has a space: {$name}\nfrom: $line";
- }
- lappend manual(wing-toc) $name;
- lappend manual(name-$name) $manual(wing-file)/$manual(name);
- }
-}
-##
-## build a cross-reference link if appropriate
-##
-proc cross-reference {ref} {
- global manual;
- if {[string match Tcl_* $ref]} {
- set lref $ref;
- } elseif {[string match Tk_* $ref]} {
- set lref $ref;
- } elseif {"$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 "<A HREF=\"../$manual(name-$name).htm\">$ref</A>";
- }
- }
- if {[lsearch {stdin stdout stderr end} $lref] >= 0} {
- # no good place to send these
- # tcl tokens?
- # also end
- }
- 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 "<A HREF=\"../$tcl_ref.htm\">$ref</A>";
- }
- if {$tk_i >= 0 && "$manual(wing-file)" == {TkCmd} || "$manual(wing-file)" == {TkLib}} {
- return "<A HREF=\"../$tk_ref.htm\">$ref</A>";
- }
- if {"$lref" == {exit} && "$manual(tail)" == {tclsh.1} && $tcl_i >= 0} {
- return "<A HREF=\"../$tcl_ref.htm\">$ref</A>";
- }
- puts stderr "multiple cross reference to $ref in $manual(name-$lref) from $manual(wing-file)/$manual(tail)";
- return $ref;
- }
- ##
- ## 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 "<A HREF=\"../$manual(name-$lref).htm\">$ref</A>";
-}
-##
-## reference generation errors
-##
-proc reference-error {msg text} {
- global manual;
- puts stderr "$manual(tail): $msg: {$text}";
- return $text;
-}
-##
-## insert as many cross references into this text string as are appropriate
-##
-proc insert-cross-references {text} {
- global manual;
- ##
- ## we identify cross references by:
- ## ``quotation''
- ## <B>emboldening</B>
- ## Tcl_ prefix
- ## Tk_ prefix
- ## [a-zA-Z0-9]+ manual entry
- ## and we avoid messing with already anchored text
- ##
- ##
- ## find where each item lives
- ##
- array set offset [list \
- anchor [string first {<A } $text] \
- end-anchor [string first {</A>} $text] \
- quote [string first {``} $text] \
- end-quote [string first {''} $text] \
- bold [string first {<B>} $text] \
- end-bold [string first {</B>} $text] \
- tcl [string first {Tcl_} $text] \
- tk [string first {Tk_} $text] \
- Tcl1 [string first {Tcl manual entry} $text] \
- Tcl2 [string first {Tcl overview manual entry} $text] \
- ];
- ##
- ## accumulate a list
- ##
- foreach name [array names offset] {
- if {$offset($name) >= 0} {
- set invert($offset($name)) $name;
- lappend offsets $offset($name);
- }
- }
- ##
- ## if nothing, then we're done.
- ##
- if { ! [info exists offsets]} {
- return $text;
- }
- ##
- ## sort the offsets
- ##
- set offsets [lsort -integer $offsets];
- ##
- ## see which we want to use
- ##
- switch -exact $invert([lindex $offsets 0]) {
- anchor {
- if {$offset(end-anchor) < 0} { return [reference-error {Missing end anchor} $text]; }
- set head [string range $text 0 $offset(end-anchor)];
- set tail [string range $text [expr $offset(end-anchor)+1] end];
- return $head[insert-cross-references $tail]
- }
- quote {
- if {$offset(end-quote) < 0} { return [reference-error {Missing end quote} $text]; }
- if {"$invert([lindex $offsets 1])" == {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<B>[cross-reference $body]</B>[insert-cross-references $tail];
- }
- anchor {
- set head [string range $text 0 [expr $offset(end-bold)+3]]
- set tail [string range $text [expr $offset(end-bold)+4] end];
- return $head[insert-cross-references $tail];
- }
- }
- return [reference-error {Uncaught bold case} $text];
- }
- tk {
- set head [string range $text 0 [expr $offset(tk)-1]]
- set tail [string range $text $offset(tk) end];
- if { ! [regexp {^(Tk_[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 <HR>;
- }
- .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 "<H3>[long-toc $manual(section)]</H3>";
- # some sections can simply free wheel their way through the text
- # some sections can be processed in their own loops
- switch -exact $manual(section) {
- NAME {
- if {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} {
- # these manual pages have two NAME sections
- if {[info exists manual($manual(tail)-NAME)]} {
- return;
- }
- set manual($manual(tail)-NAME) 1
- }
- set names {}
- while {1} {
- set line [next-text];
- if {[is-a-directive $line]} {
- backup-text 1;
- output-name [join $names { }]
- return;
- } else {
- lappend names [string trim $line]
- }
- }
- }
- SYNOPSIS {
- lappend manual(section-toc) <DL>;
- while {1} {
- if {[next-op-is .nf rest]
- || [next-op-is .br rest]
- || [next-op-is .fi rest]} {
- continue;
- }
- if {[next-op-is .SH rest]
- || [next-op-is .BE rest]
- || [next-op-is .SO rest]} {
- backup-text 1;
- break;
- }
- if {[next-op-is .sp rest]} {
- #man-puts <P>;
- continue;
- }
- set more [next-text];
- if {[is-a-directive $more]} {
- manerror "in SYNOPSIS found $more";
- backup-text 1;
- break;
- } else {
- foreach more [split $more \n] {
- man-puts $more<BR>;
- if {[lsearch {TclLib TkLib} $manual(wing-file)] < 0} {
- lappend manual(section-toc) <DD>$more;
- }
- }
- }
- }
- lappend manual(section-toc) </DL>;
- return;
- }
- {SEE ALSO} {
- while {[more-text]} {
- if {[next-op-is .SH rest]} {
- backup-text 1;
- return;
- }
- set more [next-text];
- if {[is-a-directive $more]} {
- manerror "$more";
- backup-text 1;
- return;
- }
- set nmore {};
- foreach cr [split $more ,] {
- set cr [string trim $cr];
- if { ! [regexp {^<B>.*</B>$} $cr]} {
- set cr <B>$cr</B>;
- }
- if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} {
- set cr <B>$name</B>
- }
- lappend nmore $cr;
- }
- man-puts [join $nmore {, }];
- }
- return;
- }
- KEYWORDS {
- while {[more-text]} {
- if {[next-op-is .SH rest]} {
- backup-text 1;
- return;
- }
- set more [next-text];
- if {[is-a-directive $more]} {
- manerror "$more";
- backup-text 1;
- return;
- }
- set keys {}
- foreach key [split $more ,] {
- set key [string trim $key]
- lappend manual(keyword-$key) [list $manual(name) $manual(wing-file)/$manual(name).htm];
- set initial [string toupper [string index $key 0]]
- lappend keys "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>"
- }
- man-puts [join $keys {, }]
- }
- return;
- }
- }
- if {[next-op-is .IP rest]} {
- output-IP-list .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 <DL>;
- lappend manual(section-toc) <DL>;
- foreach option [lsort $opts] {
- man-puts "<DT><B>[std-option-toc $option]</B>";
- }
- man-puts </DL>;
- lappend manual(section-toc) </DL>;
- } else {
- manerror "unexpected .SO format:\n[expand-next-text 2]";
- }
- }
- .OP {
- output-widget-options $rest;
- return;
- }
- .IP {
- output-IP-list .IP .IP $rest;
- return;
- }
- .PP {
- man-puts <P>;
- }
- .RS {
- output-RS-list;
- return;
- }
- .RE {
- manerror "unexpected .RE";
- return;
- }
- .br {
- man-puts <BR>;
- return;
- }
- .DE {
- manerror "unexpected .DE";
- return;
- }
- .DS {
- if {[next-op-is .ta rest]} {
- ;
- }
- if {[match-text @stuff .DE]} {
- man-puts <PRE>$stuff</PRE>;
- } elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
- man-puts "<PRE>[lindex $ul1 1][lindex $ul2 1]\n$stuff</PRE>";
- } else {
- manerror "unexpected .DS format:\n[expand-next-text 2]";
- }
- return;
- }
- .CS {
- if {[next-op-is .ta rest]} {
- ;
- }
- if {[match-text @stuff .CE]} {
- man-puts <PRE>$stuff</PRE>;
- } else {
- manerror "unexpected .CS format:\n[expand-next-text 2]";
- }
- return;
- }
- .CE {
- manerror "unexpected .CE";
- return;
- }
- .sp {
- man-puts <P>;
- }
- .ta {
- # these are tab stop settings for short tables
- switch -exact $manual(name):$manual(section) {
- {bind:MODIFIERS} -
- {bind:EVENT TYPES} -
- {bind:BINDING SCRIPTS AND SUBSTITUTIONS} -
- {expr:OPERANDS} -
- {expr:MATH FUNCTIONS} -
- {history:DESCRIPTION} -
- {history:HISTORY REVISION} -
- {switch:DESCRIPTION} -
- {upvar:DESCRIPTION} {
- return; # fix.me
- }
- default {
- manerror "ignoring $line";
- }
- }
- }
- .nf {
- if {[match-text @more .fi]} {
- foreach more [split $more \n] {
- man-puts $more<BR>;
- }
- } elseif {[match-text .RS @more .RE .fi]} {
- man-puts <DL><DD>;
- foreach more [split $more \n] {
- man-puts $more<BR>;
- }
- man-puts </DL>;
- } elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
- man-puts <DL><DD>;
- foreach more [split $more \n] {
- man-puts $more<BR>;
- }
- man-puts <DL><DD>;
- foreach more2 [split $more2 \n] {
- man-puts $more2<BR>;
- }
- man-puts </DL></DL>;
- } elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
- man-puts <DL><DD>;
- foreach more [split $more \n] {
- man-puts $more<BR>;
- }
- man-puts <DL><DD>;
- foreach more2 [split $more2 \n] {
- man-puts $more2<BR>;
- }
- man-puts </DL><DD>;
- foreach more3 [split $more3 \n] {
- man-puts $more3<BR>;
- }
- man-puts </DL>;
- } elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
- man-puts <P><DL><DD>;
- foreach more [split $more \n] {
- man-puts $more<BR>;
- }
- man-puts <DL><DD>;
- foreach more2 [split $more2 \n] {
- man-puts $more2<BR>;
- }
- man-puts </DL></DL><P>;
- } elseif {[match-text .RS .sp @more .sp .RE .fi]} {
- man-puts <P><DL><DD>;
- foreach more [split $more \n] {
- man-puts $more<BR>;
- }
- man-puts </DL><P>;
- } else {
- manerror "ignoring $line";
- }
- }
- .fi {
- manerror "ignoring $line";
- }
- .na -
- .ad -
- .UL -
- .ne {
- manerror "ignoring $line";
- }
- default {
- manerror "unrecognized format directive: $line";
- }
- }
-}
-##
-## merge copyright listings
-##
-proc merge-copyrights {l1 l2} {
- 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) "<HTML><HEAD><TITLE>$overall_title</TITLE></HEAD>"
- puts $manual(short-toc-fp) "<BODY><HR><H3>$overall_title</H3><HR><DL>";
- set manual(merge-copyrights) {}
- foreach arg $args {
- set manual(wing-glob) [lindex $arg 0];
- set manual(wing-name) [lindex $arg 1];
- set manual(wing-file) [lindex $arg 2];
- set manual(wing-description) [lindex $arg 3];
- set manual(wing-copyrights) {};
- makedirhier $html/$manual(wing-file);
- set manual(wing-toc-fp) [open $html/$manual(wing-file)/contents.htm w];
- # whistle
- puts stderr "scanning section $manual(wing-name)";
- # put the entry for this section into the short table of contents
- puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/contents.htm\">$manual(wing-name)</A><DD>$manual(wing-description)";
- # initialize the wing table of contents
- puts $manual(wing-toc-fp) "<HTML><HEAD><TITLE>$manual(wing-name) Manual</TITLE></HEAD>"
- puts $manual(wing-toc-fp) "<BODY><HR><H3>$manual(wing-name)</H3><HR>";
- # initialize the short table of contents for this section
- set manual(wing-toc) {};
- # initialize the man directory for this section
- makedirhier $html/$manual(wing-file);
- # initialize the long table of contents for this section
- set manual(long-toc-n) 1;
- # get the manual pages for this section
- set manual(pages) [lsort [glob $manual(wing-glob)]];
- if {[lsearch -glob $manual(pages) */options.n] >= 0} {
- set n [lsearch $manual(pages) */options.n];
- set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]";
- }
- # set manual(pages) [lrange $manual(pages) 0 5];
- foreach manual(page) $manual(pages) {
- # whistle
- puts stderr "scanning page $manual(page)";
- set manual(tail) [file tail $manual(page)];
- set manual(name) [file root $manual(tail)];
- set manual(section) {};
- if {[lsearch {case pack-old menubar} $manual(name)] >= 0} {
- # obsolete
- manerror "discarding $manual(name)";
- continue;
- }
- set manual(infp) [open "$manual(page)"];
- set manual(text) {};
- set manual(partial-text) {};
- foreach p {.RS .DS .CS .SO} {
- set manual($p) 0;
- }
- set manual(stack) {};
- set manual(section) {};
- set manual(section-toc) {};
- set manual(section-toc-n) 1;
- set manual(copyrights) {};
- lappend manual(all-pages) $manual(wing-file)/$manual(tail);
- manreport 100 "$manual(name)";
- while {[gets $manual(infp) line] >= 0} {
- manreport 100 $line;
- if {[regexp {^[`'][/\\]} $line]} {
- if {[regexp {Copyright \(c\).*$} $line copyright]} {
- lappend manual(copyrights) $copyright;
- }
- # comment
- continue;
- }
- if {"$line" == {'}} {
- # comment
- continue;
- }
- if {[parse-directive $line code rest]} {
- switch -exact $code {
- .ad -
- .na -
- .so -
- .ne -
- .AS -
- .VE -
- .VS -
- . {
- # ignore
- continue;
- }
- }
- if {"$manual(partial-text)" != {}} {
- lappend manual(text) [process-text $manual(partial-text)];
- set manual(partial-text) {};
- }
- switch -exact $code {
- .SH {
- 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 <HR><PRE>;
- foreach copyright $manual(copyrights) {
- man-puts "<A HREF=\"../copyright.htm\">Copyright</A> &#169; [lrange $copyright 2 end]";
- }
- man-puts "<A HREF=\"../copyright.htm\">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.</PRE>";
- set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)];
- } elseif {[next-op-is .TH rest]} {
- set manual($manual(name)-title) "[lrange $rest 4 end] - [lindex $rest 0] manual page";
- while {[more-text]} {
- set line [next-text];
- if {[is-a-directive $line]} {
- output-directive $line;
- } else {
- man-puts $line;
- }
- }
- man-puts <HR><PRE>;
- foreach copyright $manual(copyrights) {
- man-puts "<A HREF=\"../copyright.htm\">Copyright</A> &#169; [lrange $copyright 2 end]";
- }
- man-puts "<A HREF=\"../copyright.htm\">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.</PRE>";
- set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)];
- } else {
- manerror "no .HS or .TH record found";
- }
- #
- # make the long table of contents for this page
- #
- set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL><HR>];
- }
-
- #
- # make the wing table of contents for the section
- #
- set width 0;
- foreach name $manual(wing-toc) {
- if {[string length $name] > $width} {
- set width [string length $name];
- }
- }
- set perline [expr 120 / $width];
- set nrows [expr ([llength $manual(wing-toc)]+$perline)/$perline]
- set n 0;
- catch {unset rows}
- foreach name [lsort $manual(wing-toc)] {
- set tail $manual(name-$name);
- if {[llength $tail] > 1} {
- manerror "$name is defined in more than one file: $tail";
- set tail [lindex $tail [expr [llength $tail]-1]];
- }
- set tail [file tail $tail];
- append rows([expr $n%$nrows]) "<td> <a href=\"$tail.htm\">$name</a>"
- incr n;
- }
- puts $manual(wing-toc-fp) <table>;
- foreach row [lsort -integer [array names rows]] {
- puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
- }
- puts $manual(wing-toc-fp) </table>;
-
- #
- # insert wing copyrights
- #
- puts $manual(wing-toc-fp) "<HR><PRE>"
- foreach copyright $manual(wing-copyrights) {
- puts $manual(wing-toc-fp) "<A HREF=\"../copyright.htm\">Copyright</A> &#169; [lrange $copyright 2 end]";
- }
- puts $manual(wing-toc-fp) "<A HREF=\"../copyright.htm\">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.";
- puts $manual(wing-toc-fp) "</PRE></BODY></HTML>";
- close $manual(wing-toc-fp);
- set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)];
- }
-
- ##
- ## build the keyword index.
- ##
- proc strcasecmp {a b} { return [string compare [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) {<DT><A HREF="Keywords/contents.htm">Keywords</A><DD>The keywords from the Tcl/Tk man pages.};
- set keyfp [open $html/Keywords/contents.htm w];
- puts $keyfp "<HTML><HEAD><TITLE>Tcl/Tk Keywords</TITLE></HEAD>"
- puts $keyfp "<BODY><HR><H3>Tcl/Tk Keywords</H3><HR><H2>"
- foreach a {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
- puts $keyfp "<A HREF=\"$a.htm\">$a</A>"
- set afp [open $html/Keywords/$a.htm w];
- puts $afp "<HTML><HEAD><TITLE>Tcl/Tk Keywords - $a</TITLE></HEAD>"
- puts $afp "<BODY><HR><H3>Tcl/Tk Keywords - $a</H3><HR><H2>"
- foreach b {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
- puts $afp "<A HREF=\"$b.htm\">$b</A>"
- }
- puts $afp "</H2><HR><DL>"
- foreach k $keys {
- if {[regexp -nocase -- "^keyword-$a" $k]} {
- set k [string range $k 8 end]
- puts $afp "<DT><A NAME=\"$k\">$k</A><DD>"
- set refs {}
- foreach man $manual(keyword-$k) {
- set name [lindex $man 0];
- set file [lindex $man 1]
- lappend refs "<A HREF=\"../$file\">$name</A>";
- }
- puts $afp [join $refs {, }];
- }
- }
- puts $afp "</DL><HR><PRE>"
- # insert merged copyrights
- foreach copyright $manual(merge-copyrights) {
- puts $afp "<A HREF=\"copyright.htm\">Copyright</A> &#169; [lrange $copyright 2 end]";
- }
- puts $afp "<A HREF=\"copyright.htm\">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.";
- puts $afp "</PRE></BODY></HTML>"
- close $afp
- }
- puts $keyfp "</H2><HR><PRE>"
-
- # insert merged copyrights
- foreach copyright $manual(merge-copyrights) {
- puts $keyfp "<A HREF=\"copyright.htm\">Copyright</A> &#169; [lrange $copyright 2 end]";
- }
- puts $keyfp "<A HREF=\"copyright.htm\">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.";
- puts $keyfp </PRE><HR></BODY></HTML>
- close $keyfp;
-
- ##
- ## finish off short table of contents
- ##
- puts $manual(short-toc-fp) {<DT><A HREF="http://www.elf.org">Source</A><DD>More information about these man pages.}
- puts $manual(short-toc-fp) "</DL><HR><PRE>";
- # insert merged copyrights
- foreach copyright $manual(merge-copyrights) {
- puts $manual(short-toc-fp) "<A HREF=\"copyright.htm\">Copyright</A> &#169; [lrange $copyright 2 end]";
- }
- puts $manual(short-toc-fp) "<A HREF=\"copyright.htm\">Copyright</A> &#169; 1995-1997 Roger E. Critchlow Jr.";
- puts $manual(short-toc-fp) "</PRE></BODY></HTML>";
- close $manual(short-toc-fp);
-
- ##
- ## output man pages
- ##
- unset manual(section);
- foreach path $manual(all-pages) {
- set manual(wing-file) [file dirname $path];
- set manual(tail) [file tail $path];
- set manual(name) [file root $manual(tail)];
- set text $manual(output-$manual(wing-file)-$manual(name));
- set ntext 0;
- foreach item $text {
- incr ntext [llength [split $item \n]];
- incr ntext;
- }
- set toc $manual(toc-$manual(wing-file)-$manual(name));
- set ntoc 0;
- foreach item $toc {
- incr ntoc [llength [split $item \n]];
- incr ntoc;
- }
- puts stderr "rescanning page $manual(name) $ntoc/$ntext";
- set manual(outfp) [open $html/$manual(wing-file)/$manual(name).htm w];
- puts $manual(outfp) "<HTML><HEAD><TITLE>$manual($manual(name)-title)</TITLE></HEAD><BODY>"
- if {$ntext > 60 && $ntoc > 32
- || [lsearch {Hash LinkVar SetVar TraceVar
- ConfigWidg CrtImgType CrtItemType CrtPhImgFmt DoOneEvent GetBitmap GetColor GetCursor GetJustify GetPixels GetVisual
- ParseArgv QueueEvent} $manual(tail)] >= 0} {
- foreach item $toc {
- puts $manual(outfp) $item;
- }
- }
- foreach item $text {
- puts $manual(outfp) [insert-cross-references $item];
- }
- puts $manual(outfp) </BODY></HTML>;
- close $manual(outfp);
- }
- return {};
-}
-
-set usercmddesc {The interpreters which implement Tcl and Tk.}
-set tclcmddesc {The commands which the <B>tclsh</B> interpreter implements.}
-set tkcmddesc {The additional commands which the <B>wish</B> interpreter implements.}
-set tcllibdesc {The C functions which a Tcl extended C program may use.}
-set tklibdesc {The additional C functions which a Tk extended C program may use.}
-
-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;
- }
-}
-