tcltk-man2html.tcl

tcl是工具命令语言

#!/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,
#		  <[e-mail]> -- 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.30"

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.4 tcl8.3 tcl8.2 tcl8.1 tcl8.0 tcl}
    set tkDirList {tk8.4 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" \
	    {&}		{&amp;} \
	    {\\}	{&#92;} \
	    {\e}	{&#92;} \
	    {\ }	{&nbsp;} \
	    {\|}	{&nbsp;} \
	    {\0}	{ } \
	    {\%}	{} \
	    "\\\n"	"\n" \
	    \"		{&quot;} \
	    {<}		{&lt;} \
	    {>}		{&gt;} \
	    {\(+-}	{&#177;} \
	    {\fP}	{\fR} \
	    {\.}	. \
	    ] $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 "\\\\\n" $text "\\&#92;\n" text; # backslashed newline
    while {[string first "\\" $text] >= 0} {
	# C R
	if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
		{\1<TT>\2</TT>\3} text]} continue
	# B R
	if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
		{\1<B>\2</B>\3} text]} continue
	# B I
	if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
		{\1<B>\2</B>\\fI\3} text]} continue
	# I R
	if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
		{\1<I>\2</I>\3} text]} continue
	# I B
	if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
		{\1<I>\2</I>\\fB\3} text]} continue
	# B B, I I, R R
	if {[regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
		{\1\\fB\2\3} ntext]
	    || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \
		    {\1\\fI\2\3} ntext]
	    || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \
		    {\1\\fR\2\3} ntext]} {
	    manerror "process-text: impotent font change: $text"
	    set text $ntext
	    continue
	}
	# unrecognized
	manerror "process-text: uncaught backslash: $text"
	set text [string map [list "\\" "#92;"] $text]
    }
    return $text
}
##
## pass 2 text input and matching
##
proc open-text {} {
    global manual
    set manual(text-length) [llength $manual(text)]
    set manual(text-pointer) 0
}
proc more-text {} {
    global manual
    return [expr {$manual(text-pointer) < $manual(text-length)}]
}
proc next-text {} {
    global manual
    if {[more-text]} {
	set text [lindex $manual(text) $manual(text-pointer)]
	incr manual(text-pointer)
	return $text
    }
    manerror "read past end of text"
    error "fatal"
}
proc is-a-directive {line} {
    return [string match .* $line]
}
proc split-directive {line opname restname} {
    upvar $opname op $restname rest
    set op [string range $line 0 2]
    set rest [string trim [string range $line 3 end]]
}
proc next-op-is {op restname} {
    global manual
    upvar $restname rest
    if {[more-text]} {
	set text [lindex $manual(text) $manual(text-pointer)]
	if {[string equal -length 3 $text $op]} {
	    set rest [string range $text 4 end]
	    incr manual(text-pointer)
	    return 1
	}
    }
    return 0
}
proc backup-text {n} {
    global manual
    if {$manual(text-pointer)-$n >= 0} {
	incr manual(text-pointer) -$n
    }
}
proc match-text args {
    global manual
    set nargs [llength $args]
    if {$manual(text-pointer) + $nargs > $manual(text-length)} {
	return 0
    }
    set nback 0
    foreach arg $args {
	if {![more-text]} {
	    backup-text $nback
	    return 0
	}
	set arg [string trim $arg]
	set targ [string trim [lindex $manual(text) $manual(text-pointer)]]
	if {[string equal $arg $targ]} {
	    incr nback
	    incr manual(text-pointer)
	    continue
	}
	if {[regexp {^@(\w+)$} $arg all name]} {
	    upvar $name var
	    set var $targ
	    incr nback
	    incr manual(text-pointer)
	    continue
	}
	if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\
		&& [string equal $op [lindex $targ 0]]} {
	    upvar $name var
	    set var [lrange $targ 1 end]
	    incr nback
	    incr manual(text-pointer)
	    continue
	}
	backup-text $nback
	return 0
    }
    return 1
}
proc expand-next-text {n} {
    global manual
    return [join [lrange $manual(text) $manual(text-pointer) \
	    [expr {$manual(text-pointer)+$n-1}]] \n\n]
}
##
## pass 2 output
##
proc man-puts {text} {
    global manual
    lappend manual(output-$manual(wing-file)-$manual(name)) $text
}

##
## build hypertext links to tables of contents
##
proc long-toc {text} {
    global manual
    set here M[incr manual(section-toc-n)]
    set there L[incr manual(long-toc-n)]
    lappend manual(section-toc) \
	    "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
    return "<A NAME=\"$here\">$text</A>"
}
proc option-toc {name class switch} {
    global manual
    if {[string equal $manual(section) "WIDGET-SPECIFIC OPTIONS"]} {
	# link the defined option into the long table of contents
	set link [long-toc "$switch, $name, $class"]
	regsub -- "$switch, $name, $class" $link "$switch" link
	return $link
    } elseif {[string equal $manual(name):$manual(section) \
	    "options:DESCRIPTION"]} {
	# link the defined standard option to the long table of
	# contents and make a target for the standard option references
	# from other man pages.
	set first [lindex $switch 0]
	set here M$first
	set there L[incr manual(long-toc-n)]
	set manual(standard-option-$first) "<A HREF=\"$manual(name).htm#$here\">$switch, $name, $class</A>"
	lappend manual(section-toc) "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>"
	return "<A NAME=\"$here\">$switch</A>"
    } else {
	error "option-toc in $manual(name) section $manual(section)"
    }
}
proc std-option-toc {name} {
    global manual
    if {[info exists manual(standard-option-$name)]} {
	lappend manual(section-toc) <DD>$manual(standard-option-$name)
	return $manual(standard-option-$name)
    }
    set here M[incr manual(section-toc-n)]
    set there L[incr manual(long-toc-n)]
    set other M$name
    lappend manual(section-toc) "<DD><A HREF=\"options.htm#$other\">$name</A>"
    return "<A HREF=\"options.htm#$other\">$name</A>"
}
##
## process the widget option section
## in widget and options man pages
##
proc output-widget-options {rest} {
    global manual
    man-puts <DL>
    lappend manual(section-toc) <DL>
    backup-text 1
    set para {}
    while {[next-op-is .OP rest]} {
	switch -exact [llength $rest] {
	    3 { foreach {switch name class} $rest { break } }
	    5 {
		set switch [lrange $rest 0 2]
		set name [lindex $rest 3]
		set class [lindex $rest 4]
	    }