tcltk-man2html.tcl [plain text]
#!/bin/sh
exec tclsh8.2 "$0" ${1+"$@"}
package require Tcl 8.2
set Version "0.30"
proc parse_command_line {} {
global argv Version
global tcltkdir tkdir tcldir webdir
set tcltkdir ../..
set tkdir {}
set tcldir {}
set webdir ../html
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}
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=* {
set tcltkdir [string range $option 9 end]
}
--htmldir=* {
set webdir [string range $option 10 end]
}
default {
puts stderr "tcltk-man-html: unrecognized option -- `$option'"
exit 1
}
}
}
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
}
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
}
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
}
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" \
{&} {&} \
{\\} {\} \
{\e} {\} \
{\ } { } \
{\|} { } \
{\0} { } \
{\%} {} \
"\\\n" "\n" \
\" {"} \
{<} {<} \
{>} {>} \
{\(+-} {±} \
{\fP} {\fR} \
{\.} . \
] $text]
regsub -all {\\o'o\^'} $text {\ô} 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 "\\& while {[string first "\\" $text] >= 0} {
if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
{\1<TT>\2</TT>\3} text]} continue
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
{\1<B>\2</B>\3} text]} continue
if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
{\1<B>\2</B>\\fI\3} text]} continue
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
{\1<I>\2</I>\3} text]} continue
if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
{\1<I>\2</I>\\fB\3} text]} continue
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
}
manerror "process-text: uncaught backslash: $text"
set text [string map [list "\\" "#92;"] $text]
}
return $text
}
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]
}
proc man-puts {text} {
global manual
lappend manual(output-$manual(wing-file)-$manual(name)) $text
}
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"]} {
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"]} {
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>"
}
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]
}
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>
}
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>
}
proc output-IP-list {context code rest} {
global manual
if {![string length $rest]} {
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 {
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]} {
man-puts "<P><DT>[long-toc $rest1]"
man-puts "<DT>[long-toc $rest2]<DD>"
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
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"
}
}
}
proc output-name {line} {
global manual
regexp {^([^-]+) - (.*)$} $line all head tail
man-puts $line
lappend manual(section-toc) <DL><DD>$line</DL>
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)
}
}
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]
}
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} {
}
return $ref
}
foreach name $manual(name-$lref) {
if {[lsearch $name $manual(wing-file)/$manual(name)] >= 0} {
return $ref
}
}
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
}
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 "<A HREF=\"../$manual(name-$lref).htm\">$ref</A>"
}
proc reference-error {msg text} {
global manual
puts stderr "$manual(tail): $msg: {$text}"
return $text
}
proc insert-cross-references {text} {
global manual
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] \
]
foreach name [array names offset] {
if {$offset($name) >= 0} {
set invert($offset($name)) $name
lappend offsets $offset($name)
}
}
if {![info exists offsets]} {
return $text
}
set offsets [lsort -integer $offsets]
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_\w+)(.*)$} $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_\w+)(.*)$} $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]
}
}
}
proc output-directive {line} {
global manual
split-directive $line code rest
switch -exact $code {
.BS -
.BE {
}
.SH {
set manual(section) $rest
set manual($manual(name)-$manual(section)) {}
lappend manual(has-$manual(section)) $manual(name)
man-puts "<H3>[long-toc $manual(section)]</H3>"
switch -exact $manual(section) {
NAME {
if {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} {
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]} {
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 {
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; }
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"
}
}
}
proc merge-copyrights {l1 l2} {
foreach copyright [concat $l1 $l2] {
if {[regexp {^Copyright +\(c\) +(\d+) +(by +)?(\w.*)$} $copyright all date by who]} {
lappend dates($who) $date
continue
}
if {[regexp {^Copyright +\(c\) +(\d+)-(\d+) +(by +)?(\w.*)$} $copyright all from to by who]} {
for {set date $from} {$date <= $to} {incr date} {
lappend dates($who) $date
}
continue
}
if {[regexp {^Copyright +\(c\) +(\d+), *(\d+) +(by +)?(\w.*)$} $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] && \
[catch {file mkdir $dir} error]} {
return -code error "cannot create directory $dir: $error"
}
}
proc make-man-pages {html args} {
global env manual overall_title
makedirhier $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]
puts stderr "scanning section $manual(wing-name)"
puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/contents.htm\">$manual(wing-name)</A><DD>$manual(wing-description)"
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>"
set manual(wing-toc) {}
makedirhier $html/$manual(wing-file)
set manual(long-toc-n) 1
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]"
}
foreach manual(page) $manual(pages) {
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} {
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
}
continue
}
if {"$line" == {'}} {
continue
}
if {[parse-directive $line code rest]} {
switch -exact $code {
.ad - .na - .so - .ne - .AS - .VE - .VS -
. {
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 {^(.*) +\d+$} $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 {[string match "..*" $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)
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"
}
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> © [lrange $copyright 2 end]"
}
man-puts "<A HREF=\"../copyright.htm\">Copyright</A> © 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> © [lrange $copyright 2 end]"
}
man-puts "<A HREF=\"../copyright.htm\">Copyright</A> © 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"
}
set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL><HR>]
}
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>
puts $manual(wing-toc-fp) "<HR><PRE>"
foreach copyright $manual(wing-copyrights) {
puts $manual(wing-toc-fp) "<A HREF=\"../copyright.htm\">Copyright</A> © [lrange $copyright 2 end]"
}
puts $manual(wing-toc-fp) "<A HREF=\"../copyright.htm\">Copyright</A> © 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)]
}
proc strcasecmp {a b} { return [string compare -nocase $a $b] }
set keys [lsort -command strcasecmp [array names manual keyword-*]]
makedirhier $html/Keywords
catch {eval file delete -- [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>"
foreach copyright $manual(merge-copyrights) {
puts $afp "<A HREF=\"copyright.htm\">Copyright</A> © [lrange $copyright 2 end]"
}
puts $afp "<A HREF=\"copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr."
puts $afp "</PRE></BODY></HTML>"
close $afp
}
puts $keyfp "</H2><HR><PRE>"
foreach copyright $manual(merge-copyrights) {
puts $keyfp "<A HREF=\"copyright.htm\">Copyright</A> © [lrange $copyright 2 end]"
}
puts $keyfp "<A HREF=\"copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr."
puts $keyfp </PRE><HR></BODY></HTML>
close $keyfp
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>"
foreach copyright $manual(merge-copyrights) {
puts $manual(short-toc-fp) "<A HREF=\"copyright.htm\">Copyright</A> © [lrange $copyright 2 end]"
}
puts $manual(short-toc-fp) "<A HREF=\"copyright.htm\">Copyright</A> © 1995-1997 Roger E. Critchlow Jr."
puts $manual(short-toc-fp) "</PRE></BODY></HTML>"
close $manual(short-toc-fp)
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 GetDash
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
}
}