tcltk-man2html.tcl

tcl是工具命令语言

	    default {
		fatal "bad .OP $rest"
	    }
	}
	if {![regexp {^(<.>)([-\w ]+)(</.>)$} $switch all oswitch switch cswitch]} {
	    if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)(</.>)$} $switch all oswitch switch1 switch2 cswitch]} {
		error "not Switch: $switch"
	    } else {
		set switch "$switch1$cswitch or $oswitch$switch2"
	    }
	}
	if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} {
	    error "not Name: $name"
	}
	if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
	    error "not Class: $class"
	}
	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 {![string length $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 {[string equal $code ".IP"] && [string equal $rest {}]} {
		    man-puts "<P>"
		    continue
		}
		if {[lsearch {.br .DS .RS} $code] >= 0} {
		    output-directive $line
		} else {
		    backup-text 1
		    break
		}
	    } else {
		man-puts $line
	    }
	}
	man-puts </DL>
    } else {
	# labelled list, make contents
	if {[string compare $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 {[string equal $manual(section) "ARGUMENTS"] || \
				[regexp {^\[\d+\]$} $rest]} {
			    man-puts "<P><DT>$rest<DD>"
			} else {
			    man-puts "<P><DT>[long-toc $rest]<DD>"
			}
			if {[string equal $manual(name):$manual(section) \
				"selection:DESCRIPTION"]} {
			    if {[match-text .RE @rest .RS .RS]} {
				man-puts <DT>[long-toc $rest]<DD>
			    }
			}
		    }
		    .sp -
		    .br -
		    .DS -
		    .CS {
			output-directive $line
		    }
		    .RS {
			if {[match-text .RS]} {
			    output-directive $line
			    incr accept_RE 1
			} elseif {[match-text .CS]} {
			    output-directive .CS
			    incr accept_RE 1
			} elseif {[match-text .PP]} {
			    output-directive .PP
			    incr accept_RE 1
			} elseif {[match-text .DS]} {
			    output-directive .DS
			    incr accept_RE 1
			} else {
			    output-directive $line
			}
		    }
		    .PP {
			if {[match-text @rest1 .br @rest2 .RS]} {
			    # yet another nroff kludge as above
			    man-puts "<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 {[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 "<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]