summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--doc/variable.n7
-rw-r--r--generic/tclZlib.c151
-rw-r--r--library/history.tcl24
-rw-r--r--tests/binary.test13
-rw-r--r--tests/history.test58
-rw-r--r--tests/zlib.test19
6 files changed, 206 insertions, 66 deletions
diff --git a/doc/variable.n b/doc/variable.n
index a6e545f..8228859 100644
--- a/doc/variable.n
+++ b/doc/variable.n
@@ -45,7 +45,8 @@ linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
-only links to variables in the global namespace.
+resolves variable names with respect to the global namespace instead
+of the current namespace of the procedure.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
@@ -98,3 +99,7 @@ namespace eval foo {
global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index a7e8a8a..7f7aff6 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -177,6 +177,8 @@ static Tcl_ObjCmdProc ZlibStreamPutCmd;
static void ConvertError(Tcl_Interp *interp, int code,
uLong adler);
static Tcl_Obj * ConvertErrorToList(int code, uLong adler);
+static inline int Deflate(z_streamp strm, void *bufferPtr,
+ int bufferSize, int flush, int *writtenPtr);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
@@ -578,6 +580,10 @@ ExtractHeader(
}
}
+/*
+ * Disentangle the worst of how the zlib API is used.
+ */
+
static int
SetInflateDictionary(
z_streamp strm,
@@ -605,6 +611,38 @@ SetDeflateDictionary(
}
return Z_OK;
}
+
+static inline int
+Deflate(
+ z_streamp strm,
+ void *bufferPtr,
+ int bufferSize,
+ int flush,
+ int *writtenPtr)
+{
+ int e;
+
+ strm->next_out = (Bytef *) bufferPtr;
+ strm->avail_out = (unsigned) bufferSize;
+ e = deflate(strm, flush);
+ if (writtenPtr != NULL) {
+ *writtenPtr = bufferSize - strm->avail_out;
+ }
+ return e;
+}
+
+static inline void
+AppendByteArray(
+ Tcl_Obj *listObj,
+ void *buffer,
+ int size)
+{
+ if (size > 0) {
+ Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size);
+
+ Tcl_ListObjAppendElement(NULL, listObj, baObj);
+ }
+}
/*
*----------------------------------------------------------------------
@@ -1139,6 +1177,8 @@ Tcl_ZlibStreamSetCompressionDictionary(
*----------------------------------------------------------------------
*/
+#define BUFFER_SIZE_LIMIT 0xFFFF
+
int
Tcl_ZlibStreamPut(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
@@ -1148,8 +1188,7 @@ Tcl_ZlibStreamPut(
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
- int e, size, outSize;
- Tcl_Obj *obj;
+ int e, size, outSize, toStore;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
@@ -1175,26 +1214,45 @@ Tcl_ZlibStreamPut(
if (HaveDictToSet(zshPtr)) {
e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
- if (zshPtr->interp) {
- ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
- }
+ ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
return TCL_ERROR;
}
DictWasSet(zshPtr);
}
/*
- * Deflatebound doesn't seem to take various header sizes into
- * account, so we add 100 extra bytes.
+ * deflateBound() doesn't seem to take various header sizes into
+ * account, so we add 100 extra bytes. However, we can also loop
+ * around again so we also set an upper bound on the output buffer
+ * size.
*/
- outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100;
- zshPtr->stream.avail_out = outSize;
- dataTmp = ckalloc(zshPtr->stream.avail_out);
- zshPtr->stream.next_out = (Bytef *) dataTmp;
+ outSize = deflateBound(&zshPtr->stream, size) + 100;
+ if (outSize > BUFFER_SIZE_LIMIT) {
+ outSize = BUFFER_SIZE_LIMIT;
+ }
+ dataTmp = ckalloc(outSize);
+
+ while (1) {
+ e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore);
+
+ /*
+ * Test if we've filled the buffer up and have to ask deflate() to
+ * give us some more. Note that the condition for needing to
+ * repeat a buffer transfer when the result is Z_OK is whether
+ * there is no more space in the buffer we provided; the zlib
+ * library does not necessarily return a different code in that
+ * case. [Bug b26e38a3e4] [Tk Bug 10f2e7872b]
+ */
+
+ if ((e != Z_BUF_ERROR) && (e != Z_OK || toStore < outSize)) {
+ if ((e == Z_OK) || (flush == Z_FINISH && e == Z_STREAM_END)) {
+ break;
+ }
+ ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
+ return TCL_ERROR;
+ }
- e = deflate(&zshPtr->stream, flush);
- while (e == Z_BUF_ERROR || (flush == Z_FINISH && e == Z_OK)) {
/*
* Output buffer too small to hold the data being generated or we
* are doing the end-of-stream flush (which can spit out masses of
@@ -1202,45 +1260,21 @@ Tcl_ZlibStreamPut(
* saving the old generated data to the outData list.
*/
- obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, outSize);
- Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
+ AppendByteArray(zshPtr->outData, dataTmp, outSize);
- if (outSize < 0xFFFF) {
- outSize = 0xFFFF; /* There may be *lots* of data left to
- * output... */
+ if (outSize < BUFFER_SIZE_LIMIT) {
+ outSize = BUFFER_SIZE_LIMIT;
+ /* There may be *lots* of data left to output... */
dataTmp = ckrealloc(dataTmp, outSize);
}
- zshPtr->stream.avail_out = outSize;
- zshPtr->stream.next_out = (Bytef *) dataTmp;
-
- e = deflate(&zshPtr->stream, flush);
- }
-
- if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) {
- if (zshPtr->interp) {
- ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
- }
- return TCL_ERROR;
}
/*
- * And append the final data block.
+ * And append the final data block to the outData list.
*/
- if (outSize - zshPtr->stream.avail_out > 0) {
- obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp,
- outSize - zshPtr->stream.avail_out);
-
- /*
- * Now append the compressed data to the outData list.
- */
-
- Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
- }
-
- if (dataTmp) {
- ckfree(dataTmp);
- }
+ AppendByteArray(zshPtr->outData, dataTmp, toStore);
+ ckfree(dataTmp);
} else {
/*
* This is easy. Just append to the inData list.
@@ -1356,9 +1390,7 @@ Tcl_ZlibStreamGet(
if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
- if (zshPtr->interp) {
- ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
- }
+ ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
return TCL_ERROR;
}
DictWasSet(zshPtr);
@@ -2879,10 +2911,8 @@ ZlibTransformClose(
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
cd->outStream.avail_in = 0;
do {
- cd->outStream.next_out = (Bytef *) cd->outBuffer;
- cd->outStream.avail_out = (unsigned) cd->outAllocated;
- e = deflate(&cd->outStream, Z_FINISH);
- written = cd->outAllocated - cd->outStream.avail_out;
+ e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
+ Z_FINISH, &written);
/*
* Can't be sure that deflate() won't declare the buffer to be
@@ -3086,17 +3116,15 @@ ZlibTransformOutput(
cd->outStream.next_in = (Bytef *) buf;
cd->outStream.avail_in = toWrite;
do {
- cd->outStream.next_out = (Bytef *) cd->outBuffer;
- cd->outStream.avail_out = cd->outAllocated;
-
- e = deflate(&cd->outStream, Z_NO_FLUSH);
- produced = cd->outAllocated - cd->outStream.avail_out;
+ e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
+ Z_NO_FLUSH, &produced);
if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) {
/*
* deflate() indicates that it is out of space by returning
- * Z_BUF_ERROR; in that case, we must write the whole buffer out
- * and retry to compress what is left.
+ * Z_BUF_ERROR *or* by simply returning Z_OK with no remaining
+ * space; in either case, we must write the whole buffer out and
+ * retry to compress what is left.
*/
if (e == Z_BUF_ERROR) {
@@ -3149,10 +3177,8 @@ ZlibTransformFlush(
* Get the bytes to go out of the compression engine.
*/
- cd->outStream.next_out = (Bytef *) cd->outBuffer;
- cd->outStream.avail_out = cd->outAllocated;
-
- e = deflate(&cd->outStream, flushType);
+ e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
+ flushType, &len);
if (e != Z_OK && e != Z_BUF_ERROR) {
ConvertError(interp, e, cd->outStream.adler);
return TCL_ERROR;
@@ -3162,7 +3188,6 @@ ZlibTransformFlush(
* Write the bytes we've received to the next layer.
*/
- len = cd->outStream.next_out - (Bytef *) cd->outBuffer;
if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"problem flushing channel: %s",
diff --git a/library/history.tcl b/library/history.tcl
index 51d2404..ef9099b 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -56,6 +56,30 @@ proc ::history {args} {
tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
}
+# (unnamed) --
+#
+# Callback when [::history] is destroyed. Destroys the implementation.
+#
+# Parameters:
+# oldName what the command was called.
+# newName what the command is now called (an empty string).
+# op the operation (= delete).
+#
+# Results:
+# none
+#
+# Side Effects:
+# The implementation of the [::history] command ceases to exist.
+
+trace add command ::history delete [list apply {{oldName newName op} {
+ variable history
+ unset -nocomplain history
+ foreach c [info procs ::tcl::Hist*] {
+ rename $c {}
+ }
+ rename ::tcl::history {}
+} ::tcl}]
+
# tcl::HistAdd --
#
# Add an item to the history, and optionally eval it at the global scope
diff --git a/tests/binary.test b/tests/binary.test
index 40b1315..7738f69 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2837,6 +2837,19 @@ test binary-76.2 {binary string appending growth algorithm} win {
# Append to it
string length [append str [binary format a* foo]]
} 3
+
+test binary-77.1 {string cat ops on all bytearrays} {
+ apply {{a b} {
+ return [binary format H* $a][binary format H* $b]
+ }} ab cd
+} [binary format H* abcd]
+test binary-77.2 {string cat ops on all bytearrays} {
+ apply {{a b} {
+ set one [binary format H* $a]
+ return $one[binary format H* $b]
+ }} ab cd
+} [binary format H* abcd]
+
# ----------------------------------------------------------------------
# cleanup
diff --git a/tests/history.test b/tests/history.test
index c2d2124..9ff41f2 100644
--- a/tests/history.test
+++ b/tests/history.test
@@ -11,8 +11,8 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2
namespace import -force ::tcltest::*
}
@@ -245,6 +245,60 @@ test history-9.2 {miscellaneous} history {
catch {history gorp} msg
set msg
} {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo}
+
+# History retains references; Bug 1ae12987cb
+test history-10.1 {references kept by history} -constraints history -setup {
+ interp create histtest
+ histtest eval {
+ # Trigger any autoloading that might be present
+ catch {history}
+ proc refcount {x} {
+ set rep [::tcl::unsupported::representation $x]
+ regexp {with a refcount of (\d+)} $rep -> rc
+ # Ignore the references due to calling this procedure
+ return [expr {$rc - 3}]
+ }
+ }
+} -body {
+ histtest eval {
+ # A fresh object, refcount 1 from the variable we write it to
+ set obj [expr rand()]
+ set baseline [refcount $obj]
+ lappend result [refcount $obj]
+ history add [list list $obj]
+ lappend result [refcount $obj]
+ history clear
+ lappend result [refcount $obj]
+ }
+} -cleanup {
+ interp delete histtest
+} -result {1 2 1}
+test history-10.2 {references kept by history} -constraints history -setup {
+ interp create histtest
+ histtest eval {
+ # Trigger any autoloading that might be present
+ catch {history}
+ proc refcount {x} {
+ set rep [::tcl::unsupported::representation $x]
+ regexp {with a refcount of (\d+)} $rep -> rc
+ # Ignore the references due to calling this procedure
+ return [expr {$rc - 3}]
+ }
+ }
+} -body {
+ histtest eval {
+ # A fresh object, refcount 1 from the variable we write it to
+ set obj [expr rand()]
+ set baseline [refcount $obj]
+ lappend result [refcount $obj]
+ history add [list list $obj]
+ lappend result [refcount $obj]
+ rename history {}
+ lappend result [refcount $obj]
+ }
+} -cleanup {
+ interp delete histtest
+} -result {1 2 1}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/zlib.test b/tests/zlib.test
index 15dbb34..ae8742b 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -138,6 +138,25 @@ test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body {
} -cleanup {
catch {$s close}
} -result ""
+# Also causes Tk Bug 10f2e7872b
+test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup {
+ expr srand(12345)
+ set randdata {}
+ for {set i 0} {$i<6001} {incr i} {
+ append randdata [binary format c [expr {int(256*rand())}]]
+ }
+} -body {
+ set strm [zlib stream compress]
+ for {set i 1} {$i<3000} {incr i} {
+ $strm put $randdata
+ }
+ $strm put -finalize $randdata
+ set data [$strm get]
+ list [string length $data] [string length [zlib decompress $data]]
+} -cleanup {
+ catch {$strm close}
+ unset -nocomplain randdata data
+} -result {120185 18003000}
test zlib-8.1 {zlib transformation} -constraints zlib -setup {
set file [makeFile {} test.gz]