"
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
if {!$accept_RE} {
man-puts "$enddl$rest$dl"
backup-text 1
set para {}
break
}
man-puts "
$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
}
set para
}
man-puts "$para$enddl"
lappend manual(section-toc) $enddl
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 {^([^-]+) - (.*)$} [regsub -all {[ \n\r\t]+} $line " "] -> head tail
# output line to manual page untouched
man-puts "$head — $tail"
# output line to long table of contents
lappend manual(section-toc) "
- $head — $tail
"
# 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 remap_link_target
global ensemble_commands exclude_refs_map exclude_when_followed_by_map
set manname $manual(name)
set mantail $manual(tail)
if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref] || [string match "Itcl_*" $ref] || [string match "Tdbc_*" $ref]} {
regexp {^\w+} $ref lref
##
## apply a link remapping if available
##
if {[info exists remap_link_target($lref)]} {
set lref $remap_link_target($lref)
}
} elseif {$ref eq "Tcl"} {
set lref $ref
} elseif {
[regexp {^[A-Z0-9 ?!]+$} $ref]
&& [info exists manual($manname-id-$ref)]
} {
return "$ref"
} else {
set lref [string tolower $ref]
##
## apply a link remapping if available
##
if {[info exists remap_link_target($lref)]} {
set lref $remap_link_target($lref)
}
}
##
## nothing to reference
##
if {![info exists manual(name-$lref)]} {
foreach name $ensemble_commands {
if {
[regexp "^$name \[a-z0-9]*\$" $lref] &&
[info exists manual(name-$name)] &&
$mantail ne "$name.n" &&
(![info exists exclude_refs_map($mantail)] ||
$manual(name-$name) ni $exclude_refs_map($mantail))
} {
return "$ref"
}
}
if {$lref in {end}} {
# no good place to send this tcl token?
}
return $ref
}
set manref $manual(name-$lref)
##
## would be a self reference
##
foreach name $manref {
if {"$manual(wing-file)/$manname" in $name} {
return $ref
}
}
##
## multiple choices for reference
##
if {[llength $manref] > 1} {
set tcl_i [lsearch -glob $manref *TclCmd*]
if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd"
|| $manual(wing-file) eq "TclLib"} {
set tcl_ref [lindex $manref $tcl_i]
return "$ref"
}
set tk_i [lsearch -glob $manref *TkCmd*]
if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd"
|| $manual(wing-file) eq "TkLib"} {
set tk_ref [lindex $manref $tk_i]
return "$ref"
}
if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} {
set tcl_ref [lindex $manref $tcl_i]
return "$ref"
}
puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
return $ref
}
##
## exceptions, sigh, to the rule
##
if {[info exists exclude_when_followed_by_map($mantail)]} {
upvar 1 text tail
set following_word [lindex [regexp -inline {\S+} $tail] 0]
foreach {this that} $exclude_when_followed_by_map($mantail) {
# only a ref if $this is not followed by $that
if {$lref eq $this && [string match $that* $following_word]} {
return $ref
}
}
}
if {
[info exists exclude_refs_map($mantail)]
&& $lref in $exclude_refs_map($mantail)
} {
return $ref
}
##
## return the cross reference
##
return "$ref"
}
##
## 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
set result ""
while 1 {
##
## we identify cross references by:
## ``quotation''
## emboldening
## Tcl_ prefix
## Tk_ prefix
## [a-zA-Z0-9]+ manual entry
## and we avoid messing with already anchored text
##
##
## find where each item lives - EXPENSIVE - and accumulate a list
##
unset -nocomplain offsets
foreach {name pattern} {
anchor {}
quote {``} end-quote {''}
bold {} end-bold {}
c.tcl {Tcl_}
c.tk {Tk_}
c.ttk {Ttk_}
c.tdbc {Tdbc_}
c.itcl {Itcl_}
Tcl1 {Tcl manual entry}
Tcl2 {Tcl overview manual entry}
url {http://}
} {
set o [string first $pattern $text]
if {[set offset($name) $o] >= 0} {
set invert($o) $name
lappend offsets $o
}
}
##
## if nothing, then we're done.
##
if {![info exists offsets]} {
return [append result $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]
}
append result [string range $text 0 $offset(end-anchor)]
set text [string range $text[set text ""] \
[expr {$offset(end-anchor)+1}] end]
continue
}
quote {
if {$offset(end-quote) < 0} {
return [reference-error "Missing end quote" $text]
}
if {$invert([lindex $offsets 1]) in {tcl tk ttk}} {
set offsets [lreplace $offsets 1 1]
}
switch -exact -- $invert([lindex $offsets 1]) {
end-quote {
append result [string range $text 0 [expr {$offset(quote)-1}]]
set body [string range $text [expr {$offset(quote)+2}] \
[expr {$offset(end-quote)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-quote)+2}] end]
append result `` [cross-reference $body] ''
continue
}
bold - anchor {
append result [string range $text \
0 [expr {$offset(end-quote)+1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-quote)+2}] end]
continue
}
}
return [reference-error "Uncaught quote case" $text]
}
bold {
if {$offset(end-bold) < 0} {
return [append result $text]
}
if {[string match "c.*" $invert([lindex $offsets 1])]} {
set offsets [lreplace $offsets 1 1]
}
switch -exact -- $invert([lindex $offsets 1]) {
url - end-bold {
append result \
[string range $text 0 [expr {$offset(bold)-1}]]
set body [string range $text [expr {$offset(bold)+3}] \
[expr {$offset(end-bold)-1}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
regsub {http://[\w/.]+} $body {&} body
append result [cross-reference $body]
continue
}
anchor {
append result \
[string range $text 0 [expr {$offset(end-bold)+3}]]
set text [string range $text[set text ""] \
[expr {$offset(end-bold)+4}] end]
continue
}
default {
return [reference-error "Uncaught bold case" $text]
}
}
}
c.tk - c.ttk - c.tcl - c.tdbc - c.itcl {
append result [string range $text 0 \
[expr {[lindex $offsets 0]-1}]]
regexp -indices -start [lindex $offsets 0] {\w+} $text range
set body [string range $text {*}$range]
set text [string range $text[set text ""] \
[expr {[lindex $range 1]+1}] end]
append result [cross-reference $body]
continue
}
Tcl1 - Tcl2 {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
set text [string range $text[set text ""] [expr {$off+3}] end]
append result [cross-reference Tcl]
continue
}
url {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
regexp -indices -start $off {http://[\w/.]+} $text range
set url [string range $text {*}$range]
append result "" $url ""
set text [string range $text[set text ""] \
[expr {[lindex $range 1]+1}] end]
continue
}
end-anchor - end-bold - end-quote {
return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
}
}
}
}
##
## process formatting directives
##
proc output-directive {line} {
global manual
# process format directive
split-directive $line code rest
switch -exact -- $code {
.BS - .BE {
# man-puts
}
.SH - .SS {
# drain any open lists
# announce the subject
set manual(section) $rest
# start our own stack of stuff
set manual($manual(name)-$manual(section)) {}
lappend manual(has-$manual(section)) $manual(name)
if {$code ne ".SS"} {
man-puts "[long-toc $manual(section)]
"
} else {
man-puts "[long-toc $manual(section)]
"
}
# some sections can simply free wheel their way through the text
# some sections can be processed in their own loops
switch -exact -- [string index $code end]:$manual(section) {
H:NAME {
set names {}
while {1} {
set line [next-text]
if {[is-a-directive $line]} {
backup-text 1
output-name [join $names { }]
return
}
lappend names [string trim $line]
}
}
H:SYNOPSIS {
lappend manual(section-toc)
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 .SS rest]
|| [next-op-is .BE rest]
|| [next-op-is .SO rest]
} {
backup-text 1
break
}
if {[next-op-is .sp rest]} {
#man-puts
continue
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "in SYNOPSIS found $more"
backup-text 1
break
}
foreach more [split $more \n] {
regexp {^(\s*)(.*)} $more -> spaces more
set spaces [string map {" " " "} $spaces]
if {[string length $spaces]} {
set spaces $spaces
}
man-puts $spaces$more
if {$manual(wing-file) in {TclLib TkLib}} {
lappend manual(section-toc)
- $more
}
}
}
lappend manual(section-toc)
return
}
{H:SEE ALSO} {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS 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 {^.*$} $cr]} {
set cr $cr
}
if {[regexp {^(.*)\([13n]\)$} $cr all name]} {
set cr $name
}
lappend nmore $cr
}
man-puts [join $nmore {, }]
}
return
}
H:KEYWORDS {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS 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 "$key"
}
man-puts [join $keys {, }]
}
return
}
}
if {[next-op-is .IP rest]} {
output-IP-list $code .IP $rest
return
}
if {[next-op-is .PP rest]} {
return
}
return
}
.SO {
# When there's a sequence of multiple .SO chunks, process into one
set optslist {}
while 1 {
if {[match-text @stuff .SE]} {
foreach opt [split $stuff \n\t] {
lappend optslist [list $opt $rest]
}
} else {
manerror "unexpected .SO format:\n[expand-next-text 2]"
}
if {![next-op-is .SO rest]} {
break
}
}
output-directive {.SH STANDARD OPTIONS}
man-puts
lappend manual(section-toc)
foreach optionpair [lsort -dictionary -index 0 $optslist] {
lassign $optionpair option targetPage
man-puts "- [std-option-toc $option $targetPage]"
}
man-puts
lappend manual(section-toc)
}
.OP {
output-widget-options $rest
return
}
.IP {
output-IP-list .IP .IP $rest
return
}
.PP - .sp {
man-puts
}
.RS {
output-RS-list
return
}
.br {
man-puts
return
}
.DS {
if {[next-op-is .ta rest]} {
# skip the leading .ta directive if it is there
}
if {[match-text @stuff .DE]} {
set td "
"
set bodyText [string map [list \n | $td \t $td] \n$stuff]
man-puts "
"
#man-puts $stuff
} elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
man-puts "[lindex $ul1 1][lindex $ul2 1]\n$stuff
"
} 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 $stuff
} else {
manerror "unexpected .CS format:\n[expand-next-text 2]"
}
return
}
.nf {
if {[match-text @more .fi]} {
foreach more [split $more \n] {
man-puts $more
}
} elseif {[match-text .RS @more .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts
} elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts -
foreach more2 [split $more2 \n] {
man-puts $more2
}
man-puts
} elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts -
foreach more2 [split $more2 \n] {
man-puts $more2
}
man-puts
-
foreach more3 [split $more3 \n] {
man-puts $more3
}
man-puts
} elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
man-puts -
foreach more [split $more \n] {
man-puts $more
}
man-puts -
foreach more2 [split $more2 \n] {
man-puts $more2
}
man-puts
} elseif {[match-text .RS .sp @more .sp .RE .fi]} {
man-puts
-
foreach more [split $more \n] {
man-puts $more
}
man-puts
} else {
manerror "ignoring $line"
}
}
.RE - .DE - .CE {
manerror "unexpected $code"
return
}
.ta - .fi - .na - .ad - .UL - .ie - .el - .ne {
manerror "ignoring $line"
}
default {
manerror "unrecognized format directive: $line"
}
}
}
##
## merge copyright listings
##
proc merge-copyrights {l1 l2} {
set merge {}
set re1 {^Copyright +(?:\(c\)|\\\(co|©) +(\w.*?)(?:all rights reserved)?(?:\. )*$}
set re2 {^(\d+) +(?:by +)?(\w.*)$} ;# date who
set re3 {^(\d+)-(\d+) +(?:by +)?(\w.*)$} ;# from to who
set re4 {^(\d+), *(\d+) +(?:by +)?(\w.*)$} ;# date1 date2 who
foreach copyright [concat $l1 $l2] {
if {[regexp -nocase -- $re1 $copyright -> info]} {
set info [string trimright $info ". "] ; # remove extra period
if {[regexp -- $re2 $info -> date who]} {
lappend dates($who) $date
continue
} elseif {[regexp -- $re3 $info -> from to who]} {
for {set date $from} {$date <= $to} {incr date} {
lappend dates($who) $date
}
continue
} elseif {[regexp -- $re3 $info -> date1 date2 who]} {
lappend dates($who) $date1 $date2
continue
}
}
puts "oops: $copyright"
}
foreach who [array names dates] {
set list [lsort -dictionary $dates($who)]
if {[llength $list] == 1 || [lindex $list 0] eq [lrange $list end end]} {
lappend merge "Copyright © [lindex $list 0] $who"
} else {
lappend merge "Copyright © [lindex $list 0]-[lrange $list end end] $who"
}
}
return [lsort -dictionary $merge]
}
proc makedirhier {dir} {
try {
if {![file isdirectory $dir]} {
file mkdir $dir
}
} on error msg {
return -code error "cannot create directory $dir: $msg"
}
}
proc addbuffer {args} {
global manual
if {$manual(partial-text) ne ""} {
append manual(partial-text) \n
}
append manual(partial-text) [join $args ""]
}
proc flushbuffer {} {
global manual
if {$manual(partial-text) ne ""} {
lappend manual(text) [process-text $manual(partial-text)]
set manual(partial-text) ""
}
}
return