merge trunk

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]