diff options
Diffstat (limited to 'tools')
| -rwxr-xr-x[-rw-r--r--] | tools/checkLibraryDoc.tcl | 28 | ||||
| -rwxr-xr-x[-rw-r--r--] | tools/configure | 2 | ||||
| -rw-r--r-- | tools/configure.in | 4 | ||||
| -rw-r--r-- | tools/eolFix.tcl | 18 | ||||
| -rwxr-xr-x | tools/fix_tommath_h.tcl | 8 | ||||
| -rw-r--r-- | tools/genStubs.tcl | 126 | ||||
| -rw-r--r-- | tools/index.tcl | 10 | ||||
| -rw-r--r-- | tools/man2help2.tcl | 32 | ||||
| -rw-r--r-- | tools/regexpTestLib.tcl | 30 | ||||
| -rw-r--r-- | tools/tcl.hpj.in | 4 | ||||
| -rw-r--r-- | tools/tcl.wse.in | 6 | ||||
| -rwxr-xr-x | tools/tclZIC.tcl | 10 | ||||
| -rw-r--r-- | tools/tclsh.svg | 67 | ||||
| -rw-r--r-- | tools/tcltk-man2html-utils.tcl | 1613 | ||||
| -rwxr-xr-x | tools/tcltk-man2html.tcl | 2142 | ||||
| -rw-r--r-- | tools/tsdPerf.c | 59 | ||||
| -rw-r--r-- | tools/tsdPerf.tcl | 24 |
17 files changed, 2344 insertions, 1839 deletions
diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index cd08c2a..6d147ac 100644..100755 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -1,7 +1,7 @@ # checkLibraryDoc.tcl -- # -# This script attempts to determine what APIs exist in the source base that -# have not been documented. By grepping through all of the doc/*.3 man +# This script attempts to determine what APIs exist in the source base that +# have not been documented. By grepping through all of the doc/*.3 man # pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list # against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch]) # we create six lists: @@ -11,10 +11,10 @@ # 4) Misc APIs and structs that we are not documenting. # 5) Command APIs (e.g., Tcl_ArrayObjCmd.) # 6) Proc pointers (e.g., Tcl_CloseProc.) -# +# # Note: Each list is "a best guess" approximation. If developers write # non-standard code, this script will produce erroneous results. Each -# list should be carefully checked for accuracy. +# list should be carefully checked for accuracy. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. @@ -86,7 +86,7 @@ set StructList { Tk_Window \ } -# Misc junk that appears in the comments of the source. This just +# Misc junk that appears in the comments of the source. This just # allows us to filter comments that "fool" the script. set CommentList { @@ -99,8 +99,8 @@ set CommentList { # Main entry point to this script. proc main {} { - global argv0 - global argv + global argv0 + global argv set len [llength $argv] if {($len != 2) && ($len != 3)} { @@ -121,12 +121,12 @@ proc main {} { foreach {c d} [compare [grepCode $dir $pkg] [grepDocs $dir $pkg]] {} filter $c $d $dir $pkg $file - if {$file != "stdout"} { + if {$file ne "stdout"} { close $file } return } - + # Intersect the two list and write out the sets of APIs in one # list that is not in the other. @@ -145,7 +145,7 @@ proc filter {code docs dir pkg {outFile stdout}} { # This list should just be verified for accuracy. set cmds {} - + # A list of proc pointer structs. These are not documented. # This list should just be verified for accuracy. @@ -162,7 +162,7 @@ proc filter {code docs dir pkg {outFile stdout}} { set misc [grepMisc $dir $pkg] set pat1 ".*(${pkg}_\[A-z0-9]+).*$" - + # A list of APIs in the source, not in the docs. # This list should just be verified for accuracy. @@ -196,7 +196,7 @@ proc filter {code docs dir pkg {outFile stdout}} { # Print the list of APIs if the list is not null. proc dump {list title file} { - if {$list != {}} { + if {$list ne ""} { puts $file "" puts $file $title puts $file "---------------------------------------------------------" @@ -240,7 +240,7 @@ proc grepDocs {dir pkg} { # (e.g., Tcl_Export). Return a list of APIs. proc grepDecl {dir pkg} { - set file [file join $dir generic "[string tolower $pkg]IntDecls.h"] + set file [file join $dir generic "[string tolower $pkg]IntDecls.h"] set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_.*" $file] set pat1 ".*(${pkg}_\[A-z0-9]+).*$" @@ -258,7 +258,7 @@ proc grepDecl {dir pkg} { proc grepMisc {dir pkg} { global CommentList global StructList - + set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_Db.*" "${dir}/\*/\*\.\[ch\]"] set pat1 ".*(${pkg}_\[A-z0-9]+).*$" diff --git a/tools/configure b/tools/configure index 98b5867..3d30039 100644..100755 --- a/tools/configure +++ b/tools/configure @@ -1229,7 +1229,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -DEF_VER=8.5 +DEF_VER=8.6 # Check whether --with-tcl or --without-tcl was given. diff --git a/tools/configure.in b/tools/configure.in index 542c1d3..6aebcaa 100644 --- a/tools/configure.in +++ b/tools/configure.in @@ -2,7 +2,7 @@ dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run to configure the dnl Makefile in this directory. AC_INIT(man2tcl.c) -AC_PREREQ(2.57) +AC_PREREQ(2.59) # Recover information that Tcl computed with its configure script. @@ -11,7 +11,7 @@ AC_PREREQ(2.57) # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- -DEF_VER=8.5 +DEF_VER=8.6 AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`) if test ! -d $TCL_BIN_DIR; then diff --git a/tools/eolFix.tcl b/tools/eolFix.tcl index ed3ec7c..3f35ed4 100644 --- a/tools/eolFix.tcl +++ b/tools/eolFix.tcl @@ -13,16 +13,18 @@ namespace eval ::EOL { variable outMode crlf } -proc EOL::fix {filename {newfilename ""}} { +proc EOL::fix {filename {newfilename {}}} { variable outMode - if {![file exists $filename]} { return } + if {![file exists $filename]} { + return + } puts "EOL Fixing: $filename" file rename ${filename} ${filename}.o set fhnd [open ${filename}.o r] - if {$newfilename != ""} { + if {$newfilename ne ""} { set newfhnd [open ${newfilename} w] } else { set newfhnd [open ${filename} w] @@ -63,12 +65,12 @@ proc EOL::fixall {args} { } if {$tcl_interactive == 0 && $argc > 0} { - if {[string index [lindex $argv 0] 0] == "-"} { + if {[string index [lindex $argv 0] 0] eq "-"} { switch -- [lindex $argv 0] { - -cr { set ::EOL::outMode cr } - -crlf { set ::EOL::outMode crlf } - -lf { set ::EOL::outMode lf } - default { puts stderr "improper mode switch" ; exit 1 } + -cr {set ::EOL::outMode cr} + -crlf {set ::EOL::outMode crlf} + -lf {set ::EOL::outMode lf} + default {puts stderr "improper mode switch"; exit 1} } set argv [lrange $argv 1 end] } diff --git a/tools/fix_tommath_h.tcl b/tools/fix_tommath_h.tcl index f92b7ac..04bf857 100755 --- a/tools/fix_tommath_h.tcl +++ b/tools/fix_tommath_h.tcl @@ -17,12 +17,13 @@ set eat_endif 0 set eat_semi 0 set def_count 0 foreach line [split $data \n] { - if { !$eat_semi && !$eat_endif } { + if {!$eat_semi && !$eat_endif} { switch -regexp -- $line { {#define BN_H_} { puts $line puts {} - puts "\#include <tclTomMathDecls.h>" + puts "\#include \"tclInt.h\"" + puts "\#include \"tclTomMathDecls.h\"" puts "\#ifndef MODULE_SCOPE" puts "\#define MODULE_SCOPE extern" puts "\#endif" @@ -76,6 +77,9 @@ foreach line [split $data \n] { puts "[string map {__x86_64__ NEVER} $line]\ /* 128-bit ints fail in too many places */" } + {#include} { + # remove all includes + } default { puts $line } diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index b43423d..bb584b2 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -190,13 +190,11 @@ proc genStubs::declare {args} { puts stderr "Duplicate entry: declare $args" } } - regsub -all const $decl CONST decl - regsub -all _XCONST $decl _Xconst decl regsub -all "\[ \t\n\]+" [string trim $decl] " " decl set decl [parseDecl $decl] foreach platform $platformList { - if {$decl != ""} { + if {$decl ne ""} { set stubs($curName,$platform,$index) $decl if {![info exists stubs($curName,$platform,lastNum)] \ || ($index > $stubs($curName,$platform,lastNum))} { @@ -281,19 +279,27 @@ proc genStubs::rewriteFile {file text} { # Results: # Returns the original text inside an appropriate #ifdef. -proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { +proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { set text "" switch $plat { win { - append text "#if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */\n${iftxt}" + append text "#if defined(__WIN32__)" + if {$withCygwin} { + append text " || defined(__CYGWIN__)" + } + append text " /* WIN */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* WIN */\n${eltxt}" } append text "#endif /* WIN */\n" } unix { - append text "#if !defined(__WIN32__) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL)\ - /* UNIX */\n${iftxt}" + append text "#if !defined(__WIN32__)" + if {$withCygwin} { + append text " && !defined(__CYGWIN__)" + } + append text " && !defined(MAC_TCL)\ + /* UNIX */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* UNIX */\n${eltxt}" } @@ -314,8 +320,12 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { append text "#endif /* AQUA */\n" } x11 { - append text "#if !(defined(__WIN32__) || defined(__CYGWIN__) || defined(MAC_OSX_TK))\ - /* X11 */\n${iftxt}" + append text "#if !(defined(__WIN32__)" + if {$withCygwin} { + append text " || defined(__CYGWIN__)" + } + append text " || defined(MAC_OSX_TK))\ + /* X11 */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* X11 */\n${eltxt}" } @@ -344,7 +354,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}}} { proc genStubs::emitSlots {name textVar} { upvar $textVar text - forAllStubs $name makeSlot 1 text {" VOID *reserved$i;\n"} + forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\n"} return } @@ -372,7 +382,7 @@ proc genStubs::parseDecl {decl} { return } set rtype [string trim $rtype] - if {$args == ""} { + if {$args eq ""} { return [list $rtype $fname {}] } foreach arg [split $args ,] { @@ -420,14 +430,14 @@ proc genStubs::parseDecl {decl} { proc genStubs::parseArg {arg} { if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} { - if {$arg == "void"} { + if {$arg eq "void"} { return $arg } else { return } } set result [list [string trim $type] $name] - if {$array != ""} { + if {$array ne ""} { lappend result $array } return $result @@ -450,9 +460,6 @@ proc genStubs::makeDecl {name decl index} { lassign $decl rtype fname args append text "/* $index */\n" - if {$rtype != "void"} { - regsub -all void $rtype VOID rtype - } set line "$scspec $rtype" set count [expr {2 - ([string length $line] / 8)}] append line [string range "\t\t\t" 0 $count] @@ -467,18 +474,11 @@ proc genStubs::makeDecl {name decl index} { append text ";\n" return $text } - if {$args == ""} { - append line $fname - append text $line - append text ";\n" - return $text - } append line $fname - regsub -all void $args VOID args set arg1 [lindex $args 0] switch -exact $arg1 { - VOID { + void { append line "(void)" } TCL_VARARGS { @@ -501,6 +501,9 @@ proc genStubs::makeDecl {name decl index} { set sep ", " } append line ", ...)" + if {[lindex $args end] eq "{const char *} format"} { + append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + } } default { set sep "(" @@ -524,9 +527,7 @@ proc genStubs::makeDecl {name decl index} { append line ")" } } - append text $line ";" - format "#ifndef %s_TCL_DECLARED\n#define %s_TCL_DECLARED\n%s\n#endif\n" \ - $fname $fname $text + return "$text$line;\n" } # genStubs::makeMacro -- @@ -547,12 +548,12 @@ proc genStubs::makeMacro {name decl index} { set lfname [string tolower [string index $fname 0]] append lfname [string range $fname 1 end] - set text "#ifndef $fname\n#define $fname \\\n\t(" - if {$args == ""} { + set text "#define $fname \\\n\t(" + if {$args eq ""} { append text "*" } append text "${name}StubsPtr->$lfname)" - append text " /* $index */\n#endif\n" + append text " /* $index */\n" return $text } @@ -575,22 +576,18 @@ proc genStubs::makeSlot {name decl index} { append lfname [string range $fname 1 end] set text " " - if {$rtype != "void"} { - regsub -all void $rtype VOID rtype - } - if {$args == ""} { + if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } - if {[string range $rtype end-8 end] == "__stdcall"} { + if {[string range $rtype end-8 end] eq "__stdcall"} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " } else { append text $rtype " (*" $lfname ") " } - regsub -all void $args VOID args set arg1 [lindex $args 0] switch -exact $arg1 { - VOID { + void { append text "(void)" } TCL_VARARGS { @@ -604,6 +601,9 @@ proc genStubs::makeSlot {name decl index} { set sep ", " } append text ", ...)" + if {[lindex $args end] eq "{const char *} format"} { + append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + } } default { set sep "(" @@ -636,7 +636,7 @@ proc genStubs::makeSlot {name decl index} { # Returns the formatted declaration string. proc genStubs::makeInit {name decl index} { - if {[lindex $decl 2] == ""} { + if {[lindex $decl 2] eq ""} { append text " &" [lindex $decl 1] ", /* " $index " */\n" } else { append text " " [lindex $decl 1] ", /* " $index " */\n" @@ -811,7 +811,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar eval {append temp} $skipString } } - append text [addPlatformGuard $plat $temp] + append text [addPlatformGuard $plat $temp {} true] } ## win ## if {$block(win)} { @@ -825,7 +825,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar eval {append temp} $skipString } } - append text [addPlatformGuard $plat $temp] + append text [addPlatformGuard $plat $temp {} true] } ## macosx ## if {$block(macosx) && !$block(aqua) && !$block(x11)} { @@ -897,7 +897,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } else { eval {set etxt} $skipString append temp [addPlatformGuard $plat [$slotProc \ - $name $stubs($name,$plat,$i) $i] $etxt] + $name $stubs($name,$plat,$i) $i] $etxt true] } set emit 1 break @@ -907,7 +907,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar eval {append temp} $skipString } } - append text [addPlatformGuard x11 $temp] + append text [addPlatformGuard x11 $temp {} true] } } } @@ -947,14 +947,12 @@ proc genStubs::emitMacros {name textVar} { upvar $textVar text set upName [string toupper $libraryName] - append text "\n#if defined(USE_${upName}_STUBS) &&\ - !defined(USE_${upName}_STUB_PROCS)\n" + append text "\n#if defined(USE_${upName}_STUBS)\n" append text "\n/*\n * Inline function declarations:\n */\n\n" forAllStubs $name makeMacro 0 text - append text "\n#endif /* defined(USE_${upName}_STUBS) &&\ - !defined(USE_${upName}_STUB_PROCS) */\n" + append text "\n#endif /* defined(USE_${upName}_STUBS) */\n" return } @@ -978,7 +976,7 @@ proc genStubs::emitHeader {name} { set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] - if {$epoch != ""} { + if {$epoch ne ""} { set CAPName [string toupper $name] append text "\n" append text "#define ${CAPName}_STUBS_EPOCH $epoch\n" @@ -992,24 +990,24 @@ proc genStubs::emitHeader {name} { foreach hook $hooks($name) { set capHook [string toupper [string index $hook 0]] append capHook [string range $hook 1 end] - append text " struct ${capHook}Stubs *${hook}Stubs;\n" + append text " const struct ${capHook}Stubs *${hook}Stubs;\n" } append text "} ${capName}StubHooks;\n" } append text "\ntypedef struct ${capName}Stubs {\n" append text " int magic;\n" - if {$epoch != ""} { + if {$epoch ne ""} { append text " int epoch;\n" append text " int revision;\n" } - append text " struct ${capName}StubHooks *hooks;\n\n" + append text " const struct ${capName}StubHooks *hooks;\n\n" emitSlots $name text append text "} ${capName}Stubs;\n\n" append text "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" - append text "extern ${capName}Stubs *${name}StubsPtr;\n" + append text "extern const ${capName}Stubs *${name}StubsPtr;\n" append text "#ifdef __cplusplus\n}\n#endif\n" emitMacros $name text @@ -1031,14 +1029,16 @@ proc genStubs::emitHeader {name} { proc genStubs::emitInit {name textVar} { variable hooks + variable interfaces variable epoch upvar $textVar text + set root 1 set capName [string toupper [string index $name 0]] append capName [string range $name 1 end] if {[info exists hooks($name)]} { - append text "\nstatic ${capName}StubHooks ${name}StubHooks = \{\n" + append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n" set sep " " foreach sub $hooks($name) { append text $sep "&${sub}Stubs" @@ -1046,9 +1046,21 @@ proc genStubs::emitInit {name textVar} { } append text "\n\};\n" } - append text "\n${capName}Stubs ${name}Stubs = \{\n" - append text " TCL_STUB_MAGIC,\n" - if {$epoch != ""} { + foreach intf [array names interfaces] { + if {[info exists hooks($intf)]} { + if {[lsearch -exact $hooks($intf) $name] >= 0} { + set root 0 + break + } + } + } + + append text "\n" + if {!$root} { + append text "static " + } + append text "const ${capName}Stubs ${name}Stubs = \{\n TCL_STUB_MAGIC,\n" + if {$epoch ne ""} { set CAPName [string toupper $name] append text " ${CAPName}_STUBS_EPOCH,\n" append text " ${CAPName}_STUBS_REVISION,\n" @@ -1056,10 +1068,10 @@ proc genStubs::emitInit {name textVar} { if {[info exists hooks($name)]} { append text " &${name}StubHooks,\n" } else { - append text " NULL,\n" + append text " 0,\n" } - forAllStubs $name makeInit 1 text {" NULL, /* $i */\n"} + forAllStubs $name makeInit 1 text {" 0, /* $i */\n"} append text "\};\n" return diff --git a/tools/index.tcl b/tools/index.tcl index 7b11e3f..71329c2 100644 --- a/tools/index.tcl +++ b/tools/index.tcl @@ -12,7 +12,7 @@ # Global variables used by these scripts: # # state - state variable that controls action of text proc. -# +# # topics - array indexed by (package,section,topic) with value # of topic ID. # @@ -135,7 +135,7 @@ proc macro {name args} { switch $args { NAME { - if {$state == "INIT" } { + if {$state eq "INIT" } { set state NAME } } @@ -144,7 +144,7 @@ proc macro {name args} { KEYWORDS {set state KEY} default {set state OFF} } - + } TH { global state curID curPkg curSect topics keywords @@ -176,7 +176,7 @@ proc macro {name args} { proc dash {} { global state - if {$state == "NAME"} { + if {$state eq "NAME"} { set state DASH } } @@ -185,7 +185,7 @@ proc dash {} { # initGlobals, tab, font, char, macro2 -- # -# These procedures do nothing during the first pass. +# These procedures do nothing during the first pass. # # Arguments: # None. diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index 75f4249..fe4e7ad 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -12,7 +12,7 @@ # Global variables used by these scripts: # # state - state variable that controls action of text proc. -# +# # topics - array indexed by (package,section,topic) with value # of topic ID. # @@ -176,12 +176,12 @@ proc text {string} { } switch $state(textState) { - REF { + REF { if {$state(inTP) == 0} { set string [insertRef $string] } } - SEE { + SEE { global topics curPkg curSect foreach i [split $string] { if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} { @@ -231,7 +231,7 @@ proc insertRef {string} { } } - if {($ref != {}) && ($ref != $curID)} { + if {($ref != "") && ($ref != $curID)} { set string [link $string $ref] } return $string @@ -273,7 +273,7 @@ proc macro {name args} { # next page and previous page } br { - lineBreak + lineBreak } BS {} BE {} @@ -388,12 +388,12 @@ proc macro {name args} { set state(noFill) 1 } so { - if {$args != "man.macros"} { + if {$args ne "man.macros"} { puts stderr "Unknown macro: .$name [join $args " "]" } } sp { ;# needs work - if {$args == ""} { + if {$args eq ""} { set count 1 } else { set count [lindex $args 0] @@ -472,14 +472,14 @@ proc font {type} { P - R { endFont - if {$state(textState) == "REF"} { + if {$state(textState) eq "REF"} { set state(textState) INSERT } } C - B { beginFont Code - if {$state(textState) == "INSERT"} { + if {$state(textState) eq "INSERT"} { set state(textState) REF } } @@ -507,7 +507,7 @@ proc font {type} { proc formattedText {text} { global chars - while {$text != ""} { + while {$text ne ""} { set index [string first \\ $text] if {$index < 0} { text $text @@ -709,6 +709,10 @@ proc char {name} { textSetup puts -nonewline $file "\\'a9 " } + {\(mi} { + textSetup + puts -nonewline $file "-" + } {\(mu} { textSetup puts -nonewline $file "\\'d7 " @@ -760,7 +764,7 @@ proc SHmacro {argList {style section}} { } # control what the text proc does with text - + switch $args { NAME {set state(textState) NAME} DESCRIPTION {set state(textState) INSERT} @@ -885,7 +889,7 @@ proc THmacro {argList} { set curVer [lindex $argList 2] ;# 7.4 set curPkg [lindex $argList 3] ;# Tcl set curSect [lindex $argList 4] ;# {Tcl Library Procedures} - + regsub -all {\\ } $curSect { } curSect ;# Clean up for [incr\ Tcl] puts $file "#{\\footnote $curID}" ;# Context string @@ -950,7 +954,7 @@ proc newPara {leftIndent {firstIndent 0i}} { if $state(paragraph) { puts -nonewline $file "\\line\n" } - if {$leftIndent != ""} { + if {$leftIndent ne ""} { set state(leftIndent) [expr {$state(leftMargin) \ + ($state(offset) * $state(nestingLevel)) \ + [getTwips $leftIndent]}] @@ -1020,7 +1024,7 @@ proc incrNestingLevel {} { proc decrNestingLevel {} { global state - + if {$state(nestingLevel) == 0} { puts stderr "Nesting level decremented below 0" } else { diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl index 86f2a3e..d84a012 100644 --- a/tools/regexpTestLib.tcl +++ b/tools/regexpTestLib.tcl @@ -43,7 +43,7 @@ proc readInputFile {} { # # strings with embedded @'s are truncated # unpreceeded @'s are replaced by {} -# +# proc removeAts {ls} { set len [llength $ls] set newLs {} @@ -94,7 +94,7 @@ proc writeOutputFile {numLines fcn} { global outFileName global lineArray - # open output file and write file header info to it. + # open output file and write file header info to it. set fileId [open $outFileName w] @@ -133,7 +133,7 @@ proc writeOutputFile {numLines fcn} { puts $fileId $currentLine incr srcLineNum $lineArray(c$lineNum) incr lineNum - continue + continue } set len [llength $currentLine] @@ -144,7 +144,7 @@ proc writeOutputFile {numLines fcn} { puts $fileId "\n" incr srcLineNum $lineArray(c$lineNum) incr lineNum - continue + continue } if {($len < 3)} { puts "warning: test is too short --\n\t$currentLine" @@ -209,21 +209,21 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { set vals {} set result 0 set v 0 - + if {[regsub {\*} "$flags" "" newFlags] == 1} { # an error is expected - + if {[string compare $str "EMPTY"] == 0} { # empty regexp is not an error # skip this test - + return "\# skipping the empty-re test from line $srcLineNum\n" } set flags $newFlags set result "\{1 \{[convertErrCode $str]\}\}" } elseif {$numVars > 0} { # at least 1 match is made - + if {[regexp {s} $flags] == 1} { set result "\{0 1\}" } else { @@ -240,7 +240,7 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { } } else { # no match is made - + set result "\{0 0\}" } @@ -248,16 +248,16 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { set cmd [prepareCmd $flags $re $str $vars $noBraces] if {$cmd == -1} { - return "\# skipping test with metasyntax from line $srcLineNum\n" + return "\# skipping test with metasyntax from line $srcLineNum\n" } set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n" append test "\tcatch {unset var}\n" - append test "\tlist \[catch \{ \n" - append test "\t\tset match \[$cmd\] \n" - append test "\t\tlist \$match $vals \n" - append test "\t\} msg\] \$msg \n" - append test "\} $result \n" + append test "\tlist \[catch \{\n" + append test "\t\tset match \[$cmd\]\n" + append test "\t\tlist \$match $vals\n" + append test "\t\} msg\] \$msg\n" + append test "\} $result\n" return $test } diff --git a/tools/tcl.hpj.in b/tools/tcl.hpj.in index 0d01f35..3bdccbe 100644 --- a/tools/tcl.hpj.in +++ b/tools/tcl.hpj.in @@ -5,9 +5,9 @@ HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual -CNT=tcl85.cnt +CNT=tcl86.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl85.hlp +HLP=tcl86.hlp [FILES] tcl.rtf diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in index 69690a8..653b1e1 100644 --- a/tools/tcl.wse.in +++ b/tools/tcl.wse.in @@ -1,7 +1,7 @@ Document Type: WSE item: Global Version=6.01 - Title=Tcl 8.5 for Windows Installation + Title=Tcl 8.6 for Windows Installation Flags=00010100 Languages=65 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 Japanese Font Name=MS Gothic @@ -12,7 +12,7 @@ item: Global Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 - Disk Label=tcl8.5.11 + Disk Label=tcl8.6b2 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 @@ -42,7 +42,7 @@ item: End Block end item: Set Variable Variable=VER - Value=8.5 + Value=8.6 end item: Set Variable Variable=PATCHLEVEL diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 1b19d82..005919a 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -358,7 +358,7 @@ proc parseON {on} { # third possibility - lastWeekday - field 5 last([[:alpha:]]+) )$ - } $on -> dom1 wday2 dir2 num2 wday3]} then { + } $on -> dom1 wday2 dir2 num2 wday3]} { error "can't parse ON field \"$on\"" } if {$dom1 ne ""} { @@ -509,7 +509,7 @@ proc parseTOD {tod} { (?: ([wsugz]) # field 4 - type indicator )? - } $tod -> hour minute second ind]} then { + } $tod -> hour minute second ind]} { puts stderr "$fileName:$lno:can't parse time field \"$tod\"" incr errorCount } @@ -558,7 +558,7 @@ proc parseOffsetTime {offset} { :([[:digit:]]{2}) # field 4 - second )? )? - } $offset -> signum hour minute second]} then { + } $offset -> signum hour minute second]} { puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" incr errorCount } @@ -940,7 +940,7 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset if { $earliestSecs > $startSecs && ($until eq "" || $earliestSecs < $untilSecs) - } then { + } { # Test if the initial transition has been done. # If not, do it now. @@ -989,7 +989,7 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \ [dict create era CE year $year month 1 dayOfMonth 1] 2361222] set startSecs [expr { - [dict get $date julianDay] * wide(86400) - 210866803200 + [dict get $date julianDay] * wide(86400) - 210866803200 - $stdGMTOffset - $DSTOffset }] diff --git a/tools/tclsh.svg b/tools/tclsh.svg new file mode 100644 index 0000000..34d45a4 --- /dev/null +++ b/tools/tclsh.svg @@ -0,0 +1,67 @@ +<?xml version="1.0" encoding="UTF-8" standalone="no"?> +<svg + xmlns:dc="http://purl.org/dc/elements/1.1/" + xmlns:cc="http://creativecommons.org/ns#" + xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" + xmlns:svg="http://www.w3.org/2000/svg" + xmlns="http://www.w3.org/2000/svg" + xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" + xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" + width="256" + height="256" + id="svg2309" + sodipodi:version="0.32" + inkscape:version="0.46" + sodipodi:modified="true" + version="1.0" + sodipodi:docname="tcl.svg" + inkscape:output_extension="org.inkscape.output.svg.inkscape" + inkscape:export-filename="tcl.png" + inkscape:export-xdpi="8.4399996" + inkscape:export-ydpi="8.4399996"> + <defs + id="defs2311" /> + <sodipodi:namedview + id="base" + pagecolor="#ffffff" + bordercolor="#666666" + borderopacity="1.0" + gridtolerance="10000" + guidetolerance="10" + objecttolerance="10" + inkscape:pageopacity="0.0" + inkscape:pageshadow="2" + inkscape:zoom="1.8096812" + inkscape:cx="110.83011" + inkscape:cy="132.34375" + inkscape:document-units="px" + inkscape:current-layer="layer1" + inkscape:window-width="993" + inkscape:window-height="669" + inkscape:window-x="5" + inkscape:window-y="49" + showgrid="false" /> + <g + inkscape:label="Layer 1" + inkscape:groupmode="layer" + id="layer1" + transform="translate(-311.79308,-365.73272)"> + <g + id="g2392" + transform="matrix(0.9671783,0,0,0.9671783,10.08245,12.003966)"> + <path + id="path4426" + d="M 499.58925,374.01397 C 499.97085,397.34606 499.27848,420.4264 479.08925,442.35772 L 478.33925,443.20147 L 479.46425,443.20147 L 487.71425,443.32647 C 474.30875,471.21288 465.58677,499.02017 446.308,526.79522 L 445.6205,527.79522 L 446.808,527.57647 L 456.9955,525.63897 C 449.7786,543.94928 437.43792,556.07176 424.058,560.13897 C 420.3754,508.57034 446.11026,463.05191 467.96425,417.67022 C 467.98435,417.62848 468.00666,417.58696 468.02675,417.54522 L 467.21425,416.98272 C 431.42858,456.99623 415.30305,513.43153 409.21425,559.98272 C 397.08579,553.13549 393.04346,544.06962 388.933,531.73272 L 397.40175,535.29522 L 398.27675,535.67022 L 398.08925,534.73272 C 391.65291,506.11299 401.64573,485.57026 411.33925,458.57647 L 418.308,463.23272 L 419.1205,463.79522 L 419.08925,462.82647 C 418.54325,440.89528 433.31028,418.87866 452.90175,399.23272 L 455.6205,406.51397 L 455.9955,407.48272 L 456.52675,406.57647 L 462.4955,396.63897 L 462.52675,396.57647 C 472.37862,383.00695 482.79421,378.58965 499.58925,374.01397 z" + style="opacity:1;fill:#3465a4;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;display:inline" /> + <path + sodipodi:nodetypes="ccccccccccccccccccccccc" + id="path7600" + d="M 499.59927,374.00103 C 482.86154,378.56724 472.31963,383.0333 462.48689,396.57647 L 462.45564,396.63897 L 456.48689,406.57647 L 455.95564,407.48272 L 455.58064,406.51397 L 452.86189,399.23272 C 433.27042,418.87866 418.50339,440.89528 419.04939,462.82647 L 419.08064,463.79522 L 418.26814,463.23272 L 411.29939,458.57647 C 401.60587,485.57026 391.61305,506.11299 398.04939,534.73272 L 398.23689,535.67022 L 397.36189,535.29522 L 388.98689,531.76397 C 389.01386,531.93545 389.0525,532.09443 389.08064,532.26397 C 393.12974,544.32172 397.22634,553.23735 409.17439,559.98272 C 409.64601,556.37703 410.17162,552.69478 410.76814,548.98272 C 396.17755,514.81858 408.84232,489.70162 414.61189,467.10772 L 423.48689,472.23272 C 422.26097,451.07724 434.68113,428.26233 450.83064,408.35772 L 455.51814,416.60772 C 467.52689,391.90688 477.02451,381.99197 499.59927,374.00103 z" + style="opacity:1;fill:#eeeeec;fill-opacity:1;fill-rule:evenodd;stroke:#eff1cb;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;display:inline" /> + <path + style="opacity:1;fill:#000000;fill-opacity:1;fill-rule:evenodd;stroke:none;stroke-width:1px;stroke-linecap:butt;stroke-linejoin:miter;stroke-opacity:1;display:inline" + d="M 505.90485,365.73272 L 505.3736,365.82647 C 485.689,369.25998 466.41815,376.49266 457.96735,393.79522 L 454.40485,387.57647 L 454.09235,387.01397 L 453.6236,387.48272 C 443.92989,396.7586 433.52309,408.77328 425.84235,420.57647 C 418.63263,431.65584 413.85062,442.49956 414.3736,450.79522 L 409.34235,444.51397 L 408.84235,443.88897 L 408.4986,444.60772 C 402.37467,457.83671 396.19429,474.11179 392.4986,489.04522 C 388.9946,503.20407 387.73979,516.09228 390.9986,524.20147 L 382.71735,519.38897 L 382.02985,518.98272 L 381.96735,519.79522 C 380.40824,543.41224 390.00555,554.68855 401.02985,565.57647 L 391.84235,567.85772 L 389.9986,568.32647 L 391.84235,568.82647 C 397.11688,570.2558 402.11758,571.86507 405.59235,574.54522 C 409.06712,577.22537 411.06333,580.91104 410.46735,586.79522 L 410.46735,586.82647 L 410.46735,612.32647 L 410.46735,612.48272 L 410.5611,612.60772 L 422.0611,629.10772 L 422.96735,630.42022 L 422.96735,628.82647 L 422.96735,589.95147 C 424.48916,583.40757 426.27542,578.90352 428.84235,575.92022 C 431.40928,572.93692 434.74946,571.40505 439.52985,570.82647 L 441.2486,570.60772 L 439.6861,569.88897 L 433.6236,567.01397 C 448.07909,558.31023 464.26865,536.97467 468.52985,516.70147 L 468.71735,515.88897 L 467.9361,516.10772 L 460.4361,518.13897 C 467.09909,511.88271 473.81127,499.48743 480.1861,485.04522 C 486.94715,469.72802 493.25982,452.38054 498.4361,438.51397 L 498.71735,437.76397 L 497.9361,437.82647 L 492.15485,438.23272 C 499.30195,430.64691 503.27438,418.11982 505.21735,404.88897 C 507.23962,391.11815 507.0977,376.61792 505.96735,366.26397 L 505.90485,365.73272 z M 500.46735,374.01397 C 500.84895,397.34606 500.15658,420.4264 479.96735,442.35772 L 479.21735,443.20147 L 480.34235,443.20147 L 488.59235,443.32647 C 475.18685,471.21288 466.46487,499.02017 447.1861,526.79522 L 446.4986,527.79522 L 447.6861,527.57647 L 457.8736,525.63897 C 450.6567,543.94928 438.31602,556.07176 424.9361,560.13897 C 421.2535,508.57034 446.98836,463.05191 468.84235,417.67022 C 468.86245,417.62848 468.88476,417.58696 468.90485,417.54522 L 468.09235,416.98272 C 432.30668,456.99623 416.18115,513.43153 410.09235,559.98272 C 397.96389,553.13549 393.92156,544.06962 389.8111,531.73272 L 398.27985,535.29522 L 399.15485,535.67022 L 398.96735,534.73272 C 392.53101,506.11299 402.52383,485.57026 412.21735,458.57647 L 419.1861,463.23272 L 419.9986,463.79522 L 419.96735,462.82647 C 419.42135,440.89528 434.18838,418.87866 453.77985,399.23272 L 456.4986,406.51397 L 456.8736,407.48272 L 457.40485,406.57647 L 463.3736,396.63897 L 463.40485,396.57647 C 473.25672,383.00695 483.67231,378.58965 500.46735,374.01397 z" + id="path2177" /> + </g> + </g> +</svg> diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl new file mode 100644 index 0000000..c0c6a75 --- /dev/null +++ b/tools/tcltk-man2html-utils.tcl @@ -0,0 +1,1613 @@ +## +## Utility functions for Man->HTML converter. Note that these +## functions are specifically intended to work with the format as used +## by Tcl and Tk; they do not cope with arbitrary nroff markup. +## +## Copyright (c) 1995-1997 Roger E. Critchlow Jr +## Copyright (c) 2004-2011 Donal K. Fellows + +set ::manual(report-level) 1 + +proc manerror {msg} { + global manual + set name {} + set subj {} + set procname [lindex [info level -1] 0] + if {[info exists manual(name)]} { + set name $manual(name) + } + if {[info exists manual(section)] && [string length $manual(section)]} { + puts stderr "$name: $manual(section): $procname: $msg" + } else { + puts stderr "$name: $procname: $msg" + } +} + +proc manreport {level msg} { + global manual + if {$level < $manual(report-level)} { + uplevel 1 [list manerror $msg] + } +} + +proc fatal {msg} { + global manual + uplevel 1 [list manerror $msg] + exit 1 +} + +## +## templating +## +proc indexfile {} { + if {[info exists ::TARGET] && $::TARGET eq "devsite"} { + return "index.tml" + } else { + return "contents.htm" + } +} + +proc copyright {copyright {level {}}} { + # We don't actually generate a separate copyright page anymore + #set page "${level}copyright.htm" + #return "<A HREF=\"$page\">Copyright</A> © [htmlize-text [lrange $copyright 2 end]]" + # obfuscate any email addresses that may appear in name + set who [string map {@ (at)} [lrange $copyright 2 end]] + return "Copyright © [htmlize-text $who]" +} + +proc copyout {copyrights {level {}}} { + set out "<div class=\"copy\">" + foreach c $copyrights { + append out "[copyright $c $level]\n" + } + append out "</div>" + return $out +} + +proc CSS {{level ""}} { + return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n" +} + +proc DOCTYPE {} { + return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" +} + +proc htmlhead {title header args} { + set level "" + if {[lindex $args end] eq "../[indexfile]"} { + # XXX hack - assume same level for CSS file + set level "../" + } + set out "[DOCTYPE]\n<HTML>\n<HEAD><TITLE>$title</TITLE>\n[CSS $level]</HEAD>\n" + foreach {uptitle url} $args { + set header "<a href=\"$url\">$uptitle</a> <small>></small> $header" + } + append out "<BODY><H2>$header</H2>" + global manual + if {[info exists manual(subheader)]} { + set subs {} + foreach {name subdir} $manual(subheader) { + if {$name eq $title} { + lappend subs $name + } else { + lappend subs "<A HREF=\"${level}$subdir/[indexfile]\">$name</A>" + } + } + append out "\n<H3>[join $subs { | }]</H3>" + } + return $out +} + +## +## parsing +## +proc unquote arg { + return [string map [list \" {}] $arg] +} + +proc parse-directive {line codename restname} { + upvar 1 $codename code $restname rest + return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] +} + +proc htmlize-text {text {charmap {}}} { + # contains some extras for use in nroff->html processing + # build on the list passed in, if any + lappend charmap \ + "–" "–" \ + {&} {&} \ + {\\} "\" \ + {\e} "\" \ + {\ } { } \ + {\|} { } \ + {\0} { } \ + \" {"} \ + {<} {<} \ + {>} {>} \ + \u201c "“" \ + \u201d "”" + + return [string map $charmap $text] +} + +proc process-text {text} { + global manual + # preprocess text; note that this is an incomplete map, and will probably + # need to have things added to it as the manuals expand to use them. + set charmap [list \ + {\&} "\t" \ + {\%} {} \ + "\\\n" "\n" \ + {\(+-} "±" \ + {\(co} "©" \ + {\(em} "—" \ + {\(fm} "′" \ + {\(mu} "×" \ + {\(mi} "−" \ + {\(->} "<font size=\"+1\">→</font>" \ + {\fP} {\fR} \ + {\.} . \ + {\(bu} "•" \ + {\*(qo} "ô" \ + ] + lappend charmap {\-\|\-} -- ; # two hyphens + lappend charmap {\-} - ; # a hyphen + + set text [htmlize-text $text $charmap] + # General quoted entity + regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text + while {[string first "\\" $text] >= 0} { + # C R + if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \ + {\1<TT>\2</TT>\3} text]} continue + # B R + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \ + {\1<B>\2</B>\3} text]} continue + # B I + if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \ + {\1<B>\2</B>\\fI\3} text]} continue + # I R + if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \ + {\1<I>\2</I>\3} text]} continue + # I B + if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \ + {\1<I>\2</I>\\fB\3} text]} continue + # B B, I I, R R + 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 "impotent font change: $text" + set text $ntext + continue + } + # unrecognized + manerror "uncaught backslash: $text" + set text [string map [list "\\" "\"] $text] + } + return $text +} + +## +## pass 2 text input and matching +## +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 1 $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 1 $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 {$arg eq $targ} { + incr nback + incr manual(text-pointer) + continue + } + if {[regexp {^@(\w+)$} $arg all name]} { + upvar 1 $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 1 $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] +} + +## +## pass 2 output +## +proc man-puts {text} { + global manual + lappend manual(output-$manual(wing-file)-$manual(name)) $text +} + +## +## build hypertext links to tables of contents +## +proc long-toc {text} { + global manual + set here M[incr manual(section-toc-n)] + set manual($manual(name)-id-$text) $here + 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 + # Special case handling, oh we hate it but must do it + if {[string match "*OPTIONS" $manual(section)]} { + if {$manual(name) ne "ttk_widget" && ($manual(name) ne "ttk_entry" || + ![string match validate* $name])} { + # link the defined option into the long table of contents + set link [long-toc "$switch, $name, $class"] + regsub -- "$switch, $name, $class" $link "$switch" link + return $link + } + } elseif {"$manual(name):$manual(section)" ne "options:DESCRIPTION"} { + error "option-toc in $manual(name) section $manual(section)" + } + + # link the defined standard option to the long table of contents and make + # a target for the standard option references from other man pages. + + set first [lindex $switch 0] + set here M$first + set there L[incr manual(long-toc-n)] + set manual(standard-option-$manual(name)-$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>" +} + +proc std-option-toc {name page} { + global manual + if {[info exists manual(standard-option-$page-$name)]} { + lappend manual(section-toc) <DD>$manual(standard-option-$page-$name) + return $manual(standard-option-$page-$name) + } + manerror "missing reference to \"$name\" in $page.n" + 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=\"$page.htm#$other\">$name</A>" + return "<A HREF=\"$page.htm#$other\">$name</A>" +} + +## +## process the widget option section +## in widget and options man pages +## +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 { + lassign $rest switch name class + } + 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" + } + 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> + + if {[next-op-is .RS rest]} { + while {[more-text]} { + set line [next-text] + if {[is-a-directive $line]} { + split-directive $line code rest + switch -exact -- $code { + .RE { + break + } + .SH - .SS { + manerror "unbalanced .RS at section end" + backup-text 1 + break + } + default { + output-directive $line + } + } + } else { + man-puts $line + } + } + } + } + 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><DD> + while {[more-text]} { + set line [next-text] + if {[is-a-directive $line]} { + split-directive $line code rest + switch -exact -- $code { + .RE { + break + } + .SH - .SS { + 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><DD> + while {[more-text]} { + set line [next-text] + if {[is-a-directive $line]} { + split-directive $line code rest + if {$code eq ".IP" && $rest eq {}} { + man-puts "<P>" + continue + } + if {$code in {.br .DS .RS}} { + output-directive $line + } else { + backup-text 1 + break + } + } else { + man-puts $line + } + } + man-puts </DL> + } else { + # labelled list, make contents + if {$context ne ".SH" && $context ne ".SS"} { + man-puts <P> + } + set dl "<DL class=\"[string tolower $manual(section)]\">" + set enddl "</DL>" + if {$code eq ".IP"} { + if {[regexp {^\[[\da-f]+\]|\(?[\da-f]+\)$} $rest]} { + set dl "<OL class=\"[string tolower $manual(section)]\">" + set enddl "</OL>" + } elseif {"•" eq $rest} { + set dl "<UL class=\"[string tolower $manual(section)]\">" + set enddl "</UL>" + } + } + man-puts $dl + lappend manual(section-toc) $dl + backup-text 1 + set accept_RE 0 + set para {} + 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 {$manual(section) eq "ARGUMENTS"} { + man-puts "$para<DT>$rest<DD>" + } elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} { + man-puts "$para<LI value=\"$value\">" + } elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} { + man-puts "$para<LI value=\"$value\">" + } elseif {"•" eq $rest} { + man-puts "$para<LI>" + } else { + man-puts "$para<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 "$para<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 "$enddl<P>$rest$dl" + backup-text 1 + set para {} + break + } + 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 + } + set para <P> + } + 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) "<DL><DD>$head — $tail</DD></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 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 "<A HREF=\"#$manual($manname-id-$ref)\">$ref</A>" + } 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 "<A HREF=\"../$manual(name-$name).htm\">$ref</A>" + } + } + 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 "<A HREF=\"../$tcl_ref.htm\">$ref</A>" + } + 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 "<A HREF=\"../$tk_ref.htm\">$ref</A>" + } + if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} { + set tcl_ref [lindex $manref $tcl_i] + return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" + } + 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 "<A HREF=\"../$manref.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 + set result "" + + while 1 { + ## + ## 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 - EXPENSIVE - and accumulate a list + ## + unset -nocomplain offsets + foreach {name pattern} { + anchor {<A } end-anchor {</A>} + quote {``} end-quote {''} + bold {<B>} end-bold {</B>} + 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 {<A HREF="&">&</A>} body + append result <B> [cross-reference $body] </B> + 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 "<A HREF=\"$url\">" $url "</A>" + 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 <HR> + } + .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 "<H3>[long-toc $manual(section)]</H3>" + } else { + man-puts "<H4>[long-toc $manual(section)]</H4>" + } + # 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) <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 .SS rest] + || [next-op-is .BE rest] + || [next-op-is .SO rest] + } { + backup-text 1 + break + } + if {[next-op-is .sp rest]} { + #man-puts <P> + 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 <TT>$spaces</TT> + } + man-puts $spaces$more<BR> + if {$manual(wing-file) in {TclLib TkLib}} { + lappend manual(section-toc) <DD>$more + } + } + } + lappend manual(section-toc) </DL> + 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 {^<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 + } + 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 "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>" + } + 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 <DL> + lappend manual(section-toc) <DL> + foreach optionpair [lsort -dictionary -index 0 $optslist] { + lassign $optionpair option targetPage + man-puts "<DT><B>[std-option-toc $option $targetPage]</B>" + } + man-puts </DL> + lappend manual(section-toc) </DL> + } + .OP { + output-widget-options $rest + return + } + .IP { + output-IP-list .IP .IP $rest + return + } + .PP - .sp { + man-puts <P> + } + .RS { + output-RS-list + return + } + .br { + man-puts <BR> + return + } + .DS { + if {[next-op-is .ta rest]} { + # skip the leading .ta directive if it is there + } + if {[match-text @stuff .DE]} { + set td "<td><p class=\"tablecell\">" + set bodyText [string map [list \n <tr>$td \t $td] \n$stuff] + man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>" + #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 + } + .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" + } + } + .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] +} + +## +## foreach of the man pages in the section specified by +## sectionDescriptor, convert manpages into hypertext in +## the directory specified by outputDir. +## +proc make-manpage-section {outputDir sectionDescriptor} { + global manual overall_title tcltkdesc verbose + global excluded_pages forced_index_pages process_first_patterns + + set LQ \u201c + set RQ \u201d + + lassign $sectionDescriptor \ + manual(wing-glob) \ + manual(wing-name) \ + manual(wing-file) \ + manual(wing-description) + set manual(wing-copyrights) {} + makedirhier $outputDir/$manual(wing-file) + set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w] + # whistle + puts stderr "scanning section $manual(wing-name)" + # put the entry for this section into the short table of contents + puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>" + # initialize the wing table of contents + puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \ + $manual(wing-name) $overall_title "../[indexfile]"] + # initialize the short table of contents for this section + set manual(wing-toc) {} + # initialize the man directory for this section + makedirhier $outputDir/$manual(wing-file) + # initialize the long table of contents for this section + set manual(long-toc-n) 1 + # get the manual pages for this section + set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]] + # 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 of processing queue" + set manual(pages) \ + [linsert [lreplace $manual(pages) $n $n] 0 $f] + } + } + # set manual(pages) [lrange $manual(pages) 0 5] + foreach manual_page $manual(pages) { + set manual(page) [file normalize $manual_page] + # whistle + if {$verbose} { + puts stderr "scanning page $manual(page)" + } else { + puts -nonewline stderr . + } + set manual(tail) [file tail $manual(page)] + set manual(name) [file root $manual(tail)] + set manual(section) {} + if {$manual(name) in $excluded_pages} { + # obsolete + if {!$verbose} { + puts stderr "" + } + 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) + lappend manual(all-page-domains) $manual(wing-name) + manreport 100 $manual(name) + while {[gets $manual(infp) line] >= 0} { + manreport 100 $line + if {[regexp {^[`'][/\\]} $line]} { + if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} { + lappend manual(copyrights) $copyright + } + # comment + continue + } + if {"$line" eq {'}} { + # comment + continue + } + if {![parse-directive $line code rest]} { + addbuffer $line + continue + } + switch -exact -- $code { + .if - .nr - .ti - .in - .ie - .el - + .ad - .na - .so - .ne - .AS - .VE - .VS - . { + # ignore + continue + } + } + switch -exact -- $code { + .SH - .SS { + flushbuffer + if {[llength $rest] == 0} { + gets $manual(infp) rest + } + lappend manual(text) "$code [unquote $rest]" + } + .TH { + flushbuffer + lappend manual(text) "$code [unquote $rest]" + } + .QW { + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote afterwards + addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards] + } + .PQ { + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + inQuote punctuation afterwards + addbuffer ( $LQ [unquote $inQuote] $RQ \ + [unquote $punctuation] ) [unquote $afterwards] + } + .QR { + lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \ + rangeFrom rangeTo afterwards + addbuffer $LQ [unquote $rangeFrom] "–" \ + [unquote $rangeTo] $RQ [unquote $afterwards] + } + .MT { + addbuffer $LQ$RQ + } + .HS - .UL - .ta { + flushbuffer + lappend manual(text) "$code [unquote $rest]" + } + .BS - .BE - .br - .fi - .sp - .nf { + flushbuffer + if {$rest ne ""} { + if {!$verbose} { + puts stderr "" + } + manerror "unexpected argument: $line" + } + lappend manual(text) $code + } + .AP { + flushbuffer + lappend manual(text) [concat .IP [process-text \ + "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]] + } + .IP { + flushbuffer + regexp {^(.*) +\d+$} $rest all rest + lappend manual(text) ".IP [process-text \ + [unquote [string trim $rest]]]" + } + .TP { + flushbuffer + while {[is-a-directive [set next [gets $manual(infp)]]]} { + if {!$verbose} { + puts stderr "" + } + manerror "ignoring $next after .TP" + } + if {"$next" ne {'}} { + lappend manual(text) ".IP [process-text $next]" + } + } + .OP { + flushbuffer + lassign $rest cmdName dbName dbClass + lappend manual(text) [concat .OP [process-text \ + "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]] + } + .PP - .LP { + flushbuffer + lappend manual(text) {.PP} + } + .RS { + flushbuffer + incr manual(.RS) + lappend manual(text) $code + } + .RE { + flushbuffer + incr manual(.RS) -1 + lappend manual(text) $code + } + .SO { + flushbuffer + incr manual(.SO) + if {[llength $rest] == 0} { + lappend manual(text) "$code options" + } else { + lappend manual(text) "$code [unquote $rest]" + } + } + .SE { + flushbuffer + incr manual(.SO) -1 + lappend manual(text) $code + } + .DS { + flushbuffer + incr manual(.DS) + lappend manual(text) $code + } + .DE { + flushbuffer + incr manual(.DS) -1 + lappend manual(text) $code + } + .CS { + flushbuffer + incr manual(.CS) + lappend manual(text) $code + } + .CE { + flushbuffer + incr manual(.CS) -1 + lappend manual(text) $code + } + .de { + while {[gets $manual(infp) line] >= 0} { + if {[string match "..*" $line]} { + break + } + } + } + .. { + if {!$verbose} { + puts stderr "" + } + error "found .. outside of .de" + } + default { + if {!$verbose} { + puts stderr "" + } + flushbuffer + manerror "unrecognized format directive: $line" + } + } + } + flushbuffer + close $manual(infp) + # fixups + if {$manual(.RS) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .RS .RE" + } + if {$manual(.DS) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .DS .DE" + } + if {$manual(.CS) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .CS .CE" + } + if {$manual(.SO) != 0} { + if {!$verbose} { + puts stderr "" + } + puts "unbalanced .SO .SE" + } + # output conversion + open-text + set haserror 0 + if {[next-op-is .HS rest]} { + set manual($manual(wing-file)-$manual(name)-title) \ + "[join [lrange $rest 1 end] { }] [lindex $rest 0] manual page" + } elseif {[next-op-is .TH rest]} { + set manual($manual(wing-file)-$manual(name)-title) \ + "[lindex $rest 0] manual page - [join [lrange $rest 4 end] { }]" + } else { + set haserror 1 + if {!$verbose} { + puts stderr "" + } + manerror "no .HS or .TH record found" + } + if {!$haserror} { + while {[more-text]} { + set line [next-text] + if {[is-a-directive $line]} { + output-directive $line + } else { + man-puts $line + } + } + man-puts [copyout $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>] + } + if {!$verbose} { + puts stderr "" + } + + # + # make the wing table of contents for the section + # + set width 0 + foreach name $manual(wing-toc) { + if {[string length $name] > $width} { + set width [string length $name] + } + } + set perline [expr {118 / $width}] + set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] + set n 0 + catch {unset rows} + foreach name [lsort -dictionary $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> </td>" + 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> + + # + # insert wing copyrights + # + 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)] +} + +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 diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index c6932d0..585d76a 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -1,8 +1,6 @@ -#!/bin/sh -# The next line is executed by /bin/sh, but not tcl \ -exec tclsh "$0" ${1+"$@"} +#!/usr/bin/env tclsh -package require Tcl 8.5 +package require Tcl 8.6 # Convert Ousterhout format man pages into highly crosslinked hypertext. # @@ -16,17 +14,23 @@ package require Tcl 8.5 # try to use this, you'll be very much on your own. # # Copyright (c) 1995-1997 Roger E. Critchlow Jr +# Copyright (c) 2004-2010 Donal K. Fellows -set Version "0.40" - +regexp {\d+\.\d+} {$Revision: 1.49 $} ::Version set ::CSSFILE "docs.css" +## +## Source the utility functions that provide most of the +## implementation of the transformation from nroff to html. +## +source [file join [file dirname [info script]] tcltk-man2html-utils.tcl] + proc parse_command_line {} { global argv Version # These variables determine where the man pages come from and where # the converted pages go to. - global tcltkdir tkdir tcldir webdir build_tcl build_tk + global tcltkdir tkdir tcldir webdir build_tcl build_tk verbose # Set defaults based on original code. set tcltkdir ../.. @@ -35,6 +39,7 @@ proc parse_command_line {} { set webdir ../html set build_tcl 0 set build_tk 0 + set verbose 0 # Default search version is a glob pattern set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}} @@ -61,6 +66,7 @@ proc parse_command_line {} { puts " --tcl build tcl help" puts " --tk build tk help" puts " --useversion version of tcl/tk to search for" + puts " --verbose whether to print longer messages" exit 0 } @@ -87,6 +93,10 @@ proc parse_command_line {} { set build_tk 1 } + --verbose=* { + set verbose [string range $option \ + [string length --verbose=] end] + } default { puts stderr "tcltk-man-html: unrecognized option -- `$option'" exit 1 @@ -113,7 +123,7 @@ proc parse_command_line {} { if {$build_tk} { # Find Tk. set tkdir [lindex [lsort [glob -nocomplain -tails -type d \ - -directory $tcltkdir tk$useversion]] end] + -directory $tcltkdir tk$useversion]] end] if {$tkdir eq ""} { puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir" exit 1 @@ -121,6 +131,8 @@ proc parse_command_line {} { puts "using Tk source directory $tkdir" } + puts "verbose messages are [expr {$verbose ? {on} : {off}}]" + # the title for the man pages overall global overall_title set overall_title "" @@ -139,1676 +151,144 @@ proc parse_command_line {} { proc capitalize {string} { return [string toupper $string 0] } - -## + ## +## Returns the style sheet. ## -set manual(report-level) 1 - -proc manerror {msg} { - global manual - set name {} - set subj {} - set procname [lindex [info level -1] 0] - if {[info exists manual(name)]} { - set name $manual(name) - } - if {[info exists manual(section)] && [string length $manual(section)]} { - puts stderr "$name: $manual(section): $procname: $msg" - } else { - puts stderr "$name: $procname: $msg" - } -} - -proc manreport {level msg} { - global manual - if {$level < $manual(report-level)} { - uplevel 1 [list manerror $msg] - } -} - -proc fatal {msg} { - global manual - uplevel 1 [list manerror $msg] - exit 1 -} - -## -## templating -## -proc indexfile {} { - if {[info exists ::TARGET] && $::TARGET eq "devsite"} { - return "index.tml" - } else { - return "contents.htm" - } -} -proc copyright {copyright {level {}}} { - # We don't actually generate a separate copyright page anymore - #set page "${level}copyright.htm" - #return "<A HREF=\"$page\">Copyright</A> © [htmlize-text [lrange $copyright 2 end]]" - # obfuscate any email addresses that may appear in name - set who [string map {@ (at)} [lrange $copyright 2 end]] - return "Copyright © [htmlize-text $who]" -} -proc copyout {copyrights {level {}}} { - set out "<div class=\"copy\">" - foreach c $copyrights { - append out "[copyright $c $level]\n" - } - append out "</div>" - return $out -} -proc CSS {{level ""}} { - return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n" +proc css-style args { + upvar 1 style style + set body [uplevel 1 [list subst [lindex $args end]]] + set tokens [join [lrange $args 0 end-1] ", "] + append style $tokens " \{" $body "\}\n" } -proc DOCTYPE {} { - return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" -} -proc htmlhead {title header args} { - set level "" - if {[lindex $args end] eq "../[indexfile]"} { - # XXX hack - assume same level for CSS file - set level "../" - } - set out "[DOCTYPE]\n<HTML>\n<HEAD><TITLE>$title</TITLE>\n[CSS $level]</HEAD>\n" - foreach {uptitle url} $args { - set header "<a href=\"$url\">$uptitle</a> <small>></small> $header" - } - append out "<BODY><H2>$header</H2>" - global manual - if {[info exists manual(subheader)]} { - set subs {} - foreach {name subdir} $manual(subheader) { - if {$name eq $title} { - lappend subs $name - } else { - lappend subs "<A HREF=\"${level}$subdir/[indexfile]\">$name</A>" - } - } - append out "\n<H3>[join $subs { | }]</H3>" - } - return $out -} -proc gencss {} { +proc css-stylesheet {} { set hBd "1px dotted #11577b" - return " -body, div, p, th, td, li, dd, ul, ol, dl, dt, blockquote { - font-family: Verdana, sans-serif; -} - -pre, code { font-family: 'Courier New', Courier, monospace; } - -pre { - background-color: #f6fcec; - border-top: 1px solid #6A6A6A; - border-bottom: 1px solid #6A6A6A; - padding: 1em; - overflow: auto; -} - -body { - background-color: #FFFFFF; - font-size: 12px; - line-height: 1.25; - letter-spacing: .2px; - padding-left: .5em; -} - -h1, h2, h3, h4 { - font-family: Georgia, serif; - padding-left: 1em; - margin-top: 1em; -} - -h1 { - font-size: 18px; - color: #11577b; - border-bottom: $hBd; - margin-top: 0px; -} - -h2 { - font-size: 14px; - color: #11577b; - background-color: #c5dce8; - padding-left: 1em; - border: 1px solid #6A6A6A; -} - -h3, h4 { - color: #1674A4; - background-color: #e8f2f6; - border-bottom: $hBd; - border-top: $hBd; -} - -h3 { font-size: 12px; } -h4 { font-size: 11px; } - -.keylist dt, .arguments dt { - width: 20em; - float: left; - padding: 2px; - border-top: 1px solid #999; -} - -.keylist dt { font-weight: bold; } - -.keylist dd, .arguments dd { - margin-left: 20em; - padding: 2px; - border-top: 1px solid #999; -} - -.copy { - background-color: #f6fcfc; - white-space: pre; - font-size: 80%; - border-top: 1px solid #6A6A6A; - margin-top: 2em; -} -" -} - -## -## parsing -## -proc unquote arg { - return [string map [list \" {}] $arg] -} - -proc parse-directive {line codename restname} { - upvar 1 $codename code $restname rest - return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest] -} - -proc htmlize-text {text {charmap {}}} { - # contains some extras for use in nroff->html processing - # build on the list passed in, if any - lappend charmap \ - {&} {&} \ - {\\} "\" \ - {\e} "\" \ - {\ } { } \ - {\|} { } \ - {\0} { } \ - \" {"} \ - {<} {<} \ - {>} {>} \ - \u201c "“" \ - \u201d "”" - - return [string map $charmap $text] -} - -proc process-text {text} { - global manual - # preprocess text - set charmap [list \ - {\&} "\t" \ - {\%} {} \ - "\\\n" "\n" \ - {\(+-} "±" \ - {\(co} "©" \ - {\(em} "—" \ - {\(fm} "′" \ - {\(mu} "×" \ - {\(->} "<font size=\"+1\">→</font>" \ - {\fP} {\fR} \ - {\.} . \ - {\(bu} "•" \ - ] - lappend charmap {\o'o^'} {ô} ; # o-circumflex in re_syntax.n - lappend charmap {\-\|\-} -- ; # two hyphens - lappend charmap {\-} - ; # a hyphen - - set text [htmlize-text $text $charmap] - # General quoted entity - regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text - while {[string first "\\" $text] >= 0} { - # C R - if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \ - {\1<TT>\2</TT>\3} text]} continue - # B R - if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \ - {\1<B>\2</B>\3} text]} continue - # B I - if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \ - {\1<B>\2</B>\\fI\3} text]} continue - # I R - if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \ - {\1<I>\2</I>\3} text]} continue - # I B - if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \ - {\1<I>\2</I>\\fB\3} text]} continue - # B B, I I, R R - 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] - } then { - manerror "impotent font change: $text" - set text $ntext - continue - } - # unrecognized - manerror "uncaught backslash: $text" - set text [string map [list "\\" "\"] $text] - } - return $text -} -## -## pass 2 text input and matching -## -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 1 $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 1 $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 {$arg eq $targ} { - incr nback - incr manual(text-pointer) - continue - } - if {[regexp {^@(\w+)$} $arg all name]} { - upvar 1 $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 1 $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] -} -## -## pass 2 output -## -proc man-puts {text} { - global manual - lappend manual(output-$manual(wing-file)-$manual(name)) $text -} - -## -## build hypertext links to tables of contents -## -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 match "*OPTIONS" $manual(section)]} { - if { - $manual(name) ne "ttk_widget" - && $manual(section) ne "WIDGET-SPECIFIC OPTIONS" - } then { - # link the defined option into the long table of contents - set link [long-toc "$switch, $name, $class"] - regsub -- "$switch, $name, $class" $link "$switch" link - return $link - } - } elseif {"$manual(name):$manual(section)" ne "options:DESCRIPTION"} { - error "option-toc in $manual(name) section $manual(section)" - } - - # link the defined standard option to the long table of contents and make - # a target for the standard option references from other man pages. - - set first [lindex $switch 0] - set here M$first - set there L[incr manual(long-toc-n)] - set manual(standard-option-$manual(name)-$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>" -} -proc std-option-toc {name page} { - global manual - if {[info exists manual(standard-option-$page-$name)]} { - lappend manual(section-toc) <DD>$manual(standard-option-$page-$name) - return $manual(standard-option-$page-$name) - } - manerror "missing reference to \"$name\" in $page.n" - 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=\"$page.htm#$other\">$name</A>" - return "<A HREF=\"$page.htm#$other\">$name</A>" -} -## -## process the widget option section -## in widget and options man pages -## -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 { - lassign $rest switch name class - } - 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" - } - 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> - - if {[next-op-is .RS rest]} { - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - split-directive $line code rest - switch -exact -- $code { - .RE { - break - } - .SH - .SS { - manerror "unbalanced .RS at section end" - backup-text 1 - break - } - default { - output-directive $line - } - } - } else { - man-puts $line - } - } - } - } - 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><DD> - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - split-directive $line code rest - switch -exact -- $code { - .RE { - break - } - .SH - .SS { - 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><DD> - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - split-directive $line code rest - if {$code eq ".IP" && $rest eq {}} { - man-puts "<P>" - continue - } - if {$code in {.br .DS .RS}} { - output-directive $line - } else { - backup-text 1 - break - } - } else { - man-puts $line - } - } - man-puts </DL> - } else { - # labelled list, make contents - if {$context ne ".SH" && $context ne ".SS"} { - man-puts <P> - } - set dl "<DL class=\"[string tolower $manual(section)]\">" - man-puts $dl - lappend manual(section-toc) $dl - backup-text 1 - set accept_RE 0 - set para {} - 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 {$manual(section) eq "ARGUMENTS" || \ - [regexp {^\[\d+\]$} $rest]} { - man-puts "$para<DT>$rest<DD>" - } elseif {"•" eq $rest} { - man-puts "$para<DT><DD>$rest " - } else { - man-puts "$para<DT>[long-toc $rest]<DD>" - } - if {"$manual(name):$manual(section)" eq \ - "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 "$para<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 - set para {} - 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 - } - set para <P> - } - man-puts "$para</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</DD></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 {$ref eq "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] && \ - [info exists manual(name-$name)] && \ - $manual(tail) ne "$name.n"} { - return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>" - } - } - if {$lref in {stdin stdout stderr end}} { - # no good place to send these - # tcl tokens? - # also end - } - return $ref - } - ## - ## would be a self reference - ## - foreach name $manual(name-$lref) { - if {"$manual(wing-file)/$manual(name)" in $name} { - 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) eq "TclCmd" - || $manual(wing-file) eq "TclLib"} { - return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" - } - if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd" - || $manual(wing-file) eq "TkLib"} { - return "<A HREF=\"../$tk_ref.htm\">$ref</A>" - } - if {$lref eq "exit" && $manual(tail) eq "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 -exact -- $manual(tail) { - canvas.n { - if {$lref eq "focus"} { - upvar 1 tail tail - set clue [string first command $tail] - if {$clue < 0 || $clue > 5} { - return $ref - } - } - if {$lref in {bitmap image text}} { - return $ref - } - } - checkbutton.n - radiobutton.n { - if {$lref in {image}} { - return $ref - } - } - menu.n { - if {$lref in {checkbutton radiobutton}} { - return $ref - } - } - options.n { - if {$lref in {bitmap image set}} { - return $ref - } - } - regexp.n { - if {$lref in {string}} { - return $ref - } - } - source.n { - if {$lref in {text}} { - return $ref - } - } - history.n { - if {$lref in {exec}} { - return $ref - } - } - return.n { - if {$lref in {error continue break}} { - return $ref - } - } - scrollbar.n { - if {$lref in {set}} { - 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]) eq "tk"} { - set offsets [lreplace $offsets 1 1] - } - if {$invert([lindex $offsets 1]) eq "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]) eq "tk"} { - set offsets [lreplace $offsets 1 1] - } - if {$invert([lindex $offsets 1]) eq "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] - } - } -} -## -## process formatting directives -## -proc output-directive {line} { - global manual - # process format directive - split-directive $line code rest - switch -exact -- $code { - .BS - .BE { - # man-puts <HR> - } - .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 "<H3>[long-toc $manual(section)]</H3>" - } else { - man-puts "<H4>[long-toc $manual(section)]</H4>" - } - # some sections can simply free wheel their way through the text - # some sections can be processed in their own loops - switch -exact -- $manual(section) { - NAME { - if {$manual(tail) in {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3}} { - # these manual pages have two NAME sections - 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] - } then { - continue - } - if { - [next-op-is .SH rest] - || [next-op-is .SS rest] - || [next-op-is .BE rest] - || [next-op-is .SO rest] - } then { - backup-text 1 - break - } - if {[next-op-is .sp rest]} { - #man-puts <P> - continue - } - set more [next-text] - if {[is-a-directive $more]} { - manerror "in SYNOPSIS found $more" - backup-text 1 - break - } - foreach more [split $more \n] { - man-puts $more<BR> - if {$manual(wing-file) in {TclLib TkLib}} { - lappend manual(section-toc) <DD>$more - } - } - } - lappend manual(section-toc) </DL> - return - } - {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 {^<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] || [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 "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>" - } - 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 { - set targetPage $rest - if {[match-text @stuff .SE]} { - output-directive {.SH STANDARD OPTIONS} - set opts [split $stuff \n\t] - man-puts <DL> - lappend manual(section-toc) <DL> - foreach option [lsort -dictionary $opts] { - man-puts "<DT><B>[std-option-toc $option $targetPage]</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]} { - # skip the leading .ta directive if it is there - } - if {[match-text @stuff .DE]} { - set td "<td><p style=\"font-size:12px;padding-left:.5em;padding-right:.5em;\">" - set bodyText [string map [list \n <tr>$td \t $td] \n$stuff] - man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>" - #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 { - # these are tab stop settings for short tables - 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; # fix.me - } - 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" - } - } -} -## -## 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} { - if {![file isdirectory $dir] && \ - [catch {file mkdir $dir} error]} { - return -code error "cannot create directory $dir: $error" - } -} - -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) "" - } -} + css-style body div p th td li dd ul ol dl dt blockquote { + font-family: Verdana, sans-serif; + } + css-style pre code { + font-family: 'Courier New', Courier, monospace; + } + css-style pre { + background-color: #f6fcec; + border-top: 1px solid #6A6A6A; + border-bottom: 1px solid #6A6A6A; + padding: 1em; + overflow: auto; + } + css-style body { + background-color: #FFFFFF; + font-size: 12px; + line-height: 1.25; + letter-spacing: .2px; + padding-left: .5em; + } + css-style h1 h2 h3 h4 { + font-family: Georgia, serif; + padding-left: 1em; + margin-top: 1em; + } + css-style h1 { + font-size: 18px; + color: #11577b; + border-bottom: $hBd; + margin-top: 0px; + } + css-style h2 { + font-size: 14px; + color: #11577b; + background-color: #c5dce8; + padding-left: 1em; + border: 1px solid #6A6A6A; + } + css-style h3 h4 { + color: #1674A4; + background-color: #e8f2f6; + border-bottom: $hBd; + border-top: $hBd; + } + css-style h3 { + font-size: 12px; + } + css-style h4 { + font-size: 11px; + } + css-style ".keylist dt" ".arguments dt" { + width: 20em; + float: left; + padding: 2px; + border-top: 1px solid #999; + } + css-style ".keylist dt" { font-weight: bold; } + css-style ".keylist dd" ".arguments dd" { + margin-left: 20em; + padding: 2px; + border-top: 1px solid #999; + } + css-style .copy { + background-color: #f6fcfc; + white-space: pre; + font-size: 80%; + border-top: 1px solid #6A6A6A; + margin-top: 2em; + } + css-style .tablecell { + font-size: 12px; + padding-left: .5em; + padding-right: .5em; + } +} + ## ## foreach of the man directories specified by args ## convert manpages into hypertext in the directory ## specified by html. ## proc make-man-pages {html args} { - global manual overall_title tcltkdesc + 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 [gencss] + puts $cssfd [css-stylesheet] close $cssfd set manual(short-toc-n) 1 set manual(short-toc-fp) [open $html/[indexfile] w] puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title] puts $manual(short-toc-fp) "<DL class=\"keylist\">" set manual(merge-copyrights) {} + foreach arg $args { # preprocess to set up subheader for the rest of the files if {![llength $arg]} { continue } - set name [lindex $arg 1] - set file [lindex $arg 2] + lassign $arg -> name file + if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name -> pkg]} { + set name "$pkg Commands" + } elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name -> pkg]} { + set name "$pkg C API" + } lappend manual(subheader) $name $file } - foreach arg $args { - if {![llength $arg]} { - continue - } - 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)/[indexfile] w] - # whistle - puts stderr "scanning section $manual(wing-name)" - # put the entry for this section into the short table of contents - puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>" - # initialize the wing table of contents - puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \ - $manual(wing-name) $overall_title "../[indexfile]"] - # initialize the short table of contents for this section - set manual(wing-toc) {} - # initialize the man directory for this section - makedirhier $html/$manual(wing-file) - # initialize the long table of contents for this section - set manual(long-toc-n) 1 - # get the manual pages for this section - set manual(pages) [lsort -dictionary [glob $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]" - } - # set manual(pages) [lrange $manual(pages) 0 5] - set LQ \u201c - set RQ \u201d - foreach manual_page $manual(pages) { - set manual(page) $manual_page - # whistle - puts stderr "scanning page $manual(page)" - 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}} { - # obsolete - 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(copyrights) "Copyright © 1995-1997 Roger E. Critchlow Jr." - 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\)|\\\(co).*$} $line copyright]} { - lappend manual(copyrights) $copyright - } - # comment - continue - } - if {"$line" eq {'}} { - # comment - continue - } - if {![parse-directive $line code rest]} { - addbuffer $line - continue - } - switch -exact -- $code { - .ad - .na - .so - .ne - .AS - .VE - .VS - . { - # ignore - continue - } - } - switch -exact -- $code { - .SH - .SS { - flushbuffer - if {[llength $rest] == 0} { - gets $manual(infp) rest - } - lappend manual(text) "$code [unquote $rest]" - } - .TH { - flushbuffer - lappend manual(text) "$code [unquote $rest]" - } - .QW { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer $LQ [unquote [lindex $rest 0]] $RQ \ - [unquote [lindex $rest 1]] - } - .PQ { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer ( $LQ [unquote [lindex $rest 0]] $RQ \ - [unquote [lindex $rest 1]] ) \ - [unquote [lindex $rest 2]] - } - .QR { - set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] - addbuffer $LQ [unquote [lindex $rest 0]] - \ - [unquote [lindex $rest 1]] $RQ \ - [unquote [lindex $rest 2]] - } - .MT { - addbuffer $LQ$RQ - } - .HS - .UL - .ta { - flushbuffer - lappend manual(text) "$code [unquote $rest]" - } - .BS - .BE - .br - .fi - .sp - .nf { - flushbuffer - if {"$rest" ne {}} { - manerror "unexpected argument: $line" - } - lappend manual(text) $code - } - .AP { - flushbuffer - lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]] - } - .IP { - flushbuffer - regexp {^(.*) +\d+$} $rest all rest - lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]" - } - .TP { - flushbuffer - while {[is-a-directive [set next [gets $manual(infp)]]]} { - manerror "ignoring $next after .TP" - } - if {"$next" ne {'}} { - lappend manual(text) ".IP [process-text $next]" - } - } - .OP { - flushbuffer - lappend manual(text) [concat .OP [process-text \ - "\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]] - } - .PP - .LP { - flushbuffer - lappend manual(text) {.PP} - } - .RS { - flushbuffer - incr manual(.RS) - lappend manual(text) $code - } - .RE { - flushbuffer - incr manual(.RS) -1 - lappend manual(text) $code - } - .SO { - flushbuffer - incr manual(.SO) - if {[llength $rest] == 0} { - lappend manual(text) "$code options" - } else { - lappend manual(text) "$code [unquote $rest]" - } - } - .SE { - flushbuffer - incr manual(.SO) -1 - lappend manual(text) $code - } - .DS { - flushbuffer - incr manual(.DS) - lappend manual(text) $code - } - .DE { - flushbuffer - incr manual(.DS) -1 - lappend manual(text) $code - } - .CS { - flushbuffer - incr manual(.CS) - lappend manual(text) $code - } - .CE { - flushbuffer - 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 { - flushbuffer - manerror "unrecognized format directive: $line" - } - } - } - flushbuffer - close $manual(infp) - # fixups - if {$manual(.RS) != 0} { - 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" - } - # output conversion - open-text - set haserror 0 - if {[next-op-is .HS rest]} { - set manual($manual(name)-title) \ - "[lrange $rest 1 end] [lindex $rest 0] manual page" - } elseif {[next-op-is .TH rest]} { - set manual($manual(name)-title) "[lindex $rest 0] manual page - [lrange $rest 4 end]" - } else { - set haserror 1 - manerror "no .HS or .TH record found" - } - if {!$haserror} { - while {[more-text]} { - set line [next-text] - if {[is-a-directive $line]} { - output-directive $line - } else { - man-puts $line - } - } - man-puts [copyout $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>] - } - # - # make the wing table of contents for the section - # - 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 -dictionary $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> + ## + ## parse the manpages in a section of the docs (split by + ## package) and construct formatted manpages + ## + foreach arg $args { + if {[llength $arg]} { + make-manpage-section $html $arg } - puts $manual(wing-toc-fp) </table> - - # - # insert wing copyrights - # - 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)] } ## ## build the keyword index. ## + if {!$verbose} { + puts stderr "Assembling index" + } file delete -force -- $html/Keywords makedirhier $html/Keywords set keyfp [open $html/Keywords/[indexfile] w] @@ -1826,7 +306,7 @@ proc make-man-pages {html args} { lappend keyheader $a } } - set keyheader "<H3>[join $keyheader " |\n"]</H3>" + set keyheader <H3>[join $keyheader " |\n"]</H3> puts $keyfp $keyheader foreach a $letters { set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] @@ -1877,81 +357,321 @@ proc make-man-pages {html args} { ## output man pages ## unset manual(section) - foreach path $manual(all-pages) { + if {!$verbose} { + puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links and write out" + } + foreach path $manual(all-pages) wing_name $manual(all-page-domains) { 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 outfd [open $html/$manual(wing-file)/$manual(name).htm w] - 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 - } - } then { + try { + 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 { - puts $outfd $item + incr ntoc [llength [split $item \n]] + incr ntoc } + if {$verbose} { + puts stderr "rescanning page $manual(name) $ntoc/$ntext" + } else { + puts -nonewline stderr . + } + set outfd [open $html/$manual(wing-file)/$manual(name).htm w] + puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \ + $manual(name) $wing_name "[indexfile]" \ + $overall_title "../[indexfile]"] + 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 + } + } + foreach item $text { + puts $outfd [insert-cross-references $item] + } + puts $outfd "</BODY></HTML>" + } on error msg { + if {$verbose} { + puts stderr $msg + } else { + puts stderr "\nError when processing $manual(name): $msg" + } + } finally { + catch {close $outfd} } - foreach item $text { - puts $outfd [insert-cross-references $item] - } - puts $outfd "</BODY></HTML>" - close $outfd + } + if {!$verbose} { + puts stderr "\nDone" } 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.} - -if {1} { - if {[catch { - make-man-pages $webdir \ - "$tcltkdir/{$appdir}/doc/*.1 \"$tcltkdesc Applications\" UserCmd {$usercmddesc}" \ - [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" : ""}] \ - [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" : ""}] \ - [expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" : ""}] \ - [expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" : ""}] - } error]} { - puts $error\n$errorInfo +## +## Helper for assembling the descriptions of contributed packages. +## +proc plus-pkgs {type args} { + global build_tcl tcltkdir tcldir + if {$type ni {n 3}} { + error "unknown type \"$type\": must be 3 or n" } + if {!$build_tcl} return + set result {} + foreach {dir name} $args { + set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/*.$type + if {![llength [glob -nocomplain $globpat]]} { + # Fallback for manpages generated using doctools + set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/man/*.$type + if {![llength [glob -nocomplain $globpat]]} { + continue + } + } + regexp "pkgs/${dir}(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \ + -> version + switch $type { + n { + set title "$name Package Commands" + if {$version ne ""} { + append title ", version $version" + } + set dir [string totitle $dir]Cmd + set desc \ + "The additional commands provided by the $name package." + } + 3 { + set title "$name Package C API" + if {$version ne ""} { + append title ", version $version" + } + 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 +} + +## +## 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} +set ensemble_commands { + after array binary chan clock dde dict encoding file history info interp + memory namespace package registry self string trace update zlib + clipboard console font grab grid image option pack place selection tk + tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is +} +array set remap_link_target { + stdin Tcl_GetStdChannel + stdout Tcl_GetStdChannel + stderr Tcl_GetStdChannel + style ttk::style + {style map} ttk::style + {tk busy} busy + library auto_execok + safe-tcl safe + tclvars env + tcl_break catch + tcl_continue catch + tcl_error catch + tcl_ok catch + tcl_return catch + int() mathfunc + wide() mathfunc + packagens pkg::create + pkgMkIndex pkg_mkIndex + pkg_mkIndex pkg_mkIndex + Tcl_Obj Tcl_NewObj + Tcl_ObjType Tcl_RegisterObjType + Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel + errorinfo env + errorcode env + tcl_pkgpath env + Tcl_Command Tcl_CreateObjCommand + Tcl_CmdProc Tcl_CreateObjCommand + Tcl_CmdDeleteProc Tcl_CreateObjCommand + Tcl_ObjCmdProc Tcl_CreateObjCommand + Tcl_Channel Tcl_OpenFileChannel + Tcl_WideInt Tcl_NewIntObj + Tcl_ChannelType Tcl_CreateChannel + Tcl_DString Tcl_DStringInit + Tcl_Namespace Tcl_AppendExportList + Tcl_Object Tcl_NewObjectInstance + Tcl_Class Tcl_GetObjectAsClass + Tcl_Event Tcl_QueueEvent + Tcl_Time Tcl_GetTime + Tcl_ThreadId Tcl_CreateThread + Tk_Window Tk_WindowId + Tk_3DBorder Tk_Get3DBorder + Tk_Anchor Tk_GetAnchor + Tk_Cursor Tk_GetCursor + Tk_Dash Tk_GetDash + Tk_Font Tk_GetFont + Tk_Image Tk_GetImage + Tk_ImageMaster Tk_GetImage + Tk_ItemType Tk_CreateItemType + Tk_Justify Tk_GetJustify + Ttk_Theme Ttk_GetTheme +} +array set exclude_refs_map { + bind.n {button destroy option} + clock.n {next} + history.n {exec} + next.n {unknown} + zlib.n {binary close filename text} + canvas.n {bitmap text} + console.n {eval} + checkbutton.n {image} + clipboard.n {string} + entry.n {string} + event.n {return} + font.n {menu} + getOpenFile.n {file open text} + grab.n {global} + interp.n {time} + menu.n {checkbutton radiobutton} + messageBox.n {error info} + options.n {bitmap image set} + radiobutton.n {image} + safe.n {join split} + scale.n {label variable} + scrollbar.n {set} + selection.n {string} + tcltest.n {error} + tkvars.n {tk} + tkwait.n {variable} + tm.n {exec} + ttk_checkbutton.n {variable} + ttk_combobox.n {selection} + ttk_entry.n {focus variable} + ttk_intro.n {focus text} + ttk_label.n {font text} + ttk_labelframe.n {text} + ttk_menubutton.n {flush} + ttk_notebook.n {image text} + ttk_progressbar.n {variable} + ttk_radiobutton.n {variable} + ttk_scale.n {variable} + ttk_scrollbar.n {set} + ttk_spinbox.n {format} + ttk_treeview.n {text open} + ttk_widget.n {image text variable} + TclZlib.3 {binary flush filename text} +} +array set exclude_when_followed_by_map { + canvas.n { + bind widget + focus widget + image are + lower widget + raise widget + } + selection.n { + clipboard selection + clipboard ; + } + ttk_image.n { + image imageSpec + } + fontchooser.n { + tk fontchooser + } +} + +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. Note that the package directory list should be version-less. + 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} + thread Thread + } + } + + # + # 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 C API} TclLib \ + "The C functions which a Tcl extended C program may use."] \ + [plus-base $build_tk $tkdir/doc/*.3 {Tk C API} 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: +# mode: tcl +# End: diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c new file mode 100644 index 0000000..40004b1 --- /dev/null +++ b/tools/tsdPerf.c @@ -0,0 +1,59 @@ +#include <tcl.h> + +extern DLLEXPORT Tcl_PackageInitProc Tsdperf_Init; + +static Tcl_ThreadDataKey key; + +typedef struct { + int value; +} TsdPerf; + + +static int +tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { + TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); + int i; + + if (2 != objc) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + + if (TCL_OK != Tcl_GetIntFromObj(interp, objv[1], &i)) { + return TCL_ERROR; + } + + perf->value = i; + + return TCL_OK; +} + +static int +tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { + TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); + + + Tcl_SetObjResult(interp, Tcl_NewIntObj(perf->value)); + + return TCL_OK; +} + +int +Tsdperf_Init(Tcl_Interp *interp) { + if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + return TCL_ERROR; + } + + Tcl_CreateObjCommand(interp, "tsdPerfSet", tsdPerfSetObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "tsdPerfGet", tsdPerfGetObjCmd, NULL, NULL); + + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/tools/tsdPerf.tcl b/tools/tsdPerf.tcl new file mode 100644 index 0000000..360ca9c --- /dev/null +++ b/tools/tsdPerf.tcl @@ -0,0 +1,24 @@ + +package require Thread + +set ::tids [list] +for {set i 0} {$i < 4} {incr i} { + lappend ::tids [thread::create [string map [list IVALUE $i] { + set curdir [file dirname [info script]] + load [file join $curdir tsdPerf[info sharedlibextension]] + + while 1 { + tsdPerfSet IVALUE + } + }]] +} + +puts TIDS:$::tids + +set curdir [file dirname [info script]] +load [file join $curdir tsdPerf[info sharedlibextension]] + +tsdPerfSet 1234 +while 1 { + puts "TIME:[time {set value [tsdPerfGet]} 1000] VALUE:$value" +} |
