proc initGlobals {} {
global file noFillCount textState
global fontStart fontEnd curFont inPRE charCnt
nest init
set inPRE 0
set textState 0
set curFont ""
set fontStart(Code) "<B>"
set fontStart(Emphasis) "<I>"
set fontEnd(Code) "</B>"
set fontEnd(Emphasis) "</I>"
set noFillCount 0
set charCnt 0
setTabs 0.5i
}
proc beginFont font {
global curFont file fontStart
if {$curFont == $font} {
return
}
endFont
puts -nonewline $file $fontStart($font)
set curFont $font
}
proc endFont {} {
global curFont file fontEnd
if {$curFont != ""} {
puts -nonewline $file $fontEnd($curFont)
set curFont ""
}
}
proc text string {
global file textState inDT charCnt
set pos [string first "\t" $string]
if {$pos >= 0} {
text [string range $string 0 [expr $pos-1]]
tab
text [string range $string [expr $pos+1] end]
return
}
incr charCnt [string length $string]
regsub -all {&} $string {\&} string
regsub -all {<} $string {\<} string
regsub -all {>} $string {\>} string
regsub -all {"} $string {\"} string
switch $textState {
REF {
if {$inDT == {}} {
set string [insertRef $string]
}
}
SEE {
global NAME_file
foreach i [split $string] {
if ![regexp -nocase {^[a-z_]+} [string trim $i] i ] {
# puts "Warning: $i in SEE ALSO not found"
continue
}
if ![catch {set ref $NAME_file($i)} ] {
regsub $i $string "<A HREF=\"$ref.html\">$i</A>" string
}
}
}
}
puts -nonewline $file "$string"
}
proc insertRef string {
global NAME_file self
set path {}
if ![catch {set ref $NAME_file([string trim $string])} ] {
if {"$ref.html" != $self} {
set string "<A HREF=\"${path}$ref.html\">$string</A>"
}
}
return $string
}
proc macro {name args} {
switch $name {
AP {
if {[llength $args] != 3} {
puts stderr "Bad .AP macro: .$name [join $args " "]"
}
setTabs {1.25i 2.5i 3.75i}
TPmacro {}
font B
text "[lindex $args 0] "
font I
text "[lindex $args 1]"
font R
text " ([lindex $args 2])"
newline
}
AS {} ; br {
lineBreak
}
BS {}
BE {}
CE {
global file noFillCount inPRE
puts $file </PRE></BLOCKQUOTE>
set inPRE 0
}
CS { ; global file noFillCount inPRE
puts -nonewline $file <BLOCKQUOTE><PRE>
set inPRE 1
}
DE {
global file noFillCount inPRE
puts $file </PRE></BLOCKQUOTE>
set inPRE 0
set noFillCount 0
}
DS {
global file noFillCount inPRE
puts -nonewline $file <BLOCKQUOTE><PRE>
set noFillCount 10000000
set inPRE 1
}
fi {
global noFillCount
set noFillCount 0
}
IP {
IPmacro $args
}
LP {
nest decr
nest incr
newPara
}
ne {
}
nf {
global noFillCount
set noFillCount 1000000
}
OP {
global inDT file inPRE
if {[llength $args] != 3} {
puts stderr "Bad .OP macro: .$name [join $args " "]"
}
nest para DL DT
set inPRE 1
puts -nonewline $file <PRE>
setTabs 4c
text "Command-Line Name:"
tab
font B
set x [lindex $args 0]
regsub -all {\\-} $x - x
text $x
newline
font R
text "Database Name:"
tab
font B
text [lindex $args 1]
newline
font R
text "Database Class:"
tab
font B
text [lindex $args 2]
font R
puts -nonewline $file </PRE>
set inDT "\n<DD>" ; set inPRE 0
newline
}
PP {
nest decr
nest incr
newPara
}
RE {
nest decr
}
RS {
nest incr
}
SE {
global noFillCount textState inPRE file
font R
puts -nonewline $file </PRE>
set inPRE 0
set noFillCount 0
nest reset
newPara
text "See the "
font B
set temp $textState
set textState REF
text options
set textState $temp
font R
text " manual entry for detailed descriptions of the above options."
}
SH {
SHmacro $args
}
SO {
global noFillCount inPRE file
SHmacro "STANDARD OPTIONS"
setTabs {4c 8c 12c}
set noFillCount 1000000
puts -nonewline $file <PRE>
set inPRE 1
font B
}
so {
if {$args != "man.macros"} {
puts stderr "Unknown macro: .$name [join $args " "]"
}
}
sp { ; if {$args == ""} {
set count 1
} else {
set count [lindex $args 0]
}
while {$count > 0} {
lineBreak
incr count -1
}
}
ta {
setTabs $args
}
TH {
THmacro $args
}
TP {
TPmacro $args
}
UL { ; global file
puts -nonewline $file "<B><U>"
text [lindex $args 0]
puts -nonewline $file "</U></B>"
if {[llength $args] == 2} {
text [lindex $args 1]
}
}
VE {
}
VS {
}
default {
puts stderr "Unknown macro: .$name [join $args " "]"
}
}
}
proc font type {
global textState
switch $type {
P -
R {
endFont
if {$textState == "REF"} {
set textState INSERT
}
}
B {
beginFont Code
if {$textState == "INSERT"} {
set textState REF
}
}
I {
beginFont Emphasis
}
S {
}
default {
puts stderr "Unknown font: $type"
}
}
}
proc formattedText text {
while {$text != ""} {
set index [string first \\ $text]
if {$index < 0} {
text $text
return
}
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]
}
e {
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]
}
default {
puts stderr "Unknown sequence: \\$c"
set text [string range $text [expr $index+2] end]
}
}
}
}
proc dash {} {
global textState charCnt
if {$textState == "NAME"} {
set textState 0
}
incr charCnt
text "-"
}
proc tab {} {
global inPRE charCnt tabString
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 {
}
}
proc setTabs {tabList} {
global file breakPending tabString
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
}
}
lappend tabString [format "%*s1" [expr round($distance-$last-1)] " "]
set last $distance
}
set tabString [join $tabString {}]
}
proc lineBreak {} {
global file inPRE
puts $file "<BR>"
}
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
}
proc char name {
global file charCnt
incr charCnt
switch -exact $name {
\\0 { ; puts -nonewline $file " "
}
\\\\ { ; }
\\(+- { ; puts -nonewline $file "±"
}
\\% {} ; \\| { ; }
default {
puts stderr "Unknown character: $name"
}
}
}
proc macro2 {name args} {
puts stderr "Unknown macro: '$name [join $args " "]"
}
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>"
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
}
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 " "]"
}
proc TPmacro {argList} {
global inDT
nest para DL DT
set inDT "\n<DD>" ; setTabs 0.5i
}
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] ; set page [lindex $argList 1] ; set vers [lindex $argList 2] ; set lib [lindex $argList 3] ; set pname [lindex $argList 4] ;
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"
}
proc newPara {} {
global file nestStk
if {[lindex $nestStk end] != "NEW" } {
nest decr
}
puts -nonewline $file "<P>"
}
proc nest {op {listStart "NEW"} {listItem {} } } {
global file nestStk inDT charCnt
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
}
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
}