diff options
| -rw-r--r-- | ChangeLog | 33 | ||||
| -rw-r--r-- | changes | 4 | ||||
| -rw-r--r-- | doc/tclvars.n | 37 | ||||
| -rw-r--r-- | generic/tclObj.c | 46 | ||||
| -rw-r--r-- | generic/tclProc.c | 7 | ||||
| -rw-r--r-- | tests/encoding.test | 187 | ||||
| -rw-r--r-- | tools/tcltk-man2html-utils.tcl | 61 | ||||
| -rwxr-xr-x | tools/tcltk-man2html.tcl | 20 |
8 files changed, 224 insertions, 171 deletions
@@ -1,3 +1,36 @@ +2011-08-02 Don Porter <dgp@users.sourceforge.net> + + * changes: Updates for 8.6b2 release. + +2011-08-02 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclObj.c (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount) + (Tcl_DbIsShared): [Bug 3384007]: Fix the panic messages so they share + what should be shared and have the right number of spaces. + +2011-08-01 Miguel Sofer <msofer@users.sf.net> + + * generic/tclProc.c (TclProcCompileProc): [Bug 3383616]: Fix for leak + of resolveInfo when recompiling procs. Thanks go to Gustaf Neumann for + detecting the bug and providing the fix. + +2011-08-01 Donal K. Fellows <dkf@users.sf.net> + + * doc/tclvars.n (EXAMPLES): Added some examples of how some of the + standard global variables can be used, following prompting by a + request by Robert Hicks. + + * tools/tcltk-man2html.tcl (plus-pkgs): [Bug 3382474]: Added code to + determine the version number of contributed packages from their + directory names so that HTML documentation builds are less confusing. + +2011-07-29 Donal K. Fellows <dkf@users.sf.net> + + * tools/tcltk-man2html.tcl (ensemble_commands, remap_link_target): + Small enhancements to improve cross-linking with contributed packages. + * tools/tcltk-man2html-utils.tcl (insert-cross-references): Enhance to + cope with contributed packages' C API. + 2011-07-28 Reinhard Max <max@suse.de> * unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for @@ -7949,6 +7949,8 @@ memory with buffer backup (ferrieux) 2011-07-28 tzdata updated to Olson's tzdata2011h (porter) +2011-08-01 (bug fix)[3383616] memleak exposed by XOTcl (neumann,sofer) + Many more Tcl built-in command errors now set an -errorcode. ---- Released 8.6b2, August 3, 2011 --- See ChangeLog for details --- +--- Released 8.6b2, August 5, 2011 --- See ChangeLog for details --- diff --git a/doc/tclvars.n b/doc/tclvars.n index b126b7f..3bd18e8 100644 --- a/doc/tclvars.n +++ b/doc/tclvars.n @@ -485,6 +485,7 @@ bug fixes that retain backward compatibility. The value of this variable is returned by the \fBinfo tclversion\fR command. .SH "OTHER GLOBAL VARIABLES" +.PP The following variables are only guaranteed to exist in \fBtclsh\fR and \fBwish\fR executables; the Tcl library does not define them itself but many Tcl environments do. @@ -508,6 +509,42 @@ was invoked. Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no script was specified and standard input is a terminal-like device), 0 otherwise. +.SH EXAMPLES +.PP +To add a directory to the collection of locations searched by +\fBpackage require\fR, e.g., because of some application-specific +packages that are used, the \fBauto_path\fR variable needs to be +updated: +.PP +.CS +lappend ::\fBauto_path\fR [file join [pwd] "theLibDir"] +.CE +.PP +A simple though not very robust way to handle command line arguments +of the form +.QW "\-foo 1 \-bar 2" +is to load them into an array having first loaded in the default settings: +.CS +array set arguments {-foo 0 -bar 0 -grill 0} +array set arguments $::\fBargv\fR +puts "foo is $arguments(-foo)" +puts "bar is $arguments(-bar)" +puts "grill is $arguments(-grill)" +.CE +.PP +The \fBargv0\fR global variable can be used (in conjunction with the +\fBinfo script\fR command) to determine whether the current script is +being executed as the main script or loaded as a library. This is +useful because it allows a single script to be used as both a library +and a demonstration of that library: +.PP +.CS +if {$::\fBargv0\fR eq [info script]} { + # running as: tclsh example.tcl +} else { + package provide Example 1.0 +} +.CE .SH "SEE ALSO" eval(n), library(n), tclsh(1), tkvars(n), wish(1) .SH KEYWORDS diff --git a/generic/tclObj.c b/generic/tclObj.c index 95924c1..a1316d9 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3713,23 +3713,21 @@ Tcl_DbIncrRefCount( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to incr ref count of ", - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "incr ref count"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ ++(objPtr)->refCount; } @@ -3778,19 +3776,17 @@ Tcl_DbDecrRefCount( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; - tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to decr ref count of ", - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "decr ref count"); } /* @@ -3807,8 +3803,9 @@ Tcl_DbDecrRefCount( Tcl_DeleteHashEntry(hPtr); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ + if (--(objPtr)->refCount <= 0) { TclFreeObj(objPtr); } @@ -3858,22 +3855,21 @@ Tcl_DbIsShared( */ if (!TclInExit()) { - Tcl_HashTable *tablePtr; - Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - tablePtr = tsdPtr->objThreadMap; + Tcl_HashTable *tablePtr = tsdPtr->objThreadMap; + Tcl_HashEntry *hPtr; + if (!tablePtr) { Tcl_Panic("object table not initialized"); } hPtr = Tcl_FindHashEntry(tablePtr, objPtr); if (!hPtr) { - Tcl_Panic("%s%s", - "Trying to check shared status of", - "Tcl_Obj allocated in another thread"); + Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread", + "check shared status"); } } -# endif -#endif +# endif /* TCL_THREADS */ +#endif /* TCL_MEM_DEBUG */ #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); @@ -3885,7 +3881,7 @@ Tcl_DbIsShared( tclObjsShared[0]++; } Tcl_MutexUnlock(&tclObjMutex); -#endif +#endif /* TCL_COMPILE_STATS */ return ((objPtr)->refCount > 1); } diff --git a/generic/tclProc.c b/generic/tclProc.c index a2de765..48f472f 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2063,6 +2063,13 @@ TclProcCompileProc( CompiledLocal *toFree = clPtr; clPtr = clPtr->nextPtr; + if (toFree->resolveInfo) { + if (toFree->resolveInfo->deleteProc) { + toFree->resolveInfo->deleteProc(toFree->resolveInfo); + } else { + ckfree(toFree->resolveInfo); + } + } ckfree(toFree); } procPtr->numCompiledLocals = procPtr->numArgs; diff --git a/tests/encoding.test b/tests/encoding.test index 1738413..a4f8449 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1,12 +1,12 @@ # This file contains a collection of tests for tclEncoding.c -# Sourcing this file into Tcl runs the tests and generates output for -# errors. No output means no errors were found. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 @@ -25,32 +25,34 @@ proc fromutf {args} { } proc runtests {} { - variable x # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] testConstraint exec [llength [info commands exec]] - +testConstraint testgetdefenc [llength [info commands testgetdefenc]] + # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested -test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} { - testencoding create foo [namespace origin toutf] [namespace origin fromutf] +test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup { set old [encoding system] +} -constraints {testencoding} -body { + testencoding create foo [namespace origin toutf] [namespace origin fromutf] encoding system foo set x {} encoding convertto abcd + return $x +} -cleanup { encoding system $old testencoding delete foo - set x -} {{fromutf }} +} -result {{fromutf }} test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { testencoding create foo [namespace origin toutf] [namespace origin fromutf] set x {} encoding convertto foo abcd testencoding delete foo - set x + return $x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { list [encoding convertto jis0208 \u4e4e] \ @@ -60,71 +62,77 @@ test encoding-1.3 {Tcl_GetEncoding: load encoding} { test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { encoding convertto jis0208 \u4e4e } {8C} -test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} { +test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { set system [encoding system] set path [encoding dirs] +} -constraints {testencoding} -body { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] set x [encoding convertto shiftjis \u4e4e] ;# old one found encoding system identity llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg +} -cleanup { encoding system identity encoding dirs $path encoding system $system - set x -} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" +} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" -test encoding-3.1 {Tcl_GetEncodingName, NULL} { +test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { set old [encoding system] +} -body { encoding system shiftjis - set x [encoding system] + encoding system +} -cleanup { encoding system $old - set x -} {shiftjis} -test encoding-3.2 {Tcl_GetEncodingName, non-null} { +} -result {shiftjis} +test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup { set old [fconfigure stdout -encoding] +} -body { fconfigure stdout -encoding jis0208 - set x [fconfigure stdout -encoding] + fconfigure stdout -encoding +} -cleanup { fconfigure stdout -encoding $old - set x -} {jis0208} +} -result {jis0208} -test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} { +test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { cd [makeDirectory tmp] makeDirectory [file join tmp encoding] - makeFile {} [file join tmp encoding junk.enc] - makeFile {} [file join tmp encoding junk2.enc] set path [encoding dirs] encoding dirs {} catch {unset encodings} catch {unset x} +} -body { foreach encoding [encoding names] { set encodings($encoding) 1 } + makeFile {} [file join tmp encoding junk.enc] + makeFile {} [file join tmp encoding junk2.enc] encoding dirs [list [file join [pwd] encoding]] foreach encoding [encoding names] { if {![info exists encodings($encoding)]} { lappend x $encoding } } + lsort $x +} -cleanup { encoding dirs $path cd [workingDirectory] removeFile [file join tmp encoding junk2.enc] removeFile [file join tmp encoding junk.enc] removeDirectory [file join tmp encoding] removeDirectory tmp - lsort $x -} {junk junk2} +} -result {junk junk2} -test encoding-5.1 {Tcl_SetSystemEncoding} { +test encoding-5.1 {Tcl_SetSystemEncoding} -setup { set old [encoding system] +} -body { encoding system jis0208 - set x [encoding convertto \u4e4e] + encoding convertto \u4e4e +} -cleanup { encoding system identity encoding system $old - set x -} {8C} +} -result {8C} test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} { set old [encoding system] encoding system $old @@ -138,7 +146,7 @@ test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} { encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo - set x + return $x } {{toutf 1} {fromutf 2}} test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { testencoding create foo [namespace code {toutf a}] \ @@ -147,7 +155,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { encoding convertfrom foo abcd encoding convertto foo abcd testencoding delete foo - set x + return $x } {{toutf a} {fromutf b}} test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { @@ -173,7 +181,7 @@ test encoding-8.1 {Tcl_ExternalToUtf} { set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] - set x + return $x } "ab\u4e4eg" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { @@ -201,7 +209,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] - set x + return $x } "ab\x8c\xc1g" proc viewable {str} { @@ -242,10 +250,11 @@ test encoding-11.5 {LoadEncodingFile: escape file} { test encoding-11.5.1 {LoadEncodingFile: escape file} { viewable [encoding convertto iso2022-jp \u4e4e] } [viewable "\x1b\$B8C\x1b(B"] -test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { +test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] encoding system identity +} -body { cd [temporaryDirectory] encoding dirs [file join tmp encoding] makeDirectory tmp @@ -254,15 +263,15 @@ test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f - set x [list [catch {encoding convertto splat \u4e4e} msg] $msg] + encoding convertto splat \u4e4e +} -returnCodes error -cleanup { file delete [file join [temporaryDirectory] tmp encoding splat.enc] removeDirectory [file join tmp encoding] removeDirectory tmp cd [workingDirectory] encoding dirs $path encoding system $system - set x -} {1 {invalid encoding file "splat"}} +} -result {invalid encoding file "splat"} # OpenEncodingFile is fully tested by the rest of the tests in this file. @@ -300,7 +309,6 @@ test encoding-14.1 {BinaryProc} { test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" - test encoding-15.2 {UtfToUtfProc null character output} { set x \u0000 set y [encoding convertto utf-8 \u0000] @@ -308,7 +316,6 @@ test encoding-15.2 {UtfToUtfProc null character output} { binary scan $y H* z list [string bytelength $x] [string bytelength $y] $z } {2 1 00} - test encoding-15.3 {UtfToUtfProc null character input} { set x [encoding convertfrom identity \x00] set y [encoding convertfrom utf-8 $x] @@ -388,44 +395,40 @@ test encoding-23.3 {iso2022-jp escape encoding test} { fconfigure $fid -encoding iso2022-jp set data [read $fid 50] close $fid - set data + return $data } [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50 cd [workingDirectory] -test encoding-24.1 {EscapeFreeProc on open channels} -constraints { - exec -} -setup { - # Bug #524674 input - set file [makeFile { +# Code to make the next few tests more intelligible; the code being tested +# should be in the body of the test! +proc runInSubprocess {contents {filename iso2022.tcl}} { + set theFile [makeFile $contents $filename] + try { + exec [interpreter] $theFile + } finally { + removeFile $theFile + } +} + +test encoding-24.1 {EscapeFreeProc on open channels} exec { + runInSubprocess { set f [open [file join [file dirname [info script]] iso2022.txt]] fconfigure $f -encoding iso2022-jp gets $f - } iso2022.tcl] -} -body { - exec [interpreter] $file -} -cleanup { - removeFile iso2022.tcl -} -result {} - -test encoding-24.2 {EscapeFreeProc on open channels} -constraints { - exec -} -setup { + } +} {} +test encoding-24.2 {EscapeFreeProc on open channels} exec { # Bug #524674 output - set file [makeFile { + viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator fconfigure stdout -encoding iso2022-jp puts ab\u4e4e\u68d9g testfinexit - } iso2022.tcl] -} -body { - viewable [exec [interpreter] $file] -} -cleanup { - removeFile iso2022.tcl -} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" - + }] +} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { - # Bug #219314 - if we don't free escape encodings correctly on - # channel closure, we go boom + # Bug #219314 - if we don't free escape encodings correctly on channel + # closure, we go boom set file [makeFile { encoding system iso2022-jp set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters @@ -469,18 +472,14 @@ proc foreach-jisx0208 {varName command} { } { if {[llength $range] == 2} { # for adhoc range. simple {first last}. inclusive. - set first [scan [lindex $range 0] %x] - set last [scan [lindex $range 1] %x] + scan $range %x%x first last for {set i $first} {$i <= $last} {incr i} { set code $i uplevel 1 $command } } elseif {[llength $range] == 4} { # for uniform range. - set h0 [scan [lindex $range 0] %x] - set l0 [scan [lindex $range 1] %x] - set hend [scan [lindex $range 2] %x] - set lend [scan [lindex $range 3] %x] + scan $range %x%x%x%x h0 l0 hend lend for {set hi $h0} {$hi <= $hend} {incr hi} { for {set lo $l0} {$lo <= $lend} {incr lo} { set code [expr {$hi << 8 | ($lo & 0xff)}] @@ -524,7 +523,7 @@ proc channel-diff {fa fb} { binary scan [lindex $lb 1] H* got lappend diff [list $code $expected $got] } - set diff + return $diff } # Create char tables. @@ -543,8 +542,9 @@ file copy -force cp932.chars shiftjis.chars set NUM 0 foreach from {cp932 shiftjis euc-jp iso2022-jp} { foreach to {cp932 shiftjis euc-jp iso2022-jp} { - test encoding-25.[incr NUM] "jisx0208 $from => $to" { + test encoding-25.[incr NUM] "jisx0208 $from => $to" -setup { cd [temporaryDirectory] + } -body { set f [open $from.chars] fconfigure $f -encoding $from set out [open $from.$to.tcltestout w] @@ -552,40 +552,35 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { puts -nonewline $out [read $f] close $out close $f - # then compare $to.chars <=> $from.to.tcltestout as binary. - set fa [open $to.chars] - fconfigure $fa -encoding binary - set fb [open $from.$to.tcltestout] - fconfigure $fb -encoding binary - set diff [channel-diff $fa $fb] + set fa [open $to.chars rb] + set fb [open $from.$to.tcltestout rb] + channel-diff $fa $fb + # Difference should be empty. + } -cleanup { close $fa close $fb - - # Difference should be empty. - set diff - } {} + } -result {} } } -testConstraint testgetdefenc [llength [info commands testgetdefenc]] - test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { - testgetdefenc + testgetdefenc } -setup { - set origDir [testgetdefenc] - testsetdefenc slappy + set origDir [testgetdefenc] + testsetdefenc slappy } -body { - testgetdefenc + testgetdefenc } -cleanup { - testsetdefenc $origDir + testsetdefenc $origDir } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] # ===> Cut here <=== -# EscapeFreeProc, GetTableEncoding, unilen -# are fully tested by the rest of this file +# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of +# this file. + } runtests @@ -595,3 +590,7 @@ runtests namespace delete ::tcl::test::encoding ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index af2faa3..938a1af 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -625,7 +625,7 @@ proc cross-reference {ref} { 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]} { + 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 @@ -705,7 +705,7 @@ proc cross-reference {ref} { ## exceptions, sigh, to the rule ## if {[info exists exclude_when_followed_by_map($mantail)]} { - upvar 1 tail tail + 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 @@ -758,9 +758,11 @@ proc insert-cross-references {text} { anchor {<A } end-anchor {</A>} quote {``} end-quote {''} bold {<B>} end-bold {</B>} - tcl {Tcl_} - tk {Tk_} - ttk {Ttk_} + 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://} @@ -808,12 +810,10 @@ proc insert-cross-references {text} { [expr {$offset(end-quote)-1}]] set text [string range $text[set text ""] \ [expr {$offset(end-quote)+2}] end] - set tail $text append result `` [cross-reference $body] '' continue } - bold - - anchor { + bold - anchor { append result [string range $text \ 0 [expr {$offset(end-quote)+1}]] set text [string range $text[set text ""] \ @@ -827,7 +827,7 @@ proc insert-cross-references {text} { if {$offset(end-bold) < 0} { return [append result $text] } - if {$invert([lindex $offsets 1]) in {tcl tk ttk}} { + if {[string match "c.*" $invert([lindex $offsets 1])]} { set offsets [lreplace $offsets 1 1] } switch -exact -- $invert([lindex $offsets 1]) { @@ -838,7 +838,6 @@ proc insert-cross-references {text} { [expr {$offset(end-bold)-1}]] set text [string range $text[set text ""] \ [expr {$offset(end-bold)+4}] end] - set tail $text regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body append result <B> [cross-reference $body] </B> continue @@ -855,48 +854,20 @@ proc insert-cross-references {text} { } } } - tk { - append result [string range $text 0 [expr {$offset(tk)-1}]] - if {![regexp -indices -start $offset(tk) {Tk_\w+} $text range]} { - return [reference-error "Tk regexp failed" $text] - } - set body [string range $text {*}$range] - set text [string range $text[set text ""] \ - [expr {[lindex $range 1]+1}] end] - set tail $text - append result [cross-reference $body] - continue - } - ttk { - append result [string range $text 0 [expr {$offset(ttk)-1}]] - if {![regexp -indices -start $offset(ttk) {Ttk_\w+} $text range]} { - return [reference-error "Ttk regexp failed" $text] - } - set body [string range $text {*}$range] - set text [string range $text[set text ""] \ - [expr {[lindex $range 1]+1}] end] - set tail $text - append result [cross-reference $body] - continue - } - tcl { - append result [string range $text 0 [expr {$offset(tcl)-1}]] - if {![regexp -indices -start $offset(tcl) {Tcl_\w+} $text range]} { - return [reference-error "Tcl regexp failed" $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] - set tail $text append result [cross-reference $body] continue } - Tcl1 - - Tcl2 { + 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] - set tail $text append result [cross-reference Tcl] continue } @@ -910,9 +881,7 @@ proc insert-cross-references {text} { [expr {[lindex $range 1]+1}] end] continue } - end-anchor - - end-bold - - end-quote { + end-anchor - end-bold - end-quote { return [reference-error "Out of place $invert([lindex $offsets 0])" $text] } } diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index f928d4a..eaadc51 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -766,23 +766,31 @@ proc plus-pkgs {type args} { if {!$build_tcl} return set result {} foreach {dir name} $args { - set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/*.$type + 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 + 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 Library" + if {$version ne ""} { + append title ", version $version" + } set dir [string totitle $dir]Lib set desc \ "The additional C functions provided by the $name package." @@ -804,7 +812,7 @@ 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 + tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is } array set remap_link_target { stdin Tcl_GetStdChannel @@ -834,6 +842,8 @@ array set remap_link_target { 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 @@ -943,8 +953,8 @@ try { append appdir "$tkdir" } - # Get the list of packages to try, and what their human-readable - # names are. + # 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} { |