diff options
| -rw-r--r-- | ChangeLog | 6 | ||||
| -rwxr-xr-x | tools/tcltk-man2html.tcl | 223 |
2 files changed, 146 insertions, 83 deletions
@@ -1,3 +1,9 @@ +2010-01-12 Donal K. Fellows <dkf@users.sf.net> + + * tools/tcltk-man2html.tcl: Make the generation of the list of things + to process the docs from simpler and more flexible. Also factored out + the lists of special cases. + 2010-01-10 Jan Nijtmans <nijtmans@users.sf.net> * win/tclWinDde.c: VC++ 6.0 doesn't have diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index ba4fad6..a1b8191 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -2,7 +2,7 @@ # The next line is executed by /bin/sh, but not tcl \ exec tclsh "$0" ${1+"$@"} -package require Tcl 8.5 +package require Tcl 8.6 # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -244,6 +244,8 @@ proc css-stylesheet {} { ## proc make-man-pages {html args} { global manual overall_title tcltkdesc verbose + global excluded_pages forced_index_pages process_first_patterns + makedirhier $html set cssfd [open $html/$::CSSFILE w] puts $cssfd [css-stylesheet] @@ -253,6 +255,10 @@ proc make-man-pages {html args} { puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title] puts $manual(short-toc-fp) "<DL class=\"keylist\">" set manual(merge-copyrights) {} + + set LQ \u201c + set RQ \u201d + foreach arg $args { # preprocess to set up subheader for the rest of the files if {![llength $arg]} { @@ -288,17 +294,17 @@ proc make-man-pages {html args} { set manual(long-toc-n) 1 # get the manual pages for this section set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]] - set n [lsearch -glob $manual(pages) */ttk_widget.n] - if {$n >= 0} { - set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" - } - set n [lsearch -glob $manual(pages) */options.n] - if {$n >= 0} { - set manual(pages) "[lindex $manual(pages) $n] [lreplace $manual(pages) $n $n]" + # Some pages have to go first so that their links override others + foreach pat $process_first_patterns { + set n [lsearch -glob $manual(pages) $pat] + if {$n >= 0} { + set f [lindex $manual(pages) $n] + puts stderr "shuffling [file tail $f] to front" + set manual(pages) [linsert [lreplace $manual(pages) $n $n] 0 \ + $f] + } } # set manual(pages) [lrange $manual(pages) 0 5] - set LQ \u201c - set RQ \u201d foreach manual_page $manual(pages) { set manual(page) [file normalize $manual_page] # whistle @@ -310,7 +316,7 @@ proc make-man-pages {html args} { set manual(tail) [file tail $manual(page)] set manual(name) [file root $manual(tail)] set manual(section) {} - if {$manual(name) in {case pack-old menubar}} { + if {$manual(name) in $excluded_pages} { # obsolete if {!$verbose} { puts stderr "" @@ -489,9 +495,9 @@ proc make-man-pages {html args} { error "found .. outside of .de" } default { - if {!$verbose} { - puts stderr "" - } + if {!$verbose} { + puts stderr "" + } flushbuffer manerror "unrecognized format directive: $line" } @@ -549,12 +555,14 @@ proc make-man-pages {html args} { } } man-puts [copyout $manual(copyrights) "../"] - set manual(wing-copyrights) [merge-copyrights $manual(wing-copyrights) $manual(copyrights)] + set manual(wing-copyrights) [merge-copyrights \ + $manual(wing-copyrights) $manual(copyrights)] } # # make the long table of contents for this page # - set manual(toc-$manual(wing-file)-$manual(name)) [concat <DL> $manual(section-toc) </DL>] + set manual(toc-$manual(wing-file)-$manual(name)) \ + [concat <DL> $manual(section-toc) </DL>] } if {!$verbose} { puts stderr "" @@ -596,7 +604,8 @@ proc make-man-pages {html args} { puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"] puts $manual(wing-toc-fp) "</BODY></HTML>" close $manual(wing-toc-fp) - set manual(merge-copyrights) [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)] + set manual(merge-copyrights) [merge-copyrights \ + $manual(merge-copyrights) $manual(wing-copyrights)] } ## @@ -699,14 +708,13 @@ proc make-man-pages {html args} { puts $outfd [htmlhead "$manual($manual(name)-title)" \ $manual(name) $manual(wing-file) "[indexfile]" \ $overall_title "../[indexfile]"] - if { - (($ntext > 60) && ($ntoc > 32)) || $manual(tail) in { - Hash LinkVar SetVar TraceVar ConfigWidg CrtImgType - CrtItemType CrtPhImgFmt DoOneEvent GetBitmap GetColor - GetCursor GetDash GetJustify GetPixels GetVisual - ParseArgv QueueEvent + if {($ntext > 60) && ($ntoc > 32)} { + foreach item $toc { + puts $outfd $item } - } { + } elseif {$manual(name) in $forced_index_pages} { + if {!$verbose} {puts stderr ""} + manerror "forcing index generation" foreach item $toc { puts $outfd $item } @@ -731,73 +739,122 @@ proc make-man-pages {html args} { return {} } -parse_command_line - -set tcltkdesc ""; set cmdesc ""; set appdir "" -if {$build_tcl} { - append tcltkdesc "Tcl" - append cmdesc "Tcl" - append appdir "$tcldir" -} -if {$build_tcl && $build_tk} { - append tcltkdesc "/" - append cmdesc " and " - append appdir "," -} -if {$build_tk} { - append tcltkdesc "Tk" - append cmdesc "Tk" - append appdir "$tkdir" +## +## Helper for assembling the descriptions of base packages (i.e., Tcl and Tk). +## +proc plus-base {var glob name dir desc} { + global tcltkdir + if {$var} { + return [list $tcltkdir/$glob $name $dir $desc] + } } -set usercmddesc "The interpreters which implement $cmdesc." -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.} - -proc plus-pkg {dir name type} { +## +## Helper for assembling the descriptions of contributed packages. +## +proc plus-pkgs {type args} { global build_tcl tcltkdir tcldir - if {!$build_tcl} return - set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/*.$type - if {![llength [glob -nocomplain $globpat]]} return - if {$type eq "n"} { - set title "$name Package Commands" - set dir [string totitle $dir]Cmd - set desc "The additional commands provided by the $name package." - } elseif {$type eq "3"} { - set title "$name Package Library" - set dir [string totitle $dir]Lib - set desc "The additional C functions provided by the $name package." - } else { + if {$type ni {n 3}} { error "unknown type \"$type\": must be 3 or n" } - return [list $globpat $title $dir $desc] + if {!$build_tcl} return + set result {} + foreach {dir name} $args { + set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/*.$type + if {![llength [glob -nocomplain $globpat]]} continue + switch $type { + n { + set title "$name Package Commands" + set dir [string totitle $dir]Cmd + set desc \ + "The additional commands provided by the $name package." + } + 3 { + set title "$name Package Library" + set dir [string totitle $dir]Lib + set desc \ + "The additional C functions provided by the $name package." + } + } + lappend result [list $globpat $title $dir $desc] + } + return $result } -if {1} { - if {[catch { - make-man-pages $webdir \ - [list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd $usercmddesc] \ - [expr {$build_tcl ? - [list $tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd $tclcmddesc] - : ""}] \ - [expr {$build_tk ? - [list $tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd $tkcmddesc] - : ""}] \ - [plus-pkg itcl {[incr Tcl]} n] \ - [plus-pkg tdbc TDBC n] \ - [expr {$build_tcl ? - [list $tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib $tcllibdesc] - : ""}] \ - [expr {$build_tk ? - [list $tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib $tklibdesc] - : ""}] \ - [plus-pkg itcl {[incr Tcl]} 3] \ - [plus-pkg tdbc TDBC 3] - } error]} { - puts $error\n$errorInfo +## +## Set up some special cases. It would be nice if we didn't have them, +## but we do... +## +set excluded_pages {case menubar pack-old} +set forced_index_pages {GetDash} +set process_first_patterns {*/ttk_widget.n */options.n} + +try { + # Parse what the user told us to do + parse_command_line + + # Some strings depend on what options are specified + set tcltkdesc ""; set cmdesc ""; set appdir "" + if {$build_tcl} { + append tcltkdesc "Tcl" + append cmdesc "Tcl" + append appdir "$tcldir" + } + if {$build_tcl && $build_tk} { + append tcltkdesc "/" + append cmdesc " and " + append appdir "," + } + if {$build_tk} { + append tcltkdesc "Tk" + append cmdesc "Tk" + append appdir "$tkdir" + } + + # Get the list of packages to try, and what their human-readable + # names are. + try { + set packageDirNameMap {} + if {$build_tcl} { + set f [open $tcltkdir/$tcldir/pkgs/package.list.txt] + try { + foreach line [split [read $f] \n] { + if {[string trim $line] eq ""} continue + if {[string match #* $line]} continue + lappend packageDirNameMap {*}$line + } + } finally { + close $f + } + } + } trap {POSIX ENOENT} {} { + set packageDirNameMap { + itcl {[incr Tcl]} + tdbc {TDBC} + } } + + # + # Invoke the scraper/converter engine. + # + make-man-pages $webdir \ + [list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \ + "The interpreters which implement $cmdesc."] \ + [plus-base $build_tcl $tcldir/doc/*.n {Tcl Commands} TclCmd \ + "The commands which the <B>tclsh</B> interpreter implements."] \ + [plus-base $build_tk $tkdir/doc/*.n {Tk Commands} TkCmd \ + "The additional commands which the <B>wish</B> interpreter implements."] \ + {*}[plus-pkgs n {*}$packageDirNameMap] \ + [plus-base $build_tcl $tcldir/doc/*.3 {Tcl Library} TclLib \ + "The C functions which a Tcl extended C program may use."] \ + [plus-base $build_tk $tkdir/doc/*.3 {Tk Library} TkLib \ + "The additional C functions which a Tk extended C program may use."] \ + {*}[plus-pkgs 3 {*}$packageDirNameMap] +} on error {msg opts} { + # On failure make sure we show what went wrong. We're not supposed + # to get here though; it represents a bug in the script. + puts $msg\n[dict get $opts -errorinfo] + exit 1 } # Local-Variables: |