man2html2.tcl

tcl是工具命令语言

		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]
	    }
	    default {
		puts stderr "Unknown sequence: \\$c"
		set text [string range $text [expr $index+2] end]
	    }
	}
    }
}



# dash --
#
# This procedure is invoked to handle dash characters ("\-" in
# troff).  It outputs a special dash character.
#
# Arguments:
# None.

proc dash {} {
    global textState charCnt
    if {$textState == "NAME"} {
    	set textState 0
    }
    incr charCnt
    text "-"
}


# tab --
#
# This procedure is invoked to handle tabs in the troff input.
# Right now it does nothing.
#
# Arguments:
# None.

proc tab {} {
    global inPRE charCnt tabString
#	? charCnt
    if {$inPRE == 1} {
	set pos [expr $charCnt % [string length $tabString] ]
	set spaces [string first "1" [string range $tabString $pos end] ]
	text [format "%*s" [incr spaces] " "]
    } else {
#	puts "tab: found tab outside of <PRE> block"
    }
}


# setTabs --
#
# This procedure handles the ".ta" macro, which sets tab stops.
#
# Arguments:
# tabList -	List of tab stops, each consisting of a number
#			followed by "i" (inch) or "c" (cm).

proc setTabs {tabList} {
    global file breakPending tabString

#	puts "setTabs: --$tabList--"
    set last 0
    set tabString {}
    set charsPerInch 14.
    set numTabs [llength $tabList]
    foreach arg $tabList {
	if {[scan $arg "%f%s" distance units] != 2} {
	    puts stderr "bad distance \"$arg\""
	    return 0
    	}
	switch -- $units {
	    c	{
		set distance [expr $distance * $charsPerInch / 2.54 ]
	    }
	    i	{
		set distance [expr $distance * $charsPerInch]
	    }
	    default {
		puts stderr "bad units in distance \"$arg\""
		continue
	    }
    	}
#		? distance
    	lappend tabString [format "%*s1" [expr round($distance-$last-1)] " "]
    	set last $distance
    }
    set tabString [join $tabString {}]
#	puts "setTabs: --$tabString--"
}



# lineBreak --
#
# Generates a line break in the HTML output.
#
# Arguments:
# None.

proc lineBreak {} {
    global file inPRE
    puts $file "<BR>"
}



# newline --
#
# This procedure is invoked to handle newlines in the troff input.
# It outputs either a space character or a newline character, depending
# on fill mode.
#
# Arguments:
# None.

proc newline {} {
    global noFillCount file inDT inPRE charCnt

    if {$inDT != {} } {
    	puts $file "\n$inDT"
    	set inDT {}
    } elseif {$noFillCount == 0 || $inPRE == 1} {
	puts $file {}
    } else {
	lineBreak
	incr noFillCount -1
    }
    set charCnt 0
}



# char --
#
# This procedure is called to handle a special character.
#
# Arguments:
# name -		Special character named in troff \x or \(xx construct.

proc char name {
    global file charCnt

    incr charCnt
#	puts "char: $name"
    switch -exact $name {
	\\0 {					;#  \0
	    puts -nonewline $file " "
	}
	\\\\ {					;#  \
	    puts -nonewline $file "\\"
	}
	\\(+- { 				;#  +/-
	    puts -nonewline $file "&#177;"
	}
	\\% {}					;#  \%
	\\| {					;#  \|
	}
	default {
	    puts stderr "Unknown character: $name"
	}
    }
}


# macro2 --
#
# This procedure handles macros that are invoked with a leading "'"
# character instead of space.  Right now it just generates an
# error diagnostic.
#
# Arguments:
# name -		The name of the macro (without the ".").
# args -		Any additional arguments to the macro.

proc macro2 {name args} {
    puts stderr "Unknown macro: '$name [join $args " "]"
}



# SHmacro --
#
# Subsection head; handles the .SH macro.
#
# Arguments:
# name -		Section name.

proc SHmacro argList {
    global file noFillCount textState charCnt

    set args [join $argList " "]
    if {[llength $argList] < 1} {
	puts stderr "Bad .SH macro: .$name $args"
    }

    set noFillCount 0
    nest reset

    puts -nonewline $file "<H3>"
    text $args
    puts $file "</H3>"

#	? args textState

    # control what the text proc does with text
    
    switch $args {
	NAME {set textState NAME}
	DESCRIPTION {set textState INSERT}
	INTRODUCTION {set textState INSERT}
	"WIDGET-SPECIFIC OPTIONS" {set textState INSERT}
	"SEE ALSO" {set textState SEE}
	KEYWORDS {set textState 0}
    }
    set charCnt 0
}



# IPmacro --
#
# This procedure is invoked to handle ".IP" macros, which may take any
# of the following forms:
#
# .IP [1]			Translate to a "1Step" paragraph.
# .IP [x] (x > 1)	Translate to a "Step" paragraph.
# .IP				Translate to a "Bullet" paragraph.
# .IP text count	Translate to a FirstBody paragraph with special
#					indent and tab stop based on "count", and tab after
#					"text".
#
# Arguments:
# argList -		List of arguments to the .IP macro.
#
# HTML limitations: 'count' in '.IP text count' is ignored.

proc IPmacro argList {
    global file

    setTabs 0.5i
    set length [llength $argList]
    if {$length == 0} {
    	nest para UL LI
	return
    }
    if {$length == 1} {
    	nest para OL LI
	    return
	}
    if {$length > 1} {
    	nest para DL DT
	    formattedText [lindex $argList 0]
	    puts $file "\n<DD>"
	    return
    }
    puts stderr "Bad .IP macro: .IP [join $argList " "]"
}


# TPmacro --
#
# This procedure is invoked to handle ".TP" macros, which may take any
# of the following forms:
#
# .TP x		Translate to an indented paragraph with the
# 			specified indent (in 100 twip units).
# .TP		Translate to an indented paragraph with
# 			default indent.
#
# Arguments:
# argList -		List of arguments to the .IP macro.
#
# HTML limitations: 'x' in '.TP x' is ignored.


proc TPmacro {argList} {
    global inDT
    nest para DL DT
    set inDT "\n<DD>"			;# next newline writes inDT 
    setTabs 0.5i
}



# THmacro --
#
# This procedure handles the .TH macro.  It generates the non-scrolling
# header section for a given man page, and enters information into the
# table of contents.  The .TH macro has the following form:
#
# .TH name section date footer header
#
# Arguments:
# argList -		List of arguments to the .TH macro.

proc THmacro {argList} {
    global file

    if {[llength $argList] != 5} {
	set args [join $argList " "]
	puts stderr "Bad .TH macro: .$name $args"
    }
    set name  [lindex $argList 0]		;# Tcl_UpVar
    set page  [lindex $argList 1]		;# 3
    set vers  [lindex $argList 2]		;# 7.4
    set lib   [lindex $argList 3]		;# Tcl
    set pname [lindex $argList 4]		;# {Tcl Library Procedures}

    puts -nonewline $file "<HTML><HEAD><TITLE>"
    text "$lib - $name ($page)"
    puts $file "</TITLE></HEAD><BODY>\n"
    
    puts -nonewline $file "<H1><CENTER>"
    text $pname
    puts $file "</CENTER></H1>\n"
}



# newPara --
#
# This procedure sets the left and hanging indents for a line.
# Indents are specified in units of inches or centimeters, and are
# relative to the current nesting level and left margin.
#
# Arguments:
# None

proc newPara {} {
    global file nestStk
	
    if {[lindex $nestStk end] != "NEW" } {
	nest decr    
    }
    puts -nonewline $file "<P>"
}



# nest --
#
# This procedure takes care of inserting the tags associated with the
# IP, TP, RS, RE, LP and PP macros. Only 'nest para' takes arguments.
#
# Arguments:
# op -				operation: para, incr, decr, reset, init
# listStart -		begin list tag: OL, UL, DL.
# listItem -		item tag:       LI, LI, DT.

proc nest {op {listStart "NEW"} {listItem {} } } {
    global file nestStk inDT charCnt
#	puts "nest: $op $listStart $listItem"
    switch $op {
	para {
	    set top [lindex $nestStk end]
	    if {$top == "NEW" } {
		set nestStk [lreplace $nestStk end end $listStart]
		puts $file "<$listStart>"
	    } elseif {$top != $listStart} {
		puts stderr "nest para: bad stack"
		exit 1
	    }
	    puts $file "\n<$listItem>"
	    set charCnt 0
	}
	incr {
	   lappend nestStk NEW
	}
	decr {
	    if {[llength $nestStk] == 0} {
		puts stderr "nest error: nest length is zero"
		set nestStk NEW
	    }
	    set tag [lindex $nestStk end]
	    if {$tag != "NEW"} {
		puts $file "</$tag>"
	    }
	    set nestStk [lreplace $nestStk end end]
	}
	reset {
	    while {[llength $nestStk] > 0} {
		nest decr
	    }
	    set nestStk NEW
	}
	init {
	    set nestStk NEW
	    set inDT {}
	}
    }
    set charCnt 0
}



# do --
#
# This is the toplevel procedure that translates a man page
# to Frame.  It runs the man2tcl program to turn the man page
# into a script, then it evals that script.
#
# Arguments:
# fileName -		Name of the file to translate.

proc do fileName {
    global file self html_dir package footer
    set self "[file tail $fileName].html"
    set file [open "$html_dir/$package/$self" w]
    puts "  Pass 2 -- $fileName"
    flush stdout
    initGlobals
    if [catch {eval [exec man2tcl [glob $fileName]]} msg] {
	global errorInfo
	puts stderr $msg
	puts "in"
	puts stderr $errorInfo
	exit 1
    }
    nest reset
    puts $file $footer
    puts $file "</BODY></HTML>"
    close $file
}