From 8cc3c8dbcc8bd130f161afaf0c4ccc36562ff705 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 2 May 2012 10:11:14 +0000 Subject: Update of Patch 2445648 to trunk tip. Implementation of TIP 106: Add Encoding Abilities to the [dde] Command --- doc/dde.n | 22 ++++++++++--- win/tclWinDde.c | 100 ++++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 83 insertions(+), 39 deletions(-) diff --git a/doc/dde.n b/doc/dde.n index a02c582..60dd058 100644 --- a/doc/dde.n +++ b/doc/dde.n @@ -17,9 +17,11 @@ dde \- Execute a Dynamic Data Exchange command .sp \fBdde servername\fR ?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR? .sp -\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR +.VS 8.6 +\fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR .sp -\fBdde poke\fR \fIservice topic item data\fR +\fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR +.VE 8.6 .sp \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR .sp @@ -69,7 +71,7 @@ procedure is called with all the arguments provided by the remote call. .RE .TP -\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR +\fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR . \fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated by \fIservice\fR with the topic indicated by \fItopic\fR. Typically, @@ -80,8 +82,13 @@ script is run in the application. The \fB\-async\fR option requests asynchronous invocation. The command returns an error message if the script did not run, unless the \fB\-async\fR flag was used, in which case the command returns immediately with no error. +.VS 8.6 +The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise an utf-8 +string is sent. Combining \fB-binary\fR with the result of +\fBencoding convertto\fR may be used to send data in arbitrary encodings. +.VE 8.6 .TP -\fBdde poke \fIservice topic item data\fR +\fBdde poke ?\fB\-binary\fR? \fIservice topic item data\fR . \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, @@ -90,6 +97,10 @@ specific but can be a command to the server or the name of a file to work on. The \fIitem\fR is also application specific and is often not used, but it must always be non-null. The \fIdata\fR field is given to the remote application. +.VS 8.6 +The \fB\-binary\fR option treats \fIdata\fR as binary data, otherwise an utf-8 +string is sent. +.VE 8.6 .TP \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR . @@ -168,3 +179,6 @@ package require dde tk(n), winfo(n), send(n) .SH KEYWORDS application, dde, name, remote execution +'\"Local Variables: +'\"mode: nroff +'\"End: diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 71b03a9..e917570 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1164,13 +1164,19 @@ DdeObjCmd( DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; static const char *const ddeExecOptions[] = { - "-async", NULL + "-async", "-binary", NULL + }; + enum DdeExecOptions { + DDE_EXEC_ASYNC, DDE_EXEC_BINARY + }; + static const char *const ddePokeOptions[] = { + "-binary", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL }; - int index, i, length; + int index, i, length, argIndex; int async = 0, binary = 0, exact = 0; int result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; @@ -1198,7 +1204,6 @@ DdeObjCmd( switch ((enum DdeSubcommands) index) { case DDE_SERVERNAME: for (i = 2; i < objc; i++) { - int argIndex; if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, "option", 0, &argIndex) != TCL_OK) { /* @@ -1245,39 +1250,52 @@ DdeObjCmd( if (objc == 5) { firstArg = 2; break; - } else if (objc == 6) { - int dummy; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, - &dummy) == TCL_OK) { - async = 1; - firstArg = 3; - break; + } else if (objc >= 6 && objc <= 7) { + firstArg = objc - 3; + for (i = 2; i < firstArg; i++) { + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, + "option", 0, &argIndex) != TCL_OK) { + return TCL_ERROR; + } + if (argIndex == DDE_EXEC_ASYNC) { + async = 1; + } else { + binary = 1; + } } + break; } /* otherwise... */ Tcl_WrongNumArgs(interp, 2, objv, - "?-async? serviceName topicName value"); + "?-async? ?-binary? serviceName topicName value"); return TCL_ERROR; case DDE_POKE: - if (objc != 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "serviceName topicName item value"); - return TCL_ERROR; + if (objc == 6) { + firstArg = 2; + break; + } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddePokeOptions, "option", 0, &argIndex) == TCL_OK)) { + binary = 1; + firstArg = 3; + break; } - firstArg = 2; - break; + + /* + * Otherwise... + */ + + Tcl_WrongNumArgs(interp, 2, objv, + "serviceName ?-binary? topicName item value"); + return TCL_ERROR; case DDE_REQUEST: if (objc == 5) { firstArg = 2; break; - } else if (objc == 6) { - int dummy; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeReqOptions, "option", 0, - &dummy) == TCL_OK) { - binary = 1; - firstArg = 3; - break; - } + } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + binary = 1; + firstArg = 3; + break; } /* @@ -1300,11 +1318,9 @@ DdeObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args"); return TCL_ERROR; } else { - int dummy; - firstArg = 2; if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", - 0, &dummy) == TCL_OK) { + 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; } @@ -1353,8 +1369,15 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - BYTE *dataString = (BYTE *) Tcl_GetStringFromObj( - objv[firstArg + 2], &dataLength); + BYTE *dataString; + + if (binary) { + dataString = (BYTE *) + Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + } else { + dataString = (BYTE *) + Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); + } if (dataLength == 0) { Tcl_SetObjResult(interp, @@ -1415,6 +1438,7 @@ DdeObjCmd( result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; + ddeItem = DdeCreateStringHandleA(ddeInstance, (void *) itemString, CP_WINANSI); if (ddeItem != NULL) { @@ -1428,10 +1452,11 @@ DdeObjCmd( const BYTE *dataString = DdeAccessData(ddeData, &tmp); if (binary) { - returnObjPtr = Tcl_NewByteArrayObj(dataString, - (int) tmp); + returnObjPtr = + Tcl_NewByteArrayObj(dataString, (int) tmp); } else { - returnObjPtr = Tcl_NewStringObj((char*)dataString,-1); + returnObjPtr = + Tcl_NewStringObj((char *) dataString, -1); } DdeUnaccessData(ddeData); DdeFreeDataHandle(ddeData); @@ -1457,8 +1482,13 @@ DdeObjCmd( result = TCL_ERROR; goto cleanup; } - dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3], - &length); + if (binary) { + dataString = (BYTE *) + Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); + } else { + dataString = (BYTE *) + Tcl_GetStringFromObj(objv[firstArg + 3], &length); + } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); -- cgit v0.12 From 21ffddf58f04c4a455f133435b83bc79da913805 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 3 May 2012 09:29:06 +0000 Subject: add some tests --- tests/winDde.test | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/winDde.test b/tests/winDde.test index ca50a96..bd5ef73 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -156,6 +156,20 @@ test winDde-3.5 {DDE request locally} {win dde} { dde execute TclEval self {set a "foo"} dde request -binary TclEval self a } "foo\x00" +# Set variable a to A with diaeresis (unicode C4) by relying on the fact +# that utf8 is sent (e.g. "c3 84" on the wire) +test winDde-3.6 {DDE request utf8} {win dde} { + set a "not set" + dde execute TclEval self "set a \xc4" + scan $a %c +} 196 +# Set variable a to A with diaeresis (unicode C4) using binary execute +# and compose utf-8 (e.g. "c3 84" ) manualy +test winDde-3.7 {DDE request binary} {win dde} { + set a "not set" + dde execute -binary TclEval self "set a \xc3\x84" + scan $a %c +} 196 # ------------------------------------------------------------------------- -- cgit v0.12 From 8622e716bb6d347375ac273af7b73c6f7952f223 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 May 2012 09:07:07 +0000 Subject: fix test-cases winDde 5.1 and 5.3 --- tests/winDde.test | 4 ++-- win/tclWinDde.c | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/winDde.test b/tests/winDde.test index bd5ef73..d4a3a79 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -216,13 +216,13 @@ test winDde-4.4 {DDE eval remotely} {stdio win dde} { test winDde-5.1 {check for bad arguments} -constraints {win dde} -body { dde execute "" "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} +} -returnCodes error -result {ambiguous option "": must be -async or -binary} test winDde-5.2 {check for bad arguments} -constraints {win dde} -body { dde execute "" "" "" } -returnCodes error -result {cannot execute null data} test winDde-5.3 {check for bad arguments} -constraints {win dde} -body { dde execute -foo "" "" "" -} -returnCodes error -result {wrong # args: should be "dde execute ?-async? serviceName topicName value"} +} -returnCodes error -result {bad option "-foo": must be -async or -binary} test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body { dde eval "" "foo" } -returnCodes error -result {invalid service name ""} diff --git a/win/tclWinDde.c b/win/tclWinDde.c index e917570..83c2aa3 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1253,7 +1253,7 @@ DdeObjCmd( } else if (objc >= 6 && objc <= 7) { firstArg = objc - 3; for (i = 2; i < firstArg; i++) { - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, + if (Tcl_GetIndexFromObj(interp, objv[2], ddeExecOptions, "option", 0, &argIndex) != TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From a55cf4a7e5aa5b506929c232ed2a3c8402a41852 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 May 2012 09:26:53 +0000 Subject: another bug: [dde eval -async -binary] didn't work --- tests/winDde.test | 4 ++-- win/tclWinDde.c | 5 +++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/tests/winDde.test b/tests/winDde.test index d4a3a79..729b05e 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -216,13 +216,13 @@ test winDde-4.4 {DDE eval remotely} {stdio win dde} { test winDde-5.1 {check for bad arguments} -constraints {win dde} -body { dde execute "" "" "" "" -} -returnCodes error -result {ambiguous option "": must be -async or -binary} +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} test winDde-5.2 {check for bad arguments} -constraints {win dde} -body { dde execute "" "" "" } -returnCodes error -result {cannot execute null data} test winDde-5.3 {check for bad arguments} -constraints {win dde} -body { dde execute -foo "" "" "" -} -returnCodes error -result {bad option "-foo": must be -async or -binary} +} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} test winDde-5.4 {DDE eval bad arguments} -constraints {win dde} -body { dde eval "" "foo" } -returnCodes error -result {invalid service name ""} diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 83c2aa3..11e713b 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1253,9 +1253,9 @@ DdeObjCmd( } else if (objc >= 6 && objc <= 7) { firstArg = objc - 3; for (i = 2; i < firstArg; i++) { - if (Tcl_GetIndexFromObj(interp, objv[2], ddeExecOptions, + if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, "option", 0, &argIndex) != TCL_OK) { - return TCL_ERROR; + goto wrongDdeExecuteArgs; } if (argIndex == DDE_EXEC_ASYNC) { async = 1; @@ -1266,6 +1266,7 @@ DdeObjCmd( break; } /* otherwise... */ + wrongDdeExecuteArgs: Tcl_WrongNumArgs(interp, 2, objv, "?-async? ?-binary? serviceName topicName value"); return TCL_ERROR; -- cgit v0.12 From 2f53eeab0b9831c99ec00b1728bcd2821e3d46ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 May 2012 12:50:31 +0000 Subject: fix handling of closing '\0' for -binary data update dde version to 1.4.0 --- library/dde/pkgIndex.tcl | 6 +++--- tests/winDde.test | 2 +- win/Makefile.in | 12 ++++++------ win/configure | 4 ++-- win/configure.in | 4 ++-- win/tclWinDde.c | 10 ++++++---- 6 files changed, 20 insertions(+), 18 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index ce92028..1370567 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ -if {![package vsatisfies [package provide Tcl] 8.5]} return +if {![package vsatisfies [package provide Tcl] 8.4]} return if {[string compare [info sharedlibextension] .dll]} return if {[::tcl::pkgconfig get debug]} { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde] + package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] } else { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde] + package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde] } diff --git a/tests/winDde.test b/tests/winDde.test index 729b05e..bc64a24 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -167,7 +167,7 @@ test winDde-3.6 {DDE request utf8} {win dde} { # and compose utf-8 (e.g. "c3 84" ) manualy test winDde-3.7 {DDE request binary} {win dde} { set a "not set" - dde execute -binary TclEval self "set a \xc3\x84" + dde execute -binary TclEval self "set a \xc3\x84\x00" scan $a %c } 196 diff --git a/win/Makefile.in b/win/Makefile.in index 8492b8f..111f455 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -606,23 +606,23 @@ install-binaries: binaries done @if [ -f $(DDE_DLL_FILE) ]; then \ echo installing $(DDE_DLL_FILE); \ - $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde1.3; \ + $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/dde1.3; \ + $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo installing $(DDE_LIB_FILE); \ - $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.3; \ + $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ fi @if [ -f $(REG_DLL_FILE) ]; then \ echo installing $(REG_DLL_FILE); \ - $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.3; \ + $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/reg1.3; \ + $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi @if [ -f $(REG_LIB_FILE) ]; then \ echo installing $(REG_LIB_FILE); \ - $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.3; \ + $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi install-libraries: libraries install-tzdata install-msgs diff --git a/win/configure b/win/configure index 6673ecb..af014b4 100755 --- a/win/configure +++ b/win/configure @@ -1316,8 +1316,8 @@ VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=3 -TCL_DDE_PATCH_LEVEL="2" +TCL_DDE_MINOR_VERSION=4 +TCL_DDE_PATCH_LEVEL="0" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION TCL_REG_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index 1bab810..36a996c 100644 --- a/win/configure.in +++ b/win/configure.in @@ -19,8 +19,8 @@ VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=3 -TCL_DDE_PATCH_LEVEL="2" +TCL_DDE_MINOR_VERSION=4 +TCL_DDE_PATCH_LEVEL="0" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION TCL_REG_VERSION=1.3 diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 387c05a..9645c68 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -88,7 +88,7 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.3.3" +#define TCL_DDE_VERSION "1.4.0" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME TEXT("TclEval") #define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") @@ -1395,9 +1395,10 @@ DdeObjCmd( } else { dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); + dataLength += 1; } - if (dataLength == 0) { + if (dataLength <= (binary ? 0 : sizeof(TCHAR))) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); @@ -1415,7 +1416,7 @@ DdeObjCmd( } ddeData = DdeCreateDataHandle(ddeInstance, dataString, - (DWORD) dataLength+1, 0, 0, CF_TEXT, 0); + (DWORD) dataLength, 0, 0, CF_TEXT, 0); if (ddeData != NULL) { if (async) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, @@ -1504,6 +1505,7 @@ DdeObjCmd( } else { dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3], &length); + length += 1; } hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); @@ -1517,7 +1519,7 @@ DdeObjCmd( ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, CP_WINUNICODE); if (ddeItem != NULL) { - ddeData = DdeClientTransaction(dataString, (DWORD) length+1, + ddeData = DdeClientTransaction(dataString, (DWORD) length, hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); -- cgit v0.12 From a3a3198dfe08f980f9895d03c2a31a6c302c21dc Mon Sep 17 00:00:00 2001 From: andreask Date: Thu, 17 May 2012 21:45:35 +0000 Subject: Fix for bug 3525907. Reworked TransformInput() entirely, tightened use of timed events, and added code handling special situations like EAGAIN, parent eof, etc. --- generic/tclIORTrans.c | 2 +- generic/tclZlib.c | 306 +++++++++++++++++++++++++++++++++++++++++--------- 2 files changed, 257 insertions(+), 51 deletions(-) diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 6c9a41b..5d99f73 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -1230,7 +1230,7 @@ ReflectInput( * * ReflectOutput -- * - * This function is invoked when data is writen to the channel. + * This function is invoked when data is written to the channel. * * Results: * The number of bytes actually written. diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 3673833..540b779 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -17,6 +17,7 @@ #include "tclInt.h" #ifdef HAVE_ZLIB #include +#include "tclIO.h" /* * Magic flags used with wbits fields to indicate that we're handling the gzip @@ -90,6 +91,7 @@ typedef struct { GzipHeader outHeader; /* Header to write to an output stream, when * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ + Tcl_DString result; /* Buffer for decompression results */ } ZlibChannelData; /* @@ -119,6 +121,12 @@ typedef struct { #define TRANSFORM_FLUSH_DELAY 5 /* + * Convenience macro to make some casts easier to use. + */ + +#define UCHARP(x) ((unsigned char *) (x)) + +/* * Prototypes for private procedures defined later in this file: */ @@ -147,6 +155,9 @@ static void ZlibTransformTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); static void ZlibTransformTimerSetup(ZlibChannelData *cd); +static int ResultCopy(Tcl_DString* r, unsigned char *buf, int toRead); +static int ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr); + /* * Type of zlib-based compressing and decompressing channels. */ @@ -2320,6 +2331,8 @@ ZlibTransformClose( * Release all memory. */ + Tcl_DStringFree (&cd->result); + if (cd->inBuffer) { ckfree(cd->inBuffer); cd->inBuffer = NULL; @@ -2342,77 +2355,130 @@ ZlibTransformInput( ZlibChannelData *cd = instanceData; Tcl_DriverInputProc *inProc = Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent)); - int e, readBytes, flush = Z_NO_FLUSH; + int readBytes, gotBytes, copied; if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) { return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead, errorCodePtr); } - cd->inStream.next_out = (Bytef *) buf; - cd->inStream.avail_out = toRead; - if (cd->inStream.next_in == NULL) { - goto doReadFirst; - } - while (1) { - e = inflate(&cd->inStream, flush); - if ((e == Z_STREAM_END) || (e==Z_OK && cd->inStream.avail_out==0)) { - return toRead - cd->inStream.avail_out; - } - + gotBytes = 0; + while (toRead > 0) { /* - * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html - * - * Just indicates that the zlib couldn't consume input/produce output, - * and is fixed by supplying more input. + * Loop until the request is satisfied (or no data available from + * below, possibly EOF). */ - if ((e != Z_OK) && (e != Z_BUF_ERROR)) { - Tcl_Obj *errObj = Tcl_NewListObj(0, NULL); + copied = ResultCopy(&cd->result, UCHARP(buf), toRead); + toRead -= copied; + buf += copied; + gotBytes += copied; - Tcl_ListObjAppendElement(NULL, errObj, - Tcl_NewStringObj(cd->inStream.msg, -1)); - Tcl_SetChannelError(cd->parent, errObj); - *errorCodePtr = EINVAL; - return -1; + if (toRead == 0) { + goto stop; } /* - * Check if the inflate stopped early. + * The buffer is exhausted, but the caller wants even more. We now + * have to go to the underlying channel, get more bytes and then + * transform them for delivery. We may not get what we want (full EOF + * or temporarily out of data). + * + * Length (cd->result) == 0, toRead > 0 here. + * + * The zlib transform allows us to read at most one character from the + * underlying channel to properly identify Z_STREAM_END without + * reading over the border. */ - if (cd->inStream.avail_in > 0) { - continue; + readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); + + if (readBytes < 0) { + /* + * Report errors to caller. The state of the seek system is + * unchanged! + */ + + if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { + /* + * EAGAIN is a special situation. If we had some data before + * we report that instead of the request to re-try. + */ + + goto stop; + } + + *errorCodePtr = Tcl_GetErrno(); + goto error; } - /* - * Emptied the buffer of data from the underlying channel. Get some - * more. - */ + if (readBytes == 0) { + /* + * Check wether we hit on EOF in 'parent' or not. If not + * differentiate between blocking and non-blocking modes. In + * non-blocking mode we ran temporarily out of data. Signal this + * to the caller via EWOULDBLOCK and error return (-1). In the + * other cases we simply return what we got and let the caller + * wait for more. On the other hand, if we got an EOF we have to + * convert and flush all waiting partial data. + */ + + if (!Tcl_Eof(cd->parent)) { + /* + * The state of the seek system is unchanged! + */ + + if ((gotBytes == 0) && (cd->flags & ASYNC)) { + *errorCodePtr = EWOULDBLOCK; + goto error; + } + goto stop; + } else { + /* + * (Semi-)Eof in parent. + * + * Now this is a bit different. The partial data waiting is + * converted and returned. + */ + + if (ResultGenerate (cd, 0, Z_SYNC_FLUSH, errorCodePtr) < 0) { + goto error; + } + + if (Tcl_DStringLength(&cd->result) == 0) { + /* + * The drain delivered nothing. + */ + + goto stop; + } + + /* + * Reset eof, force caller to drain result buffer. + */ + + ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF; + continue; /* at: while (toRead > 0) */ + } + } /* readBytes == 0 */ - doReadFirst: /* - * Hack for Bug 2762041. Disable pre-reading of lots of input, read - * only one character. This way the Z_END_OF_STREAM can be read - * without triggering an EOF in the base channel. The higher input - * loops in DoReadChars() would react to that by stopping, despite the - * transform still having data which could be read. - * - * This is only a hack because other transforms may not be able to - * work around the general problem in this way. + * Transform the read chunk, which was not empty. Anything we get back + * is a transformation result to be put into our buffers, and the next + * iteration will put it into the result. */ - readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); - if (readBytes < 0) { - *errorCodePtr = Tcl_GetErrno(); - return -1; - } else if (readBytes == 0) { - flush = Z_SYNC_FLUSH; + if (ResultGenerate (cd, readBytes, Z_NO_FLUSH, errorCodePtr) < 0) { + goto error; } + } /* while toRead > 0 */ - cd->inStream.next_in = (Bytef *) cd->inBuffer; - cd->inStream.avail_in = readBytes; - } + stop: + return gotBytes; + + error: + gotBytes = -1; + goto stop; } static int @@ -2521,6 +2587,11 @@ ZlibTransformSetOption( /* not used */ return Tcl_BadChannelOption(interp, optionName, chanOptions); } + /* + * Pass all unknown options down, to deeper transforms and/or the base + * channel. + */ + return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp, optionName, value); } @@ -2615,8 +2686,9 @@ ZlibTransformWatch( watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent)); watchProc(Tcl_GetChannelInstanceData(cd->parent), mask); - if (!(mask & TCL_READABLE) - || (cd->inStream.avail_in == (uInt) cd->inAllocated)) { + + if (!(mask & TCL_READABLE) || + (Tcl_DStringLength(&cd->result) == 0)) { ZlibTransformTimerKill(cd); } else { ZlibTransformTimerSetup(cd); @@ -2804,6 +2876,8 @@ ZlibStackChannelTransform( } } + Tcl_DStringInit(&cd->result); + chan = Tcl_StackChannel(interp, &zlibChannelType, cd, Tcl_GetChannelMode(channel), channel); if (chan == NULL) { @@ -2829,6 +2903,138 @@ ZlibStackChannelTransform( /* *---------------------------------------------------------------------- + * + * ResultCopy -- + * + * Copies the requested number of bytes from the buffer into the + * specified array and removes them from the buffer afterward. Copies + * less if there is not enough data in the buffer. + * + * Side effects: + * See above. + * + * Result: + * The number of actually copied bytes, possibly less than 'toRead'. + * + *---------------------------------------------------------------------- + */ + +static int +ResultCopy( + Tcl_DString* ds, /* The buffer to read from */ + unsigned char *buf, /* The buffer to copy into */ + int toRead) /* Number of requested bytes */ +{ + int copied; + int have = Tcl_DStringLength (ds); + + if (have == 0) { + /* + * Nothing to copy in the case of an empty buffer. + */ + + copied = 0; + } else if (have > toRead) { + /* + * The internal buffer contains more than requested. Copy the + * requested subset to the caller, shift the remaining bytes down, and + * truncate. + */ + + char* src = Tcl_DStringValue (ds); + + memcpy(buf, src, toRead); + memmove(src, src + toRead, have - toRead); + + Tcl_DStringSetLength (ds, have - toRead); + copied = toRead; + } else /* have <= toRead */ { + /* + * There is just or not enough in the buffer to fully satisfy the + * caller, so take everything as best effort. + */ + + memcpy(buf, Tcl_DStringValue (ds), have); + Tcl_DStringSetLength (ds, 0); + copied = have; + } + + /* -- common postwork code ------- */ + + return copied; +} + +static int +ResultGenerate(ZlibChannelData *cd, int n, int flush, int* errorCodePtr) +{ +#define MAXBUF 1024 + unsigned char buf [MAXBUF]; + int e, written; + + cd->inStream.next_in = (Bytef *) cd->inBuffer; + cd->inStream.avail_in = n; + + while (1) { + cd->inStream.next_out = (Bytef *) buf; + cd->inStream.avail_out = MAXBUF; + + e = inflate(&cd->inStream, flush); + + /* + * avail_out is now the left over space in the output. + * Therefore "MAXBUF - avail_out" is the amount of bytes + * generated. + */ + + written = MAXBUF - cd->inStream.avail_out; + + if (written) { + Tcl_DStringAppend (&cd->result, (char*) buf, written); + } + + if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) || + (e == Z_STREAM_END) || + (e==Z_OK && cd->inStream.avail_out==0)) { + break; + } + + /* + * Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html + * + * Just indicates that the zlib couldn't consume input/produce output, + * and is fixed by supplying more input. + */ + + if ((e != Z_OK) && (e != Z_BUF_ERROR)) { + Tcl_Obj *errObj = Tcl_NewListObj(0, NULL); + + Tcl_ListObjAppendElement(NULL, errObj, + Tcl_NewStringObj(cd->inStream.msg, -1)); + Tcl_SetChannelError(cd->parent, errObj); + *errorCodePtr = EINVAL; + return -1; + } + + /* + * Check if the inflate stopped early. + */ + + if (cd->inStream.avail_in > 0) { + continue; + } + + if (flush == Z_SYNC_FLUSH) { + continue; + } + + break; + } + + return 0; +} + +/* + *---------------------------------------------------------------------- * Finally, the TclZlibInit function. Used to install the zlib API. *---------------------------------------------------------------------- */ -- cgit v0.12 From 40ff07a07969afd5de9232f869a9405dcc68f2a4 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 20 May 2012 07:58:11 +0000 Subject: * generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut the amount of hackiness in class constructors, and refactor some of the error message handling from [oo::define] to be saner in the face of odd happenings. --- ChangeLog | 7 +++ generic/tclOO.c | 68 ++++++++++------------- generic/tclOOBasic.c | 138 +++++++++++++++++++++++----------------------- generic/tclOODefineCmds.c | 103 +++++++++++++++++++++++----------- generic/tclOOInt.h | 9 ++- generic/tclOOMethod.c | 9 --- tests/oo.test | 110 ++++++++++++++++++++++++++++++++++-- 7 files changed, 286 insertions(+), 158 deletions(-) diff --git a/ChangeLog b/ChangeLog index e8cecb8..842695f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2012-05-20 Donal K. Fellows + + * generic/tclOOBasic.c (TclOO_Class_Constructor): [Bug 2023112]: Cut + the amount of hackiness in class constructors, and refactor some of + the error message handling from [oo::define] to be saner in the face + of odd happenings. + 2012-05-17 Donal K. Fellows * generic/tclCmdMZ.c (Tcl_SwitchObjCmd): [Bug 3106532]: Corrected diff --git a/generic/tclOO.c b/generic/tclOO.c index d5cc6e1..26e6d75 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -123,6 +123,16 @@ static const DeclaredClassMethod objMethods[] = { }; /* + * And for the oo::class constructor... + */ + +static const Tcl_MethodType classConstructor = { + TCL_OO_METHOD_VERSION_CURRENT, + "oo::class constructor", + TclOO_Class_Constructor, NULL, NULL +}; + +/* * Scripted parts of TclOO. First, the master script (cannot be outside this * file). */ @@ -135,18 +145,6 @@ static const char *initScript = /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The body of the constructor for oo::class. - */ - -static const char *classConstructorBody = -"set script [list ::oo::define [self] $definitionScript];" -"lassign [::oo::UpCatch $script] msg opts;" -"if {[dict get $opts -code] == 1} {" -" dict set opts -errorline 0xDeadBeef" -"};" -"return -options $opts $msg;"; - -/* * The scripted part of the definitions of slots. */ @@ -340,12 +338,12 @@ InitFoundation( TclNewLiteralStringObj(fPtr->constructorName, ""); TclNewLiteralStringObj(fPtr->destructorName, ""); TclNewLiteralStringObj(fPtr->clonedName, ""); + TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); Tcl_IncrRefCount(fPtr->clonedName); - Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd, - TclOONRUpcatch, NULL, NULL); + Tcl_IncrRefCount(fPtr->defineName); Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition", TclOOUnknownDefinition, NULL, NULL); TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition"); @@ -418,28 +416,19 @@ InitFoundation( bodyPtr = Tcl_NewStringObj(clonedBody, -1); TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, bodyPtr, NULL); - Tcl_DecrRefCount(argsPtr); + TclDecrRefCount(argsPtr); /* * Finish setting up the class of classes by marking the 'new' method as * private; classes, unlike general objects, must have explicit names. We * also need to create the constructor for classes. - * - * The 0xDeadBeef is a special signal to the errorInfo logger that is used - * by constructors that stops it from generating extra error information - * that is confusing. */ TclNewLiteralStringObj(namePtr, "new"); Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL); - - TclNewLiteralStringObj(argsPtr, "{definitionScript {}}"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(classConstructorBody, -1); - fPtr->classCls->constructorPtr = TclOONewProcMethod(interp, - fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL); - Tcl_DecrRefCount(argsPtr); + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); /* * Create non-object commands and plug ourselves into the Tcl [info] @@ -529,10 +518,11 @@ KillFoundation( DelRef(fPtr->objectCls->thisPtr); DelRef(fPtr->objectCls); - Tcl_DecrRefCount(fPtr->unknownMethodNameObj); - Tcl_DecrRefCount(fPtr->constructorName); - Tcl_DecrRefCount(fPtr->destructorName); - Tcl_DecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->unknownMethodNameObj); + TclDecrRefCount(fPtr->constructorName); + TclDecrRefCount(fPtr->destructorName); + TclDecrRefCount(fPtr->clonedName); + TclDecrRefCount(fPtr->defineName); ckfree(fPtr); } @@ -789,7 +779,7 @@ ObjectRenamedTrace( if (flags & TCL_TRACE_RENAME) { if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); + TclDecrRefCount(oPtr->cachedNameObj); oPtr->cachedNameObj = NULL; } return; @@ -1044,7 +1034,7 @@ ReleaseClassContents( Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; @@ -1123,7 +1113,7 @@ ObjectNamespaceDeleted( } FOREACH(filterObj, oPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } if (i) { ckfree(oPtr->filters.list); @@ -1138,7 +1128,7 @@ ObjectNamespaceDeleted( } FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); + TclDecrRefCount(variableObj); } if (i) { ckfree(oPtr->variables.list); @@ -1149,7 +1139,7 @@ ObjectNamespaceDeleted( } if (oPtr->cachedNameObj) { - Tcl_DecrRefCount(oPtr->cachedNameObj); + TclDecrRefCount(oPtr->cachedNameObj); oPtr->cachedNameObj = NULL; } @@ -1180,7 +1170,7 @@ ObjectNamespaceDeleted( } FOREACH(filterObj, clsPtr->filters) { - Tcl_DecrRefCount(filterObj); + TclDecrRefCount(filterObj); } if (i) { ckfree(clsPtr->filters.list); @@ -1225,7 +1215,7 @@ ObjectNamespaceDeleted( TclOODelMethodRef(clsPtr->destructorPtr); FOREACH(variableObj, clsPtr->variables) { - Tcl_DecrRefCount(variableObj); + TclDecrRefCount(variableObj); } if (i) { ckfree(clsPtr->variables.list); @@ -2490,7 +2480,7 @@ TclOOObjectCmdCore( result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, (Tcl_Class *) startClsPtr, mappedMethodName); if (result != TCL_OK) { - Tcl_DecrRefCount(mappedMethodName); + TclDecrRefCount(mappedMethodName); if (result == TCL_BREAK) { goto noMapping; } else if (result == TCL_ERROR) { @@ -2506,7 +2496,7 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); - Tcl_DecrRefCount(mappedMethodName); + TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_AppendResult(interp, "impossible to invoke method \"", TclGetString(methodNamePtr), diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 329f0a4..5e983fc 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -19,6 +19,8 @@ static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); static int AfterNRDestructor(ClientData data[], Tcl_Interp *interp, int result); +static int DecrRefsPostClassConstructor(ClientData data[], + Tcl_Interp *interp, int result); static int FinalizeConstruction(ClientData data[], Tcl_Interp *interp, int result); static int FinalizeEval(ClientData data[], @@ -70,6 +72,74 @@ FinalizeConstruction( /* * ---------------------------------------------------------------------- * + * TclOO_Class_Constructor -- + * + * Implementation for oo::class constructor. + * + * ---------------------------------------------------------------------- + */ + +int +TclOO_Class_Constructor( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + Tcl_Obj *invoke[3]; + + if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, + "?definitionScript?"); + return TCL_ERROR; + } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { + return TCL_OK; + } + + /* + * Delegate to [oo::define] to do the work. + */ + + invoke[0] = oPtr->fPtr->defineName; + invoke[1] = TclOOObjectName(interp, oPtr); + invoke[2] = objv[objc-1]; + + /* + * Must add references or errors in configuration script will cause + * trouble. + */ + + Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); + Tcl_IncrRefCount(invoke[2]); + TclNRAddCallback(interp, DecrRefsPostClassConstructor, + invoke[0], invoke[1], invoke[2], NULL); + + /* + * Tricky point: do not want the extra reported level in the Tcl stack + * trace, so use TCL_EVAL_NOERR. + */ + + return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); +} + +static int +DecrRefsPostClassConstructor( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); + TclDecrRefCount((Tcl_Obj *) data[2]); + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOO_Class_Create -- * * Implementation for oo::class->create method. @@ -1141,74 +1211,6 @@ TclOOCopyObjectCmd( } /* - * ---------------------------------------------------------------------- - * - * TclOOUpcatchCmd -- - * - * Implementation of the [oo::UpCatch] command, which is a combination of - * [uplevel 1] and [catch] that makes it easier to write transparent - * error handling in scripts. - * - * ---------------------------------------------------------------------- - */ - -int -TclOOUpcatchCmd( - ClientData ignored, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return Tcl_NRCallObjProc(interp, TclOONRUpcatch, NULL, objc, objv); -} - -static int -UpcatchCallback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedFramePtr = data[0]; - Tcl_Obj *resultObj[2]; - int rewind = iPtr->execEnvPtr->rewind; - - iPtr->varFramePtr = savedFramePtr; - if (rewind || Tcl_LimitExceeded(interp)) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (\"UpCatch\" body line %d)", Tcl_GetErrorLine(interp))); - return TCL_ERROR; - } - resultObj[0] = Tcl_GetObjResult(interp); - resultObj[1] = Tcl_GetReturnOptions(interp, result); - Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObj)); - return TCL_OK; -} - -int -TclOONRUpcatch( - ClientData ignored, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - CallFrame *savedFramePtr = iPtr->varFramePtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "script"); - return TCL_ERROR; - } - if (iPtr->varFramePtr->callerVarPtr != NULL) { - iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; - } - - Tcl_NRAddCallback(interp, UpcatchCallback, savedFramePtr, NULL,NULL,NULL); - return TclNREvalObjEx(interp, objv[1], TCL_EVAL_NOERR, - iPtr->cmdFramePtr, 1); -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 3d72690..69cffb0 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -17,6 +17,13 @@ #include "tclOOInt.h" /* + * The maximum length of fully-qualified object name to use in an errorinfo + * message. Longer than this will be curtailed. + */ + +#define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30 + +/* * Some things that make it easier to declare a slot. */ @@ -40,6 +47,8 @@ struct DeclaredSlot { static inline void BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr); static Tcl_Command FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr); +static void GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr, + Tcl_Obj *savedNameObj, const char *typeOfSubject); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); static inline int InitDefineContext(Tcl_Interp *interp, @@ -673,6 +682,7 @@ TclOOGetDefineCmdContext( Tcl_Interp *interp) { Interp *iPtr = (Interp *) interp; + Tcl_Object object; if ((iPtr->varFramePtr == NULL) || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { @@ -682,7 +692,14 @@ TclOOGetDefineCmdContext( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return NULL; } - return (Tcl_Object) iPtr->varFramePtr->clientData; + object = iPtr->varFramePtr->clientData; + if (Tcl_ObjectDeleted(object)) { + Tcl_AppendResult(interp, "this command cannot be called when the " + "object has been deleted", NULL); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return NULL; + } + return object; } /* @@ -730,6 +747,44 @@ GetClassInOuterContext( /* * ---------------------------------------------------------------------- * + * GenerateErrorInfo -- + * Factored out code to generate part of the error trace messages. + * + * ---------------------------------------------------------------------- + */ + +static void +GenerateErrorInfo( + Tcl_Interp *interp, /* Where to store the error info trace. */ + Object *oPtr, /* What object (or class) was being configured + * when the error occurred? */ + Tcl_Obj *savedNameObj, /* Name of object saved from before script was + * evaluated, which is needed if the object + * goes away part way through execution. OTOH, + * if the object isn't deleted then its + * current name (post-execution) has to be + * used. This matters, because the object + * could have been renamed... */ + const char *typeOfSubject) /* Part of the message, saying whether it was + * an object, class or class-as-object that + * was being configured. */ +{ + int length; + Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) + ? savedNameObj : TclOOObjectName(interp, oPtr); + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; + int overflow = (length > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in definition script for %s \"%.*s%s\" line %d)", + typeOfSubject, (overflow ? limit : length), objName, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineObjCmd -- * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the @@ -779,20 +834,15 @@ TclOODefineObjCmd( AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj(objv[1], &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + GenerateErrorInfo(interp, oPtr, objNameObj, "class"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -898,20 +948,15 @@ TclOOObjDefObjCmd( AddRef(oPtr); if (objc == 3) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[2], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj(objv[1], &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + GenerateErrorInfo(interp, oPtr, objNameObj, "object"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; @@ -1017,21 +1062,15 @@ TclOODefineSelfObjCmd( AddRef(oPtr); if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, ((Interp *)interp)->cmdFramePtr, 2); - if (result == TCL_ERROR) { - int length; - const char *objName = Tcl_GetStringFromObj( - TclOOObjectName(interp, oPtr), &length); - int limit = 60; - int overflow = (length > limit); - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in definition script for object \"%.*s%s\" line %d)", - (overflow ? limit : length), objName, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } + TclDecrRefCount(objNameObj); } else { Tcl_Obj *objPtr, *obj2Ptr, **objs; Interp *iPtr = (Interp *) interp; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 7988452..631961f 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -322,6 +322,7 @@ typedef struct Foundation { * destructor. */ Tcl_Obj *clonedName; /* Shared object containing the name of a * "" pseudo-constructor. */ + Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ } Foundation; /* @@ -453,6 +454,9 @@ MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, * Method implementations (in tclOOBasic.c). */ +MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -519,8 +523,6 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_Obj *const *objv, int skip); MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); -MODULE_SCOPE int TclOONRUpcatch(ClientData ignored, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr, @@ -532,9 +534,6 @@ MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp, MODULE_SCOPE void TclOOStashContext(Tcl_Obj *objPtr, CallContext *contextPtr); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); -MODULE_SCOPE int TclOOUpcatchCmd(ClientData ignored, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); /* * Include all the private API, generated from tclOO.decls. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 4e7edb8..877c3db 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1204,15 +1204,6 @@ ConstructorErrorHandler( const char *objectName, *kindName; int objectNameLen; - if (Tcl_GetErrorLine(interp) == (int) 0xDEADBEEF) { - /* - * Horrible hack to deal with certain constructors that must not add - * information to the error trace. - */ - - return; - } - if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; kindName = "object"; diff --git a/tests/oo.test b/tests/oo.test index f3c0bda..00663e9 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -1974,7 +1974,7 @@ test oo-18.1 {OO: define command support} { } {1 foo {foo while executing "error foo" - (in definition script for object "oo::object" line 1) + (in definition script for class "::oo::object" line 1) invoked from within "oo::define oo::object {error foo}"}} test oo-18.2 {OO: define command support} { @@ -1987,7 +1987,7 @@ test oo-18.3 {OO: define command support} { } {1 bar {bar while executing "error bar" - (in definition script for object "::foo" line 1) + (in definition script for class "::foo" line 1) invoked from within "oo::class create foo {error bar}"}} test oo-18.3a {OO: define command support} { @@ -1997,7 +1997,7 @@ test oo-18.3a {OO: define command support} { } {1 bar {bar while executing "error bar" - (in definition script for object "::foo" line 2) + (in definition script for class "::foo" line 2) invoked from within "oo::class create foo { error bar @@ -2015,7 +2015,7 @@ test oo-18.3b {OO: define command support} { ("eval" body line 1) invoked from within "eval eval error bar" - (in definition script for object "::foo" line 2) + (in definition script for class "::foo" line 2) invoked from within "oo::class create foo { eval eval error bar @@ -2070,6 +2070,106 @@ test oo-18.5 {OO: more error traces from the guts} -setup { (class "::cls" method "eval" line 1) invoked from within "obj eval {error bar}"}} +test oo-18.6 {class construction reference management and errors} -setup { + oo::class create super_abc +} -body { + catch { +oo::class create abc { + superclass super_abc + ::rename abc ::def + ::error foo +} + } msg opt + dict get $opt -errorinfo +} -cleanup { + super_abc destroy +} -result {foo + while executing +"::error foo" + (in definition script for class "::def" line 4) + invoked from within +"oo::class create abc { + superclass super_abc + ::rename abc ::def + ::error foo +}"} +test oo-18.7 {OO: objdefine command support} -setup { + oo::object create ::inst +} -body { + list [catch {oo::objdefine inst {rename ::inst ::INST;error foo}} msg] $msg $errorInfo +} -cleanup { + catch {::inst destroy} + catch {::INST destroy} +} -result {1 foo {foo + while executing +"error foo" + (in definition script for object "::INST" line 1) + invoked from within +"oo::objdefine inst {rename ::inst ::INST;error foo}"}} +test oo-18.8 {OO: define/self command support} -setup { + oo::class create master + oo::class create ::foo {superclass master} +} -body { + catch {oo::define foo {rename ::foo ::bar; self {error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {foobar + while executing +"error foobar" + (in definition script for class object "::bar" line 1) + invoked from within +"self {error foobar}" + (in definition script for class "::bar" line 1) + invoked from within +"oo::define foo {rename ::foo ::bar; self {error foobar}}"} +test oo-18.9 {OO: define/self command support} -setup { + oo::class create master + set c [oo::class create now_this_is_a_very_very_long_class_name_indeed { + superclass master + }] +} -body { + catch {oo::define $c {error err}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {err + while executing +"error err" + (in definition script for class "::now_this_is_a_very_very_long..." line 1) + invoked from within +"oo::define $c {error err}"} +test oo-18.10 {OO: define/self command support} -setup { + oo::class create master + oo::class create ::foo {superclass master} +} -body { + catch {oo::define foo {self {rename ::foo {}; error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {foobar + while executing +"error foobar" + (in definition script for class object "::foo" line 1) + invoked from within +"self {rename ::foo {}; error foobar}" + (in definition script for class "::foo" line 1) + invoked from within +"oo::define foo {self {rename ::foo {}; error foobar}}"} +test oo-18.11 {OO: define/self command support} -setup { + oo::class create master + oo::class create ::foo {superclass master} +} -body { + catch {oo::define foo {rename ::foo {}; self {error foobar}}} msg opt + dict get $opt -errorinfo +} -cleanup { + master destroy +} -result {this command cannot be called when the object has been deleted + while executing +"self {error foobar}" + (in definition script for class "::foo" line 1) + invoked from within +"oo::define foo {rename ::foo {}; self {error foobar}}"} test oo-19.1 {OO: varname method} -setup { oo::object create inst @@ -3189,7 +3289,7 @@ test oo-33.2 {TIP 380: slots - defaulting} -setup { } -cleanup { rename $s {} } -result {{} {a b c destroy unknown}} -test oo-32.3 {TIP 380: slots - defaulting} -setup { +test oo-33.3 {TIP 380: slots - defaulting} -setup { set s [SampleSlot new] } -body { oo::objdefine $s forward --default-operation my -set -- cgit v0.12 From dbfa28f04fc02921314fbdeb342585b87557ef8f Mon Sep 17 00:00:00 2001 From: ferrieux Date: Sun, 20 May 2012 20:46:58 +0000 Subject: Add test showing both loss of bytes and empty-fileevent frenzy. --- tests/zlib.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/zlib.test b/tests/zlib.test index d8d710a..4ed5b33 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -169,6 +169,24 @@ test zlib-8.4 {transformation and flushing: Bug 3517696} -setup { catch {close $fd} removeFile $file } -result {} +test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { + foreach {r w} [chan pipe] break +} -constraints zlib -body { + set ::res {} + fconfigure $w -buffering none + zlib push compress $w + puts -nonewline $w qwertyuiop + chan configure $w -flush sync + after 500 {puts -nonewline $w asdfghjkl;close $w} + fconfigure $r -blocking 0 -buffering none + zlib push decompress $r + fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}} + after 250 {lappend ::res MIDDLE} + vwait ::done + set ::res +} -cleanup { + catch {close $r} +} -result {qwertyuiop MIDDLE asdfghjkl} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] -- cgit v0.12 From a89ca11a44b7af7cb1017a6cbaf59f53c3e16ed7 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 May 2012 16:17:11 +0000 Subject: When using Tcl_SetObjLength() calls to grow and shrink the objPtr->bytes buffer, care must be taken that the value cannot possibly become pure Unicode. Calling Tcl_AppendToObj() has the possibility of making such a conversion. Bug found while valgrinding the trunk. --- ChangeLog | 8 ++++++++ generic/tclFileName.c | 4 ++-- generic/tclIOUtil.c | 2 +- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index fad0871..1769bd9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2012-05-21 Don Porter + + * generic/tclFileName.c: When using Tcl_SetObjLength() calls to grow + * generic/tclIOUtil.c: and shrink the objPtr->bytes buffer, care must be + taken that the value cannot possibly become pure Unicode. Calling + Tcl_AppendToObj() has the possibility of making such a conversion. Bug + found while valgrinding the trunk. + 2012-05-17 Donal K. Fellows * doc/expr.n: [Bug 3525462]: Corrected statement about what happens diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 761c8be..c5ecf0f 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1155,7 +1155,7 @@ TclpNativeJoinPath(prefix, joining) if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -1194,7 +1194,7 @@ TclpNativeJoinPath(prefix, joining) if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index d50f2e3..40f3f76 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -4977,7 +4977,7 @@ Tcl_FSJoinPath(listObj, elements) if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - length++; + Tcl_GetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); -- cgit v0.12 From c165b1b8ae2365a2afce837baf0ca643a80fe9c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 May 2012 16:49:48 +0000 Subject: Update requirements to avoid old buggy Thread releases. --- tests/socket.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index f06a548..d88eb65 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -64,7 +64,7 @@ package require tcltest 2 namespace import -force ::tcltest::* # Some tests require the Thread package or exec command -testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] +testConstraint thread [expr {0 == [catch {package require Thread 2.6.6}]}] testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range -- cgit v0.12 From 56312304b98fa9311dc467ce59da8b0e9e3dae4c Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 May 2012 17:08:51 +0000 Subject: Use [package prefer latest] to force valgrinding to use a version of Thread suitable for the whole test suite. --- tests/all.tcl | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/all.tcl b/tests/all.tcl index b436fbe..05d3024 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -10,6 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package prefer latest package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* -- cgit v0.12 From 18e9a6f3e4ca3f54e389e421704129e2cb8d7fd6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 May 2012 12:32:35 +0000 Subject: Increase the timer resolution of test io-29.33b so the timing sensitivity of the test is reduced and failures on slow runs are avoided. --- tests/io.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/io.test b/tests/io.test index e6cea16..386179e 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2748,13 +2748,13 @@ test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { set f [open $path(script2) w] puts $f {after 2000} close $f - set t1 [clock seconds] + set t1 [clock milliseconds] set ff [open "|[list [interpreter] $path(script2)]" w] catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)} exec [interpreter] $path(script) >@ $ff - set t2 [clock seconds] + set t2 [clock milliseconds] close $ff - expr {($t2-$t1)/2} + expr {($t2-$t1)/2000 ? $t2-$t1 : 0} } 0 test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} { variable c 0 -- cgit v0.12 From e6e220f14d2d0b998a5e2e1977116a701371a88f Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 May 2012 15:11:01 +0000 Subject: Avoid calling close() on a bogus fd when an attempt to open a client socket with an unsupported address family leaves one behind. --- unix/tclUnixSock.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index e48cc2b..12e5a9a 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -545,6 +545,9 @@ TcpCloseProc( */ for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { + if (fds->fd < 0) { + continue; + } Tcl_DeleteFileHandler(fds->fd); if (close(fds->fd) < 0) { errorCode = errno; -- cgit v0.12 From f1be70ab35fd454a2234ac10ed10c88b9c884b13 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 May 2012 16:05:24 +0000 Subject: 3528601 Fix broken --disable-threads build. --- generic/tclIORChan.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 2d31da3..938def2 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -934,8 +934,11 @@ TclChanPostEventObjCmd( * We have the channel and the events to post. */ +#ifdef TCL_THREADS if (rcPtr->owner == rcPtr->thread) { +#endif Tcl_NotifyChannel (chan, events); +#ifdef TCL_THREADS } else { ReflectEvent* ev = ckalloc (sizeof (ReflectEvent)); ev->header.proc = ReflectEventRun; @@ -965,6 +968,7 @@ TclChanPostEventObjCmd( Tcl_ThreadQueueEvent (rcPtr->owner, (Tcl_Event*) ev, TCL_QUEUE_TAIL); Tcl_ThreadAlert (rcPtr->owner); } +#endif /* * Squash interp results left by the event script. -- cgit v0.12 From 3cc210b6d0579358daa94a0f3670e30c973b7f34 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Tue, 22 May 2012 20:28:48 +0000 Subject: Use zero-delays instead of finite ones when posting fileevents, because (1) they should be zero in the first place (see UpdateInterest) and (2) ever-reposting cases will be detected with greater ease. --- generic/tclIORTrans.c | 9 +-------- generic/tclZlib.c | 9 +-------- 2 files changed, 2 insertions(+), 16 deletions(-) diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 5d99f73..fd25f2d 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -439,13 +439,6 @@ static const char *msg_dstlost = */ /* - * Number of milliseconds to wait before firing an event to try to flush out - * information waiting in buffers (fileevent support). - */ - -#define FLUSH_DELAY (5) - -/* * Helper functions encapsulating some of the thread forwarding to make the * control flow in callers easier. */ @@ -2861,7 +2854,7 @@ TimerSetup( return; } - rtPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TimerRun, rtPtr); + rtPtr->timer = Tcl_CreateTimerHandler(0, TimerRun, rtPtr); } /* diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 540b779..731176c 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -114,13 +114,6 @@ typedef struct { #define DEFAULT_BUFFER_SIZE 4096 /* - * Time to wait (in milliseconds) before flushing the channel when reading - * data through the transform. - */ - -#define TRANSFORM_FLUSH_DELAY 5 - -/* * Convenience macro to make some casts easier to use. */ @@ -2737,7 +2730,7 @@ ZlibTransformTimerSetup( ZlibChannelData *cd) { if (cd->timer == NULL) { - cd->timer = Tcl_CreateTimerHandler(TRANSFORM_FLUSH_DELAY, + cd->timer = Tcl_CreateTimerHandler(0, ZlibTransformTimerRun, cd); } } -- cgit v0.12 From 565885307e6c24d3a27eaa01d7701dd2819336a8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 May 2012 12:00:02 +0000 Subject: fix [bug 3529063]: 2 minor bugs in TIP #106 implementation --- win/tclWinDde.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 895551a..617e4e5 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -1189,8 +1189,8 @@ DdeObjCmd( enum DdeExecOptions { DDE_EXEC_ASYNC, DDE_EXEC_BINARY }; - static const char *const ddePokeOptions[] = { - "-binary", NULL + static const char *const ddeEvalOptions[] = { + "-async", NULL }; static const char *const ddeReqOptions[] = { "-binary", NULL @@ -1295,7 +1295,7 @@ DdeObjCmd( firstArg = 2; break; } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], - ddePokeOptions, "option", 0, &argIndex) == TCL_OK)) { + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { binary = 1; firstArg = 3; break; @@ -1306,7 +1306,7 @@ DdeObjCmd( */ Tcl_WrongNumArgs(interp, 2, objv, - "serviceName ?-binary? topicName item value"); + "?-binary? serviceName topicName item value"); return TCL_ERROR; case DDE_REQUEST: if (objc == 5) { @@ -1340,7 +1340,7 @@ DdeObjCmd( return TCL_ERROR; } else { firstArg = 2; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; -- cgit v0.12 From 78bbbde35c3f53764827e54afe963af4ea244aa4 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 24 May 2012 09:54:19 +0000 Subject: minor: Cleaning up code, adding comments. --- generic/tclZlib.c | 305 +++++++++++++++++++++++++++++++++--------------------- 1 file changed, 187 insertions(+), 118 deletions(-) diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 0c38602..d4019fc 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -91,7 +91,7 @@ typedef struct { GzipHeader outHeader; /* Header to write to an output stream, when * compressing a gzip stream. */ Tcl_TimerToken timer; /* Timer used for keeping events fresh. */ - Tcl_DString result; /* Buffer for decompression results. */ + Tcl_DString decompressed; /* Buffer for decompression results. */ } ZlibChannelData; /* @@ -114,10 +114,10 @@ typedef struct { #define DEFAULT_BUFFER_SIZE 4096 /* - * Convenience macro to make some casts easier to use. + * Time to wait before delivering a timer event. */ -#define UCHARP(x) ((unsigned char *) (x)) +#define TRANSFORM_TIMEOUT 0 /* * Prototypes for private procedures defined later in this file: @@ -128,7 +128,7 @@ static Tcl_DriverBlockModeProc ZlibTransformBlockMode; static Tcl_DriverCloseProc ZlibTransformClose; static Tcl_DriverGetHandleProc ZlibTransformGetHandle; static Tcl_DriverGetOptionProc ZlibTransformGetOption; -static Tcl_DriverHandlerProc ZlibTransformHandler; +static Tcl_DriverHandlerProc ZlibTransformEventHandler; static Tcl_DriverInputProc ZlibTransformInput; static Tcl_DriverOutputProc ZlibTransformOutput; static Tcl_DriverSetOptionProc ZlibTransformSetOption; @@ -140,7 +140,7 @@ static void ConvertError(Tcl_Interp *interp, int code); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); -static int ResultCopy(Tcl_DString *r, unsigned char *buf, +static inline int ResultCopy(ZlibChannelData *cd, char *buf, int toRead); static int ResultGenerate(ZlibChannelData *cd, int n, int flush, int *errorCodePtr); @@ -148,9 +148,8 @@ static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp, int mode, int format, int level, Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr); static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); -static void ZlibTransformTimerKill(ZlibChannelData *cd); +static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); static void ZlibTransformTimerRun(ClientData clientData); -static void ZlibTransformTimerSetup(ZlibChannelData *cd); /* * Type of zlib-based compressing and decompressing channels. @@ -170,7 +169,7 @@ static const Tcl_ChannelType zlibChannelType = { NULL, /* close2Proc */ ZlibTransformBlockMode, NULL, /* flushProc */ - ZlibTransformHandler, + ZlibTransformEventHandler, NULL, /* wideSeekProc */ NULL, NULL @@ -2264,6 +2263,12 @@ ZlibStreamCmd( *---------------------------------------------------------------------- * Set of functions to support channel stacking. *---------------------------------------------------------------------- + * + * ZlibTransformClose -- + * + * How to shut down a stacked compressing/decompressing transform. + * + *---------------------------------------------------------------------- */ static int @@ -2278,7 +2283,7 @@ ZlibTransformClose( * Delete the support timer. */ - ZlibTransformTimerKill(cd); + ZlibTransformEventTimerKill(cd); /* * Flush any data waiting to be compressed. @@ -2325,7 +2330,7 @@ ZlibTransformClose( * Release all memory. */ - Tcl_DStringFree (&cd->result); + Tcl_DStringFree(&cd->decompressed); if (cd->inBuffer) { ckfree(cd->inBuffer); @@ -2338,6 +2343,16 @@ ZlibTransformClose( ckfree(cd); return result; } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformInput -- + * + * Reader filter that does decompression. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformInput( @@ -2363,13 +2378,13 @@ ZlibTransformInput( * below, possibly EOF). */ - copied = ResultCopy(&cd->result, UCHARP(buf), toRead); + copied = ResultCopy(cd, buf, toRead); toRead -= copied; buf += copied; gotBytes += copied; if (toRead == 0) { - goto stop; + return gotBytes; } /* @@ -2378,7 +2393,7 @@ ZlibTransformInput( * transform them for delivery. We may not get what we want (full EOF * or temporarily out of data). * - * Length (cd->result) == 0, toRead > 0 here. + * Length (cd->decompressed) == 0, toRead > 0 here. * * The zlib transform allows us to read at most one character from the * underlying channel to properly identify Z_STREAM_END without @@ -2387,6 +2402,16 @@ ZlibTransformInput( readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, 1); + /* + * Three cases here: + * 1. Got some data from the underlying channel (readBytes > 0) so + * it should be fed through the decompression engine. + * 2. Got an error (readBytes < 0) which we should report up except + * for the case where we can convert it to a short read. + * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If + * it is EOF, try flushing the data out of the decompressor. + */ + if (readBytes < 0) { /* * Report errors to caller. The state of the seek system is @@ -2399,16 +2424,14 @@ ZlibTransformInput( * we report that instead of the request to re-try. */ - goto stop; + return gotBytes; } *errorCodePtr = Tcl_GetErrno(); - goto error; - } - - if (readBytes == 0) { + return -1; + } else if (readBytes == 0) { /* - * Check wether we hit on EOF in 'parent' or not. If not + * Check wether we hit on EOF in 'parent' or not. If not, * differentiate between blocking and non-blocking modes. In * non-blocking mode we ran temporarily out of data. Signal this * to the caller via EWOULDBLOCK and error return (-1). In the @@ -2424,56 +2447,61 @@ ZlibTransformInput( if ((gotBytes == 0) && (cd->flags & ASYNC)) { *errorCodePtr = EWOULDBLOCK; - goto error; - } - goto stop; - } else { - /* - * (Semi-)Eof in parent. - * - * Now this is a bit different. The partial data waiting is - * converted and returned. - */ - - if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) < 0) { - goto error; + return -1; } + return gotBytes; + } - if (Tcl_DStringLength(&cd->result) == 0) { - /* - * The drain delivered nothing. - */ + /* + * (Semi-)Eof in parent. + * + * Now this is a bit different. The partial data waiting is + * converted and returned. + */ - goto stop; - } + if (ResultGenerate(cd, 0, Z_SYNC_FLUSH, errorCodePtr) != TCL_OK) { + return -1; + } + if (Tcl_DStringLength(&cd->decompressed) == 0) { /* - * Reset eof, force caller to drain result buffer. + * The drain delivered nothing. Time to deliver what we've + * got. */ - ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF; - continue; /* at: while (toRead > 0) */ + return gotBytes; } - } /* readBytes == 0 */ - /* - * Transform the read chunk, which was not empty. Anything we get back - * is a transformation result to be put into our buffers, and the next - * iteration will put it into the result. - */ + /* + * Reset eof, force caller to drain result buffer. + */ - if (ResultGenerate(cd, readBytes, Z_NO_FLUSH, errorCodePtr) < 0) { - goto error; - } - } /* while toRead > 0 */ + ((Channel *) cd->parent)->state->flags &= ~CHANNEL_EOF; + } else /* readBytes > 0 */ { + /* + * Transform the read chunk, which was not empty. Anything we get + * back is a transformation result to be put into our buffers, and + * the next iteration will put it into the result. + */ - stop: + if (ResultGenerate(cd, readBytes, Z_NO_FLUSH, + errorCodePtr) != TCL_OK) { + return -1; + } + } + } return gotBytes; - - error: - gotBytes = -1; - goto stop; } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformOutput -- + * + * Writer filter that does compression. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformOutput( @@ -2518,6 +2546,16 @@ ZlibTransformOutput( return toWrite - cd->outStream.avail_in; } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformSetOption -- + * + * Writing side of [fconfigure] on our channel. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformSetOption( /* not used */ @@ -2568,7 +2606,7 @@ ZlibTransformSetOption( /* not used */ } if (Tcl_WriteRaw(cd->parent, cd->outBuffer, - cd->outStream.next_out - (Bytef*)cd->outBuffer) < 0) { + cd->outStream.next_out - (Bytef *) cd->outBuffer) < 0) { Tcl_AppendResult(interp, "problem flushing channel: ", Tcl_PosixError(interp), NULL); return TCL_ERROR; @@ -2589,6 +2627,16 @@ ZlibTransformSetOption( /* not used */ return setOptionProc(Tcl_GetChannelInstanceData(cd->parent), interp, optionName, value); } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformGetOption -- + * + * Reading side of [fconfigure] on our channel. + * + *---------------------------------------------------------------------- + */ static int ZlibTransformGetOption( @@ -2665,6 +2713,17 @@ ZlibTransformGetOption( } return Tcl_BadChannelOption(interp, optionName, chanOptions); } + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformWatch, ZlibTransformEventHandler -- + * + * If we have data pending, trigger a readable event after a short time + * (in order to allow a real event to catch up). + * + *---------------------------------------------------------------------- + */ static void ZlibTransformWatch( @@ -2681,63 +2740,27 @@ ZlibTransformWatch( watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent)); watchProc(Tcl_GetChannelInstanceData(cd->parent), mask); - if (!(mask & TCL_READABLE) || - (Tcl_DStringLength(&cd->result) == 0)) { - ZlibTransformTimerKill(cd); - } else { - ZlibTransformTimerSetup(cd); - } -} - -static int -ZlibTransformGetHandle( - ClientData instanceData, - int direction, - ClientData *handlePtr) -{ - ZlibChannelData *cd = instanceData; - - return Tcl_GetChannelHandle(cd->parent, direction, handlePtr); -} - -static int -ZlibTransformBlockMode( - ClientData instanceData, - int mode) -{ - ZlibChannelData *cd = instanceData; - - if (mode == TCL_MODE_NONBLOCKING) { - cd->flags |= ASYNC; - } else { - cd->flags &= ~ASYNC; + if (!(mask & TCL_READABLE) || Tcl_DStringLength(&cd->decompressed) == 0) { + ZlibTransformEventTimerKill(cd); + } else if (cd->timer == NULL) { + cd->timer = Tcl_CreateTimerHandler(TRANSFORM_TIMEOUT, + ZlibTransformTimerRun, cd); } - return TCL_OK; } static int -ZlibTransformHandler( +ZlibTransformEventHandler( ClientData instanceData, int interestMask) { ZlibChannelData *cd = instanceData; - ZlibTransformTimerKill(cd); + ZlibTransformEventTimerKill(cd); return interestMask; } -static void -ZlibTransformTimerSetup( - ZlibChannelData *cd) -{ - if (cd->timer == NULL) { - cd->timer = Tcl_CreateTimerHandler(0, - ZlibTransformTimerRun, cd); - } -} - -static void -ZlibTransformTimerKill( +static inline void +ZlibTransformEventTimerKill( ZlibChannelData *cd) { if (cd->timer != NULL) { @@ -2759,6 +2782,53 @@ ZlibTransformTimerRun( /* *---------------------------------------------------------------------- * + * ZlibTransformGetHandle -- + * + * Anything that needs the OS handle is told to get it from what we are + * stacked on top of. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibTransformGetHandle( + ClientData instanceData, + int direction, + ClientData *handlePtr) +{ + ZlibChannelData *cd = instanceData; + + return Tcl_GetChannelHandle(cd->parent, direction, handlePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ZlibTransformBlockMode -- + * + * We need to keep track of the blocking mode; it changes our behavior. + * + *---------------------------------------------------------------------- + */ + +static int +ZlibTransformBlockMode( + ClientData instanceData, + int mode) +{ + ZlibChannelData *cd = instanceData; + + if (mode == TCL_MODE_NONBLOCKING) { + cd->flags |= ASYNC; + } else { + cd->flags &= ~ASYNC; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * ZlibStackChannelTransform -- * * Stacks either compression or decompression onto a channel. @@ -2870,7 +2940,7 @@ ZlibStackChannelTransform( } } - Tcl_DStringInit(&cd->result); + Tcl_DStringInit(&cd->decompressed); chan = Tcl_StackChannel(interp, &zlibChannelType, cd, Tcl_GetChannelMode(channel), channel); @@ -2913,13 +2983,13 @@ ZlibStackChannelTransform( *---------------------------------------------------------------------- */ -static int +static inline int ResultCopy( - Tcl_DString *ds, /* The buffer to read from */ - unsigned char *buf, /* The buffer to copy into */ + ZlibChannelData *cd, /* The location of the buffer to read from. */ + char *buf, /* The buffer to copy into */ int toRead) /* Number of requested bytes */ { - int have = Tcl_DStringLength(ds); + int have = Tcl_DStringLength(&cd->decompressed); if (have == 0) { /* @@ -2927,20 +2997,19 @@ ResultCopy( */ return 0; - } - if (have > toRead) { + } else if (have > toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, shift the remaining bytes down, and * truncate. */ - char *src = Tcl_DStringValue(ds); + char *src = Tcl_DStringValue(&cd->decompressed); memcpy(buf, src, toRead); memmove(src, src + toRead, have - toRead); - Tcl_DStringSetLength(ds, have - toRead); + Tcl_DStringSetLength(&cd->decompressed, have - toRead); return toRead; } else /* have <= toRead */ { /* @@ -2948,8 +3017,8 @@ ResultCopy( * caller, so take everything as best effort. */ - memcpy(buf, Tcl_DStringValue(ds), have); - Tcl_DStringSetLength(ds, 0); + memcpy(buf, Tcl_DStringValue(&cd->decompressed), have); + Tcl_DStringSetLength(&cd->decompressed, 0); return have; } } @@ -2963,7 +3032,7 @@ ResultCopy( * in our working buffer. * * Result: - * Zero on success, -1 on error (with *errorCodePtr updated with reason). + * TCL_OK/TCL_ERROR (with *errorCodePtr updated with reason). * * Side effects: * See above. @@ -2998,7 +3067,7 @@ ResultGenerate( written = MAXBUF - cd->inStream.avail_out; if (written) { - Tcl_DStringAppend(&cd->result, (char*) buf, written); + Tcl_DStringAppend(&cd->decompressed, (char *) buf, written); } /* @@ -3008,7 +3077,7 @@ ResultGenerate( if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) || (e == Z_STREAM_END) || (e == Z_OK && cd->inStream.avail_out == 0)) { - return 0; + return TCL_OK; } /* @@ -3027,7 +3096,7 @@ ResultGenerate( Tcl_NewStringObj(cd->inStream.msg, -1)); Tcl_SetChannelError(cd->parent, errObj); *errorCodePtr = EINVAL; - return -1; + return TCL_ERROR; } /* @@ -3035,7 +3104,7 @@ ResultGenerate( */ if (cd->inStream.avail_in <= 0 && flush != Z_SYNC_FLUSH) { - return 0; + return TCL_OK; } } } -- cgit v0.12