summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2011-08-02 14:06:01 (GMT)
committerdgp <dgp@users.sourceforge.net>2011-08-02 14:06:01 (GMT)
commit448030e37ec7508c06c212e4ea97aa09723e37fc (patch)
treee0689d9c4299cd6f82807563bd7b139991cc22fa
parentb5d586efcb0a9467938f183610fa4e82eeea988e (diff)
parente6bcda9b1f02804a103d402c12abf8b22b743084 (diff)
downloadtcl-448030e37ec7508c06c212e4ea97aa09723e37fc.zip
tcl-448030e37ec7508c06c212e4ea97aa09723e37fc.tar.gz
tcl-448030e37ec7508c06c212e4ea97aa09723e37fc.tar.bz2
merge to rc
-rw-r--r--ChangeLog33
-rw-r--r--changes4
-rw-r--r--doc/tclvars.n37
-rw-r--r--generic/tclObj.c46
-rw-r--r--generic/tclProc.c7
-rw-r--r--tests/encoding.test187
-rw-r--r--tools/tcltk-man2html-utils.tcl61
-rwxr-xr-xtools/tcltk-man2html.tcl20
8 files changed, 224 insertions, 171 deletions
diff --git a/ChangeLog b/ChangeLog
index 7129877..060cd04 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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
diff --git a/changes b/changes
index 75fcda3..76ed3e8 100644
--- a/changes
+++ b/changes
@@ -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} {