From a99f768a32b42d04735d090f7d6fd8a0f75bc8ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Apr 2014 14:01:14 +0000 Subject: Remove all win95-specific test-cases, since Windows 95 is not supported any more. --- tests/fCmd.test | 6 ---- tests/http.test | 12 +++---- tests/winFCmd.test | 96 ++---------------------------------------------------- tests/winFile.test | 18 ---------- tests/winPipe.test | 8 ----- 5 files changed, 6 insertions(+), 134 deletions(-) diff --git a/tests/fCmd.test b/tests/fCmd.test index 8f27ad4..3d22b09 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -511,12 +511,6 @@ test fCmd-6.6 {CopyRenameOneFile: errno != ENOENT} -setup { } -returnCodes error -cleanup { testchmod 755 td1 } -result {error renaming "tf1" to "td1/tf1": permission denied} -test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} -setup { - cleanup -} -constraints {win 95} -returnCodes error -body { - createfile tf1 - file rename tf1 $long -} -result [subst {error renaming "tf1" to "$long": file name too long}] test fCmd-6.9 {CopyRenameOneFile: errno == ENOENT} -setup { cleanup } -constraints {unix notRoot} -body { diff --git a/tests/http.test b/tests/http.test index a52cfb1..a0a26de 100644 --- a/tests/http.test +++ b/tests/http.test @@ -492,14 +492,10 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test http-4.6.1 {http::Event} knownBug { - set token [http::geturl $url -blocksize 50 -progress myProgress] - return $progress - } {111 111} -} +test http-4.6.1 {http::Event} knownBug { + set token [http::geturl $url -blocksize 50 -progress myProgress] + return $progress +} {111 111} test http-4.7 {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28a0e9f..bd50328 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -208,22 +208,11 @@ test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { } -constraints {win win2000orXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} -setup { +test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { cleanup } -constraints {win nt winOlderThan2000 testfile} -body { testfile mv nul tf1 } -returnCodes error -result EACCES -test winFCmd-1.13.2 {TclpRenameFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - testfile mv tf1 nul -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup } -constraints {win nt testfile} -body { @@ -257,11 +246,6 @@ test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { } -constraints {win nt winOlderThan2000 testfile} -body { testfile mv nul tf1 } -returnCodes error -result EACCES -test winFCmd-1.19.2 {TclpRenameFile: errno == ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result ENOENT test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup } -constraints {win nt testfile} -body { @@ -474,29 +458,14 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -returnCodes error -result ENOENT test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set fd [open tf2 w] - testfile cp tf1 tf2 -} -cleanup { - close $fd - cleanup -} -returnCodes error -result EACCES -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup } -constraints {win win2000orXP testfile} -body { testfile cp nul tf1 } -returnCodes error -result EINVAL -test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} -setup { +test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { cleanup } -constraints {win nt winOlderThan2000 testfile} -body { testfile cp nul tf1 } -returnCodes error -result EACCES -test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result ENOENT test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -573,17 +542,6 @@ test winFCmd-2.17 {TclpCopyFile: dst is readonly} -setup { catch {testchmod 666 tf2} cleanup } -result {1 tf1} -test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} -setup { - cleanup -} -constraints {win 95 testfile testchmod} -body { - createfile tf1 - createfile tf2 - testchmod 000 tf2 - set fd [open tf2] - set msg [list [catch {testfile cp tf1 tf2} msg] $msg] - close $fd - lappend msg [file writable tf2] -} -result {1 EACCES 0} test winFCmd-3.1 {TclpDeleteFile: errno: EACCES} -body { testfile rm $cdfile $cdrom/dummy~~.fil @@ -666,9 +624,6 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir } -constraints {win nt cdrom testfile} -returnCodes error -result EACCES -test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} -body { - testfile mkdir $cdrom/dummy~~.dir -} -constraints {win 95 cdrom testfile} -returnCodes error -result ENOSPC test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -764,11 +719,6 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { catch {testchmod 666 td1} cleanup } -result {td1 EACCES} -test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} -setup { - cleanup -} -constraints {win 95 testfile} -body { - testfile rmdir nul -} -returnCodes error -result {nul EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup } -constraints {win nt testfile} -body { @@ -776,16 +726,6 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. } -returnCodes error -match regexp -result {^/ E(ACCES|EXIST)$} -# This next test has a very hokey way of matching... -test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} -setup { - cleanup -} -constraints {win 95 testfile} -body { - createfile tf1 - set res [catch {testfile rmdir tf1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {tf1 ENOTDIR}} test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -constraints {winVista testfile testchmod} -body { @@ -798,16 +738,6 @@ test winFCmd-6.13 {TclpRemoveDirectory: write-protected} -setup { cleanup } -returnCodes error -result {td1 EACCES} # This next test has a very hokey way of matching... -test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1/td2 - set res [catch {testfile rmdir td1} msg] - # get rid of path - set msg [list [file tail [lindex $msg 0]] [lindex $msg 1]] - list $res $msg -} -result {1 {td1 EEXIST}} -# This next test has a very hokey way of matching... test winFCmd-6.15 {TclpRemoveDirectory: !recursive} -setup { cleanup } -constraints {win testfile} -body { @@ -887,11 +817,6 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} -body { - # cdrom can return either d:\ or D:/, but we only care about the errcode - testfile rmdir $cdrom/ -} -constraints {win 95 cdrom testfile} -returnCodes error -match glob \ - -result {* EACCES} ; # was EEXIST, but changed for win98. test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ } -constraints {win nt cdrom testfile} -returnCodes error -match glob \ @@ -930,14 +855,6 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -cleanup { cleanup } -result {tf1} -test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - testfile cpdir td1 / -} -cleanup { - cleanup -} -returnCodes error -result {/ EEXIST} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup } -constraints {win nt testfile} -body { @@ -1038,15 +955,6 @@ test winFCmd-9.1 {TraversalDelete: DOTREE_F} -setup { createfile td1/tf1 testfile rmdir -force td1 } -result {} -test winFCmd-9.2 {TraversalDelete: DOTREE_F} -setup { - cleanup -} -constraints {win 95 testfile} -body { - file mkdir td1 - set fd [open td1/tf1 w] - testfile rmdir -force td1 -} -cleanup { - close $fd -} -returnCodes error -result {td1\tf1 EACCES} test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup { cleanup } -constraints {winVista testfile testchmod} -body { diff --git a/tests/winFile.test b/tests/winFile.test index fba9bcb..2c47f5f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -37,24 +37,6 @@ test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.3 {TclpGetUserHome} -constraints {win 95} -body { - # Find some user in system.ini and then see if they have a home. - - set f [open $::env(windir)/system.ini] - while {[gets $f line] >= 0} { - if {$line ne {[Password Lists]}} { - continue - } - gets $f - set name [lindex [split [gets $f] =] 0] - if {$name ne ""} { - return [catch {glob ~$name}] - } - } - return 0 ;# didn't find anything... -} -cleanup { - catch {close $f} -} -result {0} test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { catch {glob ~stanton@workgroup} } {0} diff --git a/tests/winPipe.test b/tests/winPipe.test index d2e804d..9c6f94d 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -82,10 +82,6 @@ test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat3 exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {win 95 exec cat32} { - exec command /c type $path(big) |& $cat32 > $path(stdout) 2> $path(stderr) - list [contents $path(stdout)] [contents $path(stderr)] -} "{$big} stderr32" test winpipe-1.6 {32 bit comprehensive tests: from console} \ {win cat32 AllocConsole} { # would block waiting for human input @@ -174,10 +170,6 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ catch {close $f} set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-1.22 {Checking command.com for Win95/98 hanging} {win 95 exec} { - exec command.com /c dir /b - set result 1 -} 1 test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { proc readResults {f} { -- cgit v0.12 From ffc78c758ef00181a0c05fb7086a07e4a4673cbc Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2014 16:05:06 +0000 Subject: Simplify reflected channels. Instead of having two modes of Close operations and the need to choose between them with a special value of the methods field, when the initialize pass fails for some reason, simply do not create the channel so there's nothing that needs closing. Then the methods field no longer holds anything used, so eliminate it. All the methods checking is done by [chan create]. --- generic/tclIORChan.c | 62 ++++++---------------------------------------------- 1 file changed, 7 insertions(+), 55 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index eaabdfb..a4d1ec5 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -92,7 +92,6 @@ typedef struct { Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif Tcl_Obj *cmd; /* Callback command prefix */ - int methods; /* Bitmask of supported methods */ /* * NOTE (9): Should we have predefined shared literals for the method @@ -436,9 +435,7 @@ static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj); * list-quoting to keep the words of the message together. See also [x]. */ -static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_read_toomuch = "{read delivered more than requested}"; -static const char *msg_write_unsup = "{write not supported by Tcl driver}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; @@ -550,11 +547,6 @@ TclChanCreateObjCmd( rcId = NextHandle(); rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId); - chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, - mode); - rcPtr->chan = chan; - Tcl_Preserve(chan); - chanPtr = (Channel *) chan; /* * Invoke 'initialize' and validate that the handler is present and ok. @@ -657,7 +649,11 @@ TclChanCreateObjCmd( * Everything is fine now. */ - rcPtr->methods = methods; + chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, + mode); + rcPtr->chan = chan; + Tcl_Preserve(chan); + chanPtr = (Channel *) chan; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { /* @@ -720,12 +716,8 @@ TclChanCreateObjCmd( return TCL_OK; error: - /* - * Signal to ReflectClose to not call 'finalize'. - */ - - rcPtr->methods = 0; - Tcl_Close(interp, chan); + Tcl_DecrRefCount(rcPtr->cmd); + ckfree((char*) rcPtr); return TCL_ERROR; #undef MODE @@ -1069,18 +1061,6 @@ ReflectClose( } /* - * -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL) - * - * A cleaned method mask here implies that the channel creation was - * aborted, and "finalize" must not be called. - */ - - if (rcPtr->methods == 0) { - Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); - return EOK; - } - - /* * Are we in the correct thread? */ @@ -1176,18 +1156,6 @@ ReflectInput( Tcl_Obj *resObj; /* Result data for 'read' */ /* - * The following check can be done before thread redirection, because we - * are reading from an item which is readonly, i.e. will never change - * during the lifetime of the channel. - */ - - if (!(rcPtr->methods & FLAG(METH_READ))) { - SetChannelErrorStr(rcPtr->chan, msg_read_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - /* * Are we in the correct thread? */ @@ -1291,18 +1259,6 @@ ReflectOutput( int written; /* - * The following check can be done before thread redirection, because we - * are reading from an item which is readonly, i.e. will never change - * during the lifetime of the channel. - */ - - if (!(rcPtr->methods & FLAG(METH_WRITE))) { - SetChannelErrorStr(rcPtr->chan, msg_write_unsup); - *errorCodePtr = EINVAL; - return -1; - } - - /* * Are we in the correct thread? */ @@ -1524,8 +1480,6 @@ ReflectWatch( ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; Tcl_Obj *maskObj; - /* ASSERT rcPtr->methods & FLAG(METH_WATCH) */ - /* * We restrict the interest to what the channel can support. IOW there * will never be write events for a channel which is not writable. @@ -2008,10 +1962,8 @@ NewReflectedChannel( rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ - /* rcPtr->methods: Assigned by caller. Dummy data here. */ rcPtr->chan = NULL; - rcPtr->methods = 0; rcPtr->interp = interp; #ifdef TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); -- cgit v0.12 From 9814e7b3519b71ebace82cd8ca37748fc92b8185 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2014 17:55:59 +0000 Subject: Reflected channels. Keep a set of method names cached so we don't create new each operation, and we can benefit from any lookup info cached in intreps. --- generic/tclIORChan.c | 83 +++++++++++++++++++++++++++------------------------- 1 file changed, 43 insertions(+), 40 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index a4d1ec5..17c1593 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -92,11 +92,8 @@ typedef struct { Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif Tcl_Obj *cmd; /* Callback command prefix */ - - /* - * NOTE (9): Should we have predefined shared literals for the method - * names? - */ + Tcl_Obj *methods; /* Methods to append to command prefix */ + Tcl_Obj *name; /* Name of the channel as created */ int mode; /* Mask of R/W mode */ int interest; /* Mask of events the channel is interested @@ -420,7 +417,7 @@ static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp, static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, - const char *method, Tcl_Obj *argOneObj, + MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); @@ -560,7 +557,7 @@ TclChanCreateObjCmd( modeObj = DecodeEventMask(mode); /* assert modeObj.refCount == 1 */ - result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj); + result = InvokeTclMethod(rcPtr, METH_INIT, modeObj, NULL, &resObj); Tcl_DecrRefCount(modeObj); if (result != TCL_OK) { UnmarshallErrorResult(interp, resObj); @@ -716,6 +713,8 @@ TclChanCreateObjCmd( return TCL_OK; error: + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); ckfree((char*) rcPtr); return TCL_ERROR; @@ -1081,7 +1080,7 @@ ReflectClose( } } else { #endif - result = InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj); + result = InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj); if ((result != TCL_OK) && (interp != NULL)) { Tcl_SetChannelErrorInterp(interp, resObj); } @@ -1193,7 +1192,7 @@ ReflectInput( toReadObj = Tcl_NewIntObj(toRead); Tcl_IncrRefCount(toReadObj); - if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK) { int code = ErrnoReturn (rcPtr, resObj); if (code < 0) { @@ -1296,7 +1295,7 @@ ReflectOutput( bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite); Tcl_IncrRefCount(bufObj); - if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -1409,7 +1408,7 @@ ReflectSeekWide( Tcl_IncrRefCount(offObj); Tcl_IncrRefCount(baseObj); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); goto invalid; } @@ -1522,7 +1521,7 @@ ReflectWatch( maskObj = DecodeEventMask(mask); /* assert maskObj.refCount == 1 */ - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); @@ -1581,7 +1580,7 @@ ReflectBlock( Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, &resObj) != TCL_OK) { Tcl_SetChannelError(rcPtr->chan, resObj); errorNum = EINVAL; } else { @@ -1655,7 +1654,7 @@ ReflectSetOption( Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); - result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj); + result = InvokeTclMethod(rcPtr, METH_CONFIGURE,optionObj,valueObj, &resObj); if (result != TCL_OK) { UnmarshallErrorResult(interp, resObj); } @@ -1700,7 +1699,7 @@ ReflectGetOption( Tcl_Obj *resObj; /* Result data for 'configure' */ int listc, result = TCL_OK; Tcl_Obj **listv; - const char *method; + MethodName method; /* * Are we in the correct thread? @@ -1739,14 +1738,14 @@ ReflectGetOption( * Retrieve all options. */ - method = "cgetall"; + method = METH_CGETALL; optionObj = NULL; } else { /* * Retrieve the value of one option. */ - method = "cget"; + method = METH_CGET; optionObj = Tcl_NewStringObj(optionName, -1); Tcl_IncrRefCount(optionObj); } @@ -1958,6 +1957,7 @@ NewReflectedChannel( Tcl_Obj *handleObj) { ReflectedChannel *rcPtr; + MethodName mn = METH_BLOCKING; rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel)); @@ -1973,9 +1973,15 @@ NewReflectedChannel( /* ASSERT: cmdpfxObj is a Tcl List */ rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj); - Tcl_ListObjAppendElement(NULL, rcPtr->cmd, Tcl_NewObj()); - Tcl_ListObjAppendElement(NULL, rcPtr->cmd, handleObj); Tcl_IncrRefCount(rcPtr->cmd); + rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL); + while (mn <= METH_WRITE) { + Tcl_ListObjAppendElement(NULL, rcPtr->methods, + Tcl_NewStringObj(methodNames[mn++], -1)); + } + Tcl_IncrRefCount(rcPtr->methods); + rcPtr->name = handleObj; + Tcl_IncrRefCount(rcPtr->name); return rcPtr; } @@ -2035,6 +2041,8 @@ FreeReflectedChannel( ckfree((char*) chanPtr->typePtr); } Tcl_Release(chanPtr); + Tcl_DecrRefCount(rcPtr->name); + Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); ckfree((char*) rcPtr); } @@ -2066,7 +2074,7 @@ FreeReflectedChannel( static int InvokeTclMethod( ReflectedChannel *rcPtr, - const char *method, + MethodName method, Tcl_Obj *argOneObj, /* NULL'able */ Tcl_Obj *argTwoObj, /* NULL'able */ Tcl_Obj **resultObjPtr) /* NULL'able */ @@ -2076,7 +2084,6 @@ InvokeTclMethod( int result; /* Result code of method invokation */ Tcl_Obj *resObj = NULL; /* Result of method invokation. */ Tcl_Obj *cmd; - int len; if (!rcPtr->interp) { /* @@ -2099,20 +2106,15 @@ InvokeTclMethod( } /* - * NOTE (5): Decide impl. issue: Cache objects with method names? Needs - * TSD data as reflections can be created in many different threads. - * NO: Caching of command resolutions means storage per channel. - */ - - /* * Insert method into the callback command, after the command prefix, * before the channel id. */ - methObj = Tcl_NewStringObj(method, -1); cmd = TclListObjCopy(NULL, rcPtr->cmd); - ListObjLength(cmd, len); - Tcl_ListObjReplace(NULL, cmd, len - 2, 1, 1, &methObj); + + Tcl_ListObjIndex(NULL, rcPtr->methods, method, &methObj); + Tcl_ListObjAppendElement(NULL, cmd, methObj); + Tcl_ListObjAppendElement(NULL, cmd, rcPtr->name); /* * Append the additional argument containing method specific details @@ -2173,7 +2175,8 @@ InvokeTclMethod( result = TCL_ERROR; } Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf( - "\n (chan handler subcommand \"%s\")", method)); + "\n (chan handler subcommand \"%s\")", + methodNames[method])); resObj = MarshallError(rcPtr->interp); } Tcl_IncrRefCount(resObj); @@ -2700,7 +2703,7 @@ ForwardProc( * No parameters/results. */ - if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj)!=TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_FINAL, NULL, NULL, &resObj)!=TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -2732,7 +2735,7 @@ ForwardProc( Tcl_IncrRefCount(toReadObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_READ, toReadObj, NULL, &resObj)!=TCL_OK){ int code = ErrnoReturn (rcPtr, resObj); if (code < 0) { @@ -2772,7 +2775,7 @@ ForwardProc( Tcl_IncrRefCount(bufObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + if (InvokeTclMethod(rcPtr, METH_WRITE, bufObj, NULL, &resObj) != TCL_OK) { int code = ErrnoReturn(rcPtr, resObj); if (code < 0) { @@ -2813,7 +2816,7 @@ ForwardProc( Tcl_IncrRefCount(baseObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; } else { @@ -2847,7 +2850,7 @@ ForwardProc( /* assert maskObj.refCount == 1 */ Tcl_Preserve(rcPtr); - (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL); + (void) InvokeTclMethod(rcPtr, METH_WATCH, maskObj, NULL, NULL); Tcl_DecrRefCount(maskObj); Tcl_Release(rcPtr); break; @@ -2858,7 +2861,7 @@ ForwardProc( Tcl_IncrRefCount(blockObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, + if (InvokeTclMethod(rcPtr, METH_BLOCKING, blockObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -2874,7 +2877,7 @@ ForwardProc( Tcl_IncrRefCount(optionObj); Tcl_IncrRefCount(valueObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, + if (InvokeTclMethod(rcPtr, METH_CONFIGURE, optionObj, valueObj, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); } @@ -2893,7 +2896,7 @@ ForwardProc( Tcl_IncrRefCount(optionObj); Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_CGET, optionObj, NULL, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { Tcl_DStringAppend(paramPtr->getOpt.value, @@ -2910,7 +2913,7 @@ ForwardProc( */ Tcl_Preserve(rcPtr); - if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj) != TCL_OK){ + if (InvokeTclMethod(rcPtr, METH_CGETALL, NULL, NULL, &resObj) != TCL_OK){ ForwardSetObjError(paramPtr, resObj); } else { /* -- cgit v0.12 From 87f75437c09a8e8fbe5fe0eaa68200c773799e28 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 17 Apr 2014 19:58:41 +0000 Subject: Another test exposing another segfault. --- tests/ioCmd.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index f021ade..184f773 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -774,6 +774,22 @@ test iocmd-21.20 {Bug 88aef05cda} -setup { close $ch rename foo {} } -match glob -result {1 {*nested eval*}} +test iocmd-21.21 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + close $chan + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 1 +} -cleanup { + close $ch + rename foo {} +} -result a # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. -- cgit v0.12 From a07adf4d6d28771d9aa74ef06526e5fb3035f5c1 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 Apr 2014 18:55:41 +0000 Subject: Added a refcounting mechanism to ChannelBuffers. Other edits to stop segfaults in tests iocmd-21.2[12]. --- generic/tclIO.c | 50 ++++++++++++++++++++++++++++++++++++++++++-------- generic/tclIO.h | 1 + generic/tclIOCmd.c | 3 +++ tests/ioCmd.test | 20 ++++++++++++++++++-- 4 files changed, 64 insertions(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 9e675c6..a60c97d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -162,6 +162,8 @@ typedef struct CloseCallback { */ static ChannelBuffer * AllocChannelBuffer(int length); +static void PreserveChannelBuffer(ChannelBuffer *bufPtr); +static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); static void ChannelTimerProc(ClientData clientData); static int CheckChannelErrors(ChannelState *statePtr, int direction); @@ -352,6 +354,7 @@ ChanRead( int *errnoPtr) { if (WillRead(chanPtr) < 0) { + *errnoPtr = Tcl_GetErrno(); return -1; } @@ -2216,8 +2219,26 @@ AllocChannelBuffer( bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; bufPtr->nextPtr = NULL; + bufPtr->refCount = 1; return bufPtr; } + +static void +PreserveChannelBuffer( + ChannelBuffer *bufPtr) +{ + bufPtr->refCount++; +} + +static void +ReleaseChannelBuffer( + ChannelBuffer *bufPtr) +{ + if (--bufPtr->refCount) { + return; + } + ckfree((char *) bufPtr); +} /* *---------------------------------------------------------------------- @@ -2250,7 +2271,7 @@ RecycleBuffer( */ if (mustDiscard) { - ckfree((char *) bufPtr); + ReleaseChannelBuffer(bufPtr); return; } @@ -2261,7 +2282,7 @@ RecycleBuffer( */ if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { - ckfree((char *) bufPtr); + ReleaseChannelBuffer(bufPtr); return; } @@ -2296,7 +2317,7 @@ RecycleBuffer( * If we reached this code we return the buffer to the OS. */ - ckfree((char *) bufPtr); + ReleaseChannelBuffer(bufPtr); return; keepBuffer: @@ -2470,6 +2491,7 @@ FlushChannel( * Produce the output on the channel. */ + PreserveChannelBuffer(bufPtr); toWrite = BytesLeft(bufPtr); if (toWrite == 0) { written = 0; @@ -2597,6 +2619,7 @@ FlushChannel( } RecycleBuffer(statePtr, bufPtr, 0); } + ReleaseChannelBuffer(bufPtr); } /* Closes "while (1)". */ /* @@ -2681,7 +2704,7 @@ CloseChannel( */ if (statePtr->curOutPtr != NULL) { - ckfree((char *) statePtr->curOutPtr); + ReleaseChannelBuffer(statePtr->curOutPtr); statePtr->curOutPtr = NULL; } @@ -3566,6 +3589,11 @@ static void WillWrite(Channel *chanPtr) static int WillRead(Channel *chanPtr) { + if (chanPtr->typePtr == NULL) { + /* Prevent read attempts on a closed channel */ + Tcl_SetErrno(EINVAL); + return -1; + } if ((chanPtr->typePtr->seekProc != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { if ((chanPtr->state->curOutPtr != NULL) @@ -3652,6 +3680,7 @@ Write( bufPtr->nextAdded += saved; saved = 0; } + PreserveChannelBuffer(bufPtr); dst = InsertPoint(bufPtr); dstLen = SpaceLeft(bufPtr); @@ -3665,6 +3694,7 @@ Write( if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { /* We're reading from invalid/incomplete UTF-8 */ + ReleaseChannelBuffer(bufPtr); if (total == 0) { Tcl_SetErrno(EINVAL); return -1; @@ -3748,6 +3778,7 @@ Write( needNlFlush = 0; } } + ReleaseChannelBuffer(bufPtr); } if ((flushed < total) && (statePtr->flags & CHANNEL_UNBUFFERED || (needNlFlush && statePtr->flags & CHANNEL_LINEBUFFERED))) { @@ -5935,7 +5966,7 @@ DiscardInputQueued( */ if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) { - ckfree((char *) statePtr->saveInBufPtr); + ReleaseChannelBuffer(statePtr->saveInBufPtr); statePtr->saveInBufPtr = NULL; } } @@ -6028,7 +6059,7 @@ GetInput( if ((bufPtr != NULL) && (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) { - ckfree((char *) bufPtr); + ReleaseChannelBuffer(bufPtr); bufPtr = NULL; } @@ -6090,6 +6121,7 @@ GetInput( } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + PreserveChannelBuffer(bufPtr); nread = ChanRead(chanPtr, InsertPoint(bufPtr), toRead, &result); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING @@ -6097,6 +6129,7 @@ GetInput( #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ if (nread > 0) { + result = 0; bufPtr->nextAdded += nread; /* @@ -6122,6 +6155,7 @@ GetInput( #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ } else if (nread == 0) { + result = 0; SetFlag(statePtr, CHANNEL_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; } else if (nread < 0) { @@ -6130,9 +6164,9 @@ GetInput( result = EAGAIN; } Tcl_SetErrno(result); - return result; } - return 0; + ReleaseChannelBuffer(bufPtr); + return result; } /* diff --git a/generic/tclIO.h b/generic/tclIO.h index ebf2ef7..0ea7d1c 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -36,6 +36,7 @@ */ typedef struct ChannelBuffer { + int refCount; /* Current uses count */ int nextAdded; /* The next position into which a character * will be put in the buffer. */ int nextRemoved; /* Position of next byte to be removed from diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 2958bc8..7e8e91a 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -447,6 +447,7 @@ Tcl_ReadObjCmd( resultPtr = Tcl_NewObj(); Tcl_IncrRefCount(resultPtr); + Tcl_Preserve(chan); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { /* @@ -462,6 +463,7 @@ Tcl_ReadObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } @@ -480,6 +482,7 @@ Tcl_ReadObjCmd( } } Tcl_SetObjResult(interp, resultPtr); + Tcl_Release(chan); Tcl_DecrRefCount(resultPtr); return TCL_OK; } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 184f773..8bf32d2 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -785,11 +785,27 @@ test iocmd-21.21 {[close] in [read] segfaults} -setup { } set ch [chan create read foo] } -body { - read $ch 1 + read $ch 0 } -cleanup { close $ch rename foo {} -} -result a +} -result {} +test iocmd-21.22 {[close] in [read] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return a + } + } + set ch [chan create read foo] +} -body { + read $ch 1 +} -returnCodes error -cleanup { + catch {close $ch} + rename foo {} +} -match glob -result {*invalid argument*} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. -- cgit v0.12 From 192fce9c01c4ee3827aa8f54967764c18bdd5dca Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 22 Apr 2014 13:25:41 +0000 Subject: Memory leak after thread exit, fixed (alloc cache released by exit), belong to ticket [3493120] Moved over to branch bug-3493120. This is not ready for the core-8-5-branch. Segfaults all over the place in a thread-enabled build on a CentOS system. --- generic/tclInt.h | 1 + generic/tclThread.c | 8 ++++++-- generic/tclThreadAlloc.c | 27 +++++++++++++++++++++++++++ 3 files changed, 34 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 1348340..00b246b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2550,6 +2550,7 @@ MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); +MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(void); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(mp_int *a); diff --git a/generic/tclThread.c b/generic/tclThread.c index 8384107..d6b5bcb 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -338,8 +338,9 @@ Tcl_ConditionFinalize( * * TclFinalizeThreadData -- * - * This function cleans up the thread-local storage. This is called once - * for each thread. + * This function cleans up the thread-local storage. Secondary, it cleans + * thread alloc cache. + * This is called once for each thread before thread exits. * * Results: * None. @@ -354,6 +355,9 @@ void TclFinalizeThreadData(void) { TclpFinalizeThreadDataThread(); +#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) + TclFinalizeThreadAllocThread(); +#endif } /* diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 2e74fa7..106e908 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -1012,6 +1012,33 @@ TclFinalizeThreadAlloc(void) TclpFreeAllocCache(NULL); } +/* + *---------------------------------------------------------------------- + * + * TclFinalizeThreadAllocThread -- + * + * This procedure is used to destroy single thread private resources used + * in this file. + * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeThreadAllocThread(void) +{ + Cache *cachePtr = TclpGetAllocCache(); + if (cachePtr != NULL) { + TclpFreeAllocCache(cachePtr); + } +} + #else /* !(TCL_THREADS && USE_THREAD_ALLOC) */ /* *---------------------------------------------------------------------- -- cgit v0.12 From 190e2f09e8fa5bc975ba496a5544b4dd853378f0 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 22 Apr 2014 14:57:44 +0000 Subject: Add refcounting and preservation to [testchannel transform] to stop segfault in test iogt-2.4. --- generic/tclIOGT.c | 122 +++++++++++++++++++++++++++++++++--------------------- 1 file changed, 75 insertions(+), 47 deletions(-) diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index eed21fb..beddf4f 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -210,7 +210,27 @@ struct TransformChannelData { * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ + int refCount; }; + +static void +PreserveData( + TransformChannelData *dataPtr) +{ + dataPtr->refCount++; +} + +static void +ReleaseData( + TransformChannelData *dataPtr) +{ + if (--dataPtr->refCount) { + return; + } + ResultClear(&dataPtr->result); + Tcl_DecrRefCount(dataPtr->command); + ckfree((char *) dataPtr); +} /* *---------------------------------------------------------------------- @@ -240,6 +260,7 @@ TclChannelTransform( Channel *chanPtr; /* The actual channel. */ ChannelState *statePtr; /* State info for channel. */ int mode; /* Read/write mode of the channel. */ + int objc; TransformChannelData *dataPtr; Tcl_DString ds; @@ -247,6 +268,12 @@ TclChannelTransform( return TCL_ERROR; } + if (TCL_OK != Tcl_ListObjLength(interp, cmdObjPtr, &objc)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("-command value is not a list", -1)); + return TCL_ERROR; + } + chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; @@ -261,6 +288,7 @@ TclChannelTransform( dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData)); + dataPtr->refCount = 1; Tcl_DStringInit(&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); dataPtr->readIsFlushed = 0; @@ -286,9 +314,7 @@ TclChannelTransform( if (dataPtr->self == NULL) { Tcl_AppendResult(interp, "\nfailed to stack channel \"", Tcl_GetChannelName(chan), "\"", NULL); - Tcl_DecrRefCount(dataPtr->command); - ResultClear(&dataPtr->result); - ckfree((char *) dataPtr); + ReleaseData(dataPtr); return TCL_ERROR; } @@ -296,9 +322,11 @@ TclChannelTransform( * At last initialize the transformation at the script level. */ + PreserveData(dataPtr); if ((dataPtr->mode & TCL_WRITABLE) && ExecuteCallback(dataPtr, NULL, A_CREATE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE) != TCL_OK){ Tcl_UnstackChannel(interp, chan); + ReleaseData(dataPtr); return TCL_ERROR; } @@ -307,9 +335,11 @@ TclChannelTransform( ExecuteCallback(dataPtr, NULL, A_DELETE_WRITE, NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); + ReleaseData(dataPtr); return TCL_ERROR; } + ReleaseData(dataPtr); return TCL_OK; } @@ -350,7 +380,10 @@ ExecuteCallback( unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; - Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); + Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command); + Tcl_Interp *eval = dataPtr->interp; + + Tcl_Preserve(eval); /* * Step 1, create the complete command to execute. Do this by appending @@ -361,26 +394,18 @@ ExecuteCallback( */ if (preserve == P_PRESERVE) { - state = Tcl_SaveInterpState(dataPtr->interp, res); + state = Tcl_SaveInterpState(eval, res); } Tcl_IncrRefCount(command); - res = Tcl_ListObjAppendElement(dataPtr->interp, command, - Tcl_NewStringObj((char *) op, -1)); - if (res != TCL_OK) { - goto cleanup; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); /* * Use a byte-array to prevent the misinterpretation of binary data coming * through as UTF while at the tcl level. */ - res = Tcl_ListObjAppendElement(dataPtr->interp, command, - Tcl_NewByteArrayObj(buf, bufLen)); - if (res != TCL_OK) { - goto cleanup; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewByteArrayObj(buf, bufLen)); /* * Step 2, execute the command at the global level of the interpreter used @@ -390,13 +415,14 @@ ExecuteCallback( * current interpreter. Don't copy if in preservation mode. */ - res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL); + res = Tcl_EvalObjEx(eval, command, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(command); command = NULL; - if ((res != TCL_OK) && (interp != NULL) && (dataPtr->interp != interp) + if ((res != TCL_OK) && (interp != NULL) && (eval != interp) && (preserve == P_NO_PRESERVE)) { - Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp)); + Tcl_SetObjResult(interp, Tcl_GetObjResult(eval)); + Tcl_Release(eval); return res; } @@ -411,20 +437,20 @@ ExecuteCallback( break; case TRANSMIT_DOWN: - resObj = Tcl_GetObjResult(dataPtr->interp); + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, resLen); break; case TRANSMIT_SELF: - resObj = Tcl_GetObjResult(dataPtr->interp); + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); break; case TRANSMIT_IBUF: - resObj = Tcl_GetObjResult(dataPtr->interp); + resObj = Tcl_GetObjResult(eval); resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); ResultAdd(&dataPtr->result, resBuf, resLen); break; @@ -434,24 +460,16 @@ ExecuteCallback( * Interpret result as integer number. */ - resObj = Tcl_GetObjResult(dataPtr->interp); - TclGetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); + resObj = Tcl_GetObjResult(eval); + TclGetIntFromObj(eval, resObj, &dataPtr->maxRead); break; } - Tcl_ResetResult(dataPtr->interp); - if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - return res; - - cleanup: + Tcl_ResetResult(eval); if (preserve == P_PRESERVE) { - (void) Tcl_RestoreInterpState(dataPtr->interp, state); - } - if (command != NULL) { - Tcl_DecrRefCount(command); + (void) Tcl_RestoreInterpState(eval, state); } + Tcl_Release(eval); return res; } @@ -535,6 +553,7 @@ TransformCloseProc( * system rely on (f.e. signaling the close to interested parties). */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_PRESERVE); @@ -554,14 +573,13 @@ TransformCloseProc( ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0, TRANSMIT_DONT, P_PRESERVE); } + ReleaseData(dataPtr); /* * General cleanup. */ - ResultClear(&dataPtr->result); - Tcl_DecrRefCount(dataPtr->command); - ckfree((char *) dataPtr); + ReleaseData(dataPtr); return TCL_OK; } @@ -606,6 +624,7 @@ TransformInputProc( gotBytes = 0; downChan = Tcl_GetStackedChannel(dataPtr->self); + PreserveData(dataPtr); while (toRead > 0) { /* * Loop until the request is satisfied (or no data is available from @@ -623,7 +642,7 @@ TransformInputProc( * break out of the loop and return to the caller. */ - return gotBytes; + break; } /* @@ -647,7 +666,7 @@ TransformInputProc( } } /* else: 'maxRead < 0' == Accept the current value of toRead. */ if (toRead <= 0) { - return gotBytes; + break; } /* @@ -663,11 +682,12 @@ TransformInputProc( */ if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { - return gotBytes; + break; } *errorCodePtr = Tcl_GetErrno(); - return -1; + gotBytes = -1; + break; } else if (read == 0) { /* * Check wether we hit on EOF in the underlying channel or not. If @@ -682,9 +702,9 @@ TransformInputProc( if (!Tcl_Eof(downChan)) { if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) { *errorCodePtr = EWOULDBLOCK; - return -1; + gotBytes = -1; } - return gotBytes; + break; } if (dataPtr->readIsFlushed) { @@ -692,7 +712,7 @@ TransformInputProc( * Already flushed, nothing to do anymore. */ - return gotBytes; + break; } dataPtr->readIsFlushed = 1; @@ -704,7 +724,7 @@ TransformInputProc( * We had nothing to flush. */ - return gotBytes; + break; } continue; /* at: while (toRead > 0) */ @@ -718,9 +738,11 @@ TransformInputProc( if (ExecuteCallback(dataPtr, NULL, A_READ, UCHARP(buf), read, TRANSMIT_IBUF, P_PRESERVE) != TCL_OK) { *errorCodePtr = EINVAL; - return -1; + gotBytes = -1; + break; } } /* while toRead > 0 */ + ReleaseData(dataPtr); return gotBytes; } @@ -762,11 +784,13 @@ TransformOutputProc( return 0; } + PreserveData(dataPtr); if (ExecuteCallback(dataPtr, NULL, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE) != TCL_OK) { *errorCodePtr = EINVAL; - return -1; + toWrite = -1; } + ReleaseData(dataPtr); return toWrite; } @@ -819,6 +843,7 @@ TransformSeekProc( * request down, unchanged. */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); @@ -830,6 +855,7 @@ TransformSeekProc( ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } + ReleaseData(dataPtr); return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, errorCodePtr); @@ -890,6 +916,7 @@ TransformWideSeekProc( * request down, unchanged. */ + PreserveData(dataPtr); if (dataPtr->mode & TCL_WRITABLE) { ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); @@ -901,6 +928,7 @@ TransformWideSeekProc( ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } + ReleaseData(dataPtr); /* * If we have a wide seek capability, we should stick with that. -- cgit v0.12 From f231f10b58b9f58583b664655b513d3f3ee0c382 Mon Sep 17 00:00:00 2001 From: sebres Date: Wed, 23 Apr 2014 09:18:20 +0000 Subject: *nix segfault cleared: we should reset a thread key after freeing of alloc cache (in tclUnixThrd.c) --- unix/tclUnixThrd.c | 1 + 1 file changed, 1 insertion(+) diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index ad36242..d30791d 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -814,6 +814,7 @@ TclpFreeAllocCache( */ TclFreeAllocCache(ptr); + pthread_setspecific(key, NULL); } else if (initialized) { /* -- cgit v0.12 From 790e5adaf4cabf6c9dcaa3d109427dbe18f786ff Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 24 Apr 2014 15:27:58 +0000 Subject: Make sure the ReflectedChannel struct is freed in the handler thread, where it was allocated. This constraint allows the struct to safely hold Tcl_Obj values, which has been convenient for storing callback commands. --- generic/tclIORChan.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e462f61..94428bb 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1145,6 +1145,7 @@ ReflectClose( if (result != TCL_OK) { FreeReceivedError(&p); } + return EOK; } #endif @@ -1169,8 +1170,6 @@ ReflectClose( Tcl_DeleteEvents(ReflectEventDelete, rcPtr); - Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); - if (result != TCL_OK) { PassReceivedErrorInterp(interp, &p); } @@ -2903,6 +2902,7 @@ ForwardProc( Tcl_GetChannelName(rcPtr->chan)); Tcl_DeleteHashEntry(hPtr); + Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); break; case ForwardedInput: { -- cgit v0.12 From 1fc337bda0ffe4523e3a47f27077378b4c1349cf Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 25 Apr 2014 20:12:48 +0000 Subject: Disable buffer recycling to expose bugs for fixing. --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index a60c97d..3f9ca0a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -2270,7 +2270,7 @@ RecycleBuffer( * Do we have to free the buffer to the OS? */ - if (mustDiscard) { + if (1 || mustDiscard) { ReleaseChannelBuffer(bufPtr); return; } -- cgit v0.12 From 9a76d245a9dcf48449c6f147252a9be6b43abf09 Mon Sep 17 00:00:00 2001 From: ferrieux Date: Mon, 28 Apr 2014 20:28:10 +0000 Subject: Clarify fcopy manpage regarding its bidirectional uses. [1350564] --- doc/fcopy.n | 27 ++++++++++++++++++++++++--- 1 file changed, 24 insertions(+), 3 deletions(-) diff --git a/doc/fcopy.n b/doc/fcopy.n index ec3d5c6..071896c 100644 --- a/doc/fcopy.n +++ b/doc/fcopy.n @@ -46,8 +46,11 @@ non-blocking mode; the \fBfcopy\fR command takes care of that automatically. However, it is necessary to enter the event loop by using the \fBvwait\fR command or by using Tk. .PP -You are not allowed to do other I/O operations with -\fIinchan\fR or \fIoutchan\fR during a background \fBfcopy\fR. +You are not allowed to do other input operations with \fIinchan\fR, or +output operations with \fIoutchan\fR, during a background +\fBfcopy\fR. The converse is entirely legitimate, as exhibited by the +bidirectional fcopy example below. +.PP If either \fIinchan\fR or \fIoutchan\fR get closed while the copy is in progress, the current copy is stopped and the command callback is \fInot\fR made. @@ -57,7 +60,7 @@ then all data already queued for \fIoutchan\fR is written out. Note that \fIinchan\fR can become readable during a background copy. You should turn off any \fBfileevent\fR handlers during a background copy so those handlers do not interfere with the copy. -Any I/O attempted by a \fBfileevent\fR handler will get a +Any wrong-sided I/O attempted (by a \fBfileevent\fR handler or otherwise) will get a .QW "channel busy" error. .PP @@ -149,6 +152,24 @@ set total 0 -command [list CopyMore $in $out $chunk] vwait done .CE +.PP +The fourth example starts an asynchronous, bidirectional fcopy between +two sockets. Those could also be pipes from two [open "|hal 9000" r+] +(though their conversation would remain secret to the script, since +all four fileevent slots are busy). +.PP +.CS +set flows 2 +proc Done {dir args} { + global flows done + puts "$dir is over." + incr flows -1 + if {$flows<=0} {set done 1} +} +\fBfcopy\fR $sok1 $sok2 -command [list Done UP] +\fBfcopy\fR $sok2 $sok1 -command [list Done DOWN] +vwait done +.CE .SH "SEE ALSO" eof(n), fblocked(n), fconfigure(n), file(n) .SH KEYWORDS -- cgit v0.12 From 0725c745416a8cfec6c72440cfc62d5fdc686f04 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 29 Apr 2014 15:54:03 +0000 Subject: Revise the logic for setting TCL_ENCODING_END in the outputEncodingFlags so it does not rely on buffer recycling. --- generic/tclIO.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3f9ca0a..6ff8806 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -3142,7 +3142,8 @@ Tcl_Close( stickyError = 0; - if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) + if ((statePtr->encoding != NULL) + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; if (WriteChars(chanPtr, "", 0) < 0) { @@ -7330,7 +7331,8 @@ Tcl_SetChannelOption( * iso2022, the terminated escape sequence must write to the buffer. */ - if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) + if ((statePtr->encoding != NULL) + && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); -- cgit v0.12 From 267c1eb9f4c15531f7bf4095ffb56151ad8f9203 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 29 Apr 2014 17:40:15 +0000 Subject: Make sure no shared ChannelBuffers get recycled. --- generic/tclIO.c | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 08d0d93..6831c47 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -164,6 +164,7 @@ typedef struct CloseCallback { static ChannelBuffer * AllocChannelBuffer(int length); static void PreserveChannelBuffer(ChannelBuffer *bufPtr); static void ReleaseChannelBuffer(ChannelBuffer *bufPtr); +static int IsShared(ChannelBuffer *bufPtr); static void ChannelTimerProc(ClientData clientData); static int CheckChannelErrors(ChannelState *statePtr, int direction); @@ -2239,6 +2240,13 @@ ReleaseChannelBuffer( } ckfree((char *) bufPtr); } + +static int +IsShared( + ChannelBuffer *bufPtr) +{ + return bufPtr->refCount > 1; +} /* *---------------------------------------------------------------------- @@ -2269,6 +2277,9 @@ RecycleBuffer( /* * Do we have to free the buffer to the OS? */ + if (IsShared(bufPtr)) { + mustDiscard = 1; + } if (mustDiscard) { ReleaseChannelBuffer(bufPtr); -- cgit v0.12 From 75c22ad9870b02a3a9b9d213a1d38a1e93a7f7e7 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Apr 2014 19:12:37 +0000 Subject: Another segfault demo test, this one with [close] during [gets]. --- tests/ioCmd.test | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 8bf32d2..d2c0173 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -806,6 +806,22 @@ test iocmd-21.22 {[close] in [read] segfaults} -setup { catch {close $ch} rename foo {} } -match glob -result {*invalid argument*} +test iocmd-21.23 {[close] in [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + gets $ch +} -returnCodes error -cleanup { + catch {close $ch} + rename foo {} +} -match glob -result {*invalid argument*} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. -- cgit v0.12 From 1264e873bbaae9d4328826b749e459e88b32e820 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Apr 2014 19:33:21 +0000 Subject: Panic message to pinpoint the cause of iocmd-21.23 segfault. --- generic/tclIO.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6831c47..0c9db67 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4570,6 +4570,9 @@ FilterInputBytes( } bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; + if (bufPtr == NULL) { + Tcl_Panic("GetInput nuked buffers!"); + } } /* -- cgit v0.12 From 1c909a3352991d577a7164d5bb33dbe8d295ae67 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 30 Apr 2014 19:54:51 +0000 Subject: Stop the segfaults in [close] during [gets] tests. Not sure this is the right behavior, but it's better than crashing. --- generic/tclIO.c | 23 ++++++++++++++--------- tests/ioCmd.test | 21 +++++++++++++++++++-- 2 files changed, 33 insertions(+), 11 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0c9db67..cd28a0e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4163,12 +4163,12 @@ Tcl_GetsObj( restore: bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("Tcl_GetsObj: restore reached with bufPtr==NULL"); + if (bufPtr != NULL) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4298,6 +4298,9 @@ TclGetsObjBinary( goto restore; } bufPtr = statePtr->inQueueTail; + if (bufPtr == NULL) { + goto restore; + } } dst = (unsigned char *) RemovePoint(bufPtr); @@ -4410,12 +4413,12 @@ TclGetsObjBinary( restore: bufPtr = statePtr->inQueueHead; - if (bufPtr == NULL) { - Tcl_Panic("TclGetsObjBinary: restore reached with bufPtr==NULL"); + if (bufPtr) { + bufPtr->nextRemoved = oldRemoved; + bufPtr = bufPtr->nextPtr; } - bufPtr->nextRemoved = oldRemoved; - for (bufPtr = bufPtr->nextPtr; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { + for ( ; bufPtr != NULL; bufPtr = bufPtr->nextPtr) { bufPtr->nextRemoved = BUFFER_PADDING; } CommonGetsCleanup(chanPtr); @@ -4571,7 +4574,9 @@ FilterInputBytes( bufPtr = statePtr->inQueueTail; gsPtr->bufPtr = bufPtr; if (bufPtr == NULL) { - Tcl_Panic("GetInput nuked buffers!"); + gsPtr->charsWrote = 0; + gsPtr->rawRead = 0; + return -1; } } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index d2c0173..bb133f9 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -818,10 +818,27 @@ test iocmd-21.23 {[close] in [gets] segfaults} -setup { set ch [chan create read foo] } -body { gets $ch -} -returnCodes error -cleanup { +} -cleanup { catch {close $ch} rename foo {} -} -match glob -result {*invalid argument*} +} -result {} +test iocmd-21.24 {[close] in binary [gets] segfaults} -setup { + proc foo {method chan args} { + switch -- $method initialize { + return {initialize finalize watch read} + } finalize {} watch {} read { + catch {close $chan} + return \n + } + } + set ch [chan create read foo] +} -body { + chan configure $ch -translation binary + gets $ch +} -cleanup { + catch {close $ch} + rename foo {} +} -result {} # --- --- --- --------- --------- --------- # Helper commands to record the arguments to handler methods. -- cgit v0.12 From 10d7a2ac566063ffdd10a932a0d610ae6ecd62dd Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 30 Apr 2014 21:24:39 +0000 Subject: [82e7f67325] Fix an evil refcount problem in compiled [string replace]. --- generic/tclExecute.c | 14 ++++++++++++-- tests/stringComp.test | 34 +++++++++++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 3 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2c136d7..4ecca5b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5702,11 +5702,21 @@ TEBCresume( length - toIdx); } } else { - objResultPtr = value3Ptr; + /* + * Be careful with splicing the stack in this case; we have a + * refCount:1 object in value3Ptr and we want to append to it and + * make it be the refCount:1 object at the top of the stack + * afterwards. [Bug 82e7f67325] + */ + if (toIdx < length) { - Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, + Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1, length - toIdx); } + TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); + TclDecrRefCount(valuePtr); + OBJ_AT_TOS = value3Ptr; /* Tricky! */ + NEXT_INST_F(1, 0, 0); } TclDecrRefCount(value3Ptr); TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); diff --git a/tests/stringComp.test b/tests/stringComp.test index 9e00ce7..39dac78 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -26,6 +26,22 @@ catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} test stringComp-1.1 {error conditions} { proc foo {} {string gorp a b} @@ -687,7 +703,23 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} { ## not yet bc ## string replace -## not yet bc +test stringComp-14.1 {Bug 82e7f67325} { + apply {{} { + set a [join {a b} {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} +} {3 3} +test stringComp-14.2 {Bug 82e7f67325} { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {{} { + set a [join {a b} {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} + } +} {0} ## string tolower ## not yet bc -- cgit v0.12 From 7df749abdc0780eb176e6fade94388d60cd8a0ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Apr 2014 21:59:00 +0000 Subject: Better (safer) fix for [0e92c404f1] --- generic/tclCmdMZ.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 6fd468c..d106f53 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2086,7 +2086,7 @@ StringRangeCmd( * Unicode string rep to get the range. */ - if (objv[1]->typePtr == &tclByteArrayType) { + if (objv[1]->typePtr == &tclByteArrayType && (objv[1]->bytes==NULL)) { string = Tcl_GetByteArrayFromObj(objv[1], &length); length--; } else { -- cgit v0.12 From f715c2fad2a69457bbcbdf99167c66a3f62ed3a5 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 May 2014 01:15:42 +0000 Subject: missing constraint --- tests/stringComp.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/stringComp.test b/tests/stringComp.test index 39dac78..0d134b5 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -710,7 +710,7 @@ test stringComp-14.1 {Bug 82e7f67325} { lappend b [string length [string replace ___! 0 2 $a[unset a]]] }} } {3 3} -test stringComp-14.2 {Bug 82e7f67325} { +test stringComp-14.2 {Bug 82e7f67325} memory { # As in stringComp-14.1, but make sure we don't retain too many refs leaktest { apply {{} { -- cgit v0.12 From 1c52941e5f67f7f374dbc110234bf18a7ac4844a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 May 2014 07:38:27 +0000 Subject: Fix more corner-cases like [0e92c404f19ede5b2eb06e6db27647d3138cc56|0e92c404f1]: The only place where a type of &tclByteArrayType can be trusted is when determining its length, because the character length of a (UTF-8) string is always equal to the byte length of the byte array. --- generic/tclCmdMZ.c | 12 ++++++------ generic/tclExecute.c | 10 +++++----- generic/tclInt.h | 18 ++++++++++++++++++ generic/tclUtil.c | 2 +- 4 files changed, 30 insertions(+), 12 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index d106f53..70943e9 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1345,7 +1345,7 @@ StringIndexCmd( * Unicode string rep to get the index'th char. */ - if (objv[1]->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(objv[1])) { const unsigned char *string = Tcl_GetByteArrayFromObj(objv[1], &length); @@ -2086,7 +2086,7 @@ StringRangeCmd( * Unicode string rep to get the range. */ - if (objv[1]->typePtr == &tclByteArrayType && (objv[1]->bytes==NULL)) { + if (TclIsPureByteArray(objv[1])) { string = Tcl_GetByteArrayFromObj(objv[1], &length); length--; } else { @@ -2537,8 +2537,8 @@ StringEqualCmd( return TCL_OK; } - if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { /* * Use binary versions of comparisons since that won't cause undue * type conversions and it is much faster. Only do this if we're @@ -2684,8 +2684,8 @@ StringCmpCmd( return TCL_OK; } - if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { /* * Use binary versions of comparisons since that won't cause undue * type conversions and it is much faster. Only do this if we're diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2e396e8..c4f9836 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4235,8 +4235,8 @@ TclExecuteByteCode( */ iResult = s1len = s2len = 0; - } else if ((valuePtr->typePtr == &tclByteArrayType) - && (value2Ptr->typePtr == &tclByteArrayType)) { + } else if (TclIsPureByteArray(valuePtr) + && TclIsPureByteArray(value2Ptr)) { s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); iResult = memcmp(s1, s2, @@ -4354,7 +4354,7 @@ TclExecuteByteCode( * use the Unicode string rep to get the index'th char. */ - if (valuePtr->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(valuePtr)) { bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); } else { /* @@ -4370,7 +4370,7 @@ TclExecuteByteCode( } if ((index >= 0) && (index < length)) { - if (valuePtr->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj((unsigned char *) (&bytes[index]), 1); } else if (valuePtr->bytes && length == valuePtr->length) { @@ -4422,7 +4422,7 @@ TclExecuteByteCode( ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, length1, ustring2, length2, nocase); - } else if ((valuePtr->typePtr == &tclByteArrayType) && !nocase) { + } else if (TclIsPureByteArray(valuePtr) && !nocase) { unsigned char *string1, *string2; int length1, length2; diff --git a/generic/tclInt.h b/generic/tclInt.h index 00b246b..2353450 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3668,6 +3668,24 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file, /* *---------------------------------------------------------------- + * Macro that encapsulates the logic that determines when it is safe to + * interpret a string as a byte array directly. In summary, the object must be + * a byte array and must not have a string representation (as the operations + * that it is used in are defined on strings, not byte arrays). Theoretically + * it is possible to also be efficient in the case where the object's bytes + * field is filled by generation from the byte array (c.f. list canonicality) + * but we don't do that at the moment since this is purely about efficiency. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclIsPureByteArray(objPtr) \ + (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) + +/* + *---------------------------------------------------------------- * Macro used by the Tcl core to compare Unicode strings. On big-endian * systems we can use the more efficient memcmp, but this would not be * lexically correct on little-endian systems. The ANSI C "prototype" for diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5f4cdae..8c6adfe 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -2334,7 +2334,7 @@ TclStringMatchObj( udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); - } else if ((strObj->typePtr == &tclByteArrayType) && !flags) { + } else if (TclIsPureByteArray(strObj) && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); -- cgit v0.12 From f90303fa441e484833044f364aae0974a6a705d4 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 1 May 2014 09:11:09 +0000 Subject: make doubly sure that things which should be unshared stay unshared --- tests/stringComp.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/stringComp.test b/tests/stringComp.test index 0d134b5..165ef20 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -704,20 +704,20 @@ test stringComp-12.1 {Bug 3588366: end-offsets before start} { ## string replace test stringComp-14.1 {Bug 82e7f67325} { - apply {{} { - set a [join {a b} {}] + apply {x { + set a [join $x {}] lappend b [string length [string replace ___! 0 2 $a]] lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} + }} {a b} } {3 3} test stringComp-14.2 {Bug 82e7f67325} memory { # As in stringComp-14.1, but make sure we don't retain too many refs leaktest { - apply {{} { - set a [join {a b} {}] + apply {x { + set a [join $x {}] lappend b [string length [string replace ___! 0 2 $a]] lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} + }} {a b} } } {0} -- cgit v0.12 From cf5a2fcdb5b8dd834e530641922f7ba5c841553f Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 May 2014 14:18:35 +0000 Subject: We must Preserve channels if we're going to use TclChanCaughtErrorBypass() to get error information after channel routines are called (and have possibly called for the channel to go away). --- generic/tclIOCmd.c | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 7e8e91a..b206303 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -177,6 +177,7 @@ Tcl_PutsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); result = Tcl_WriteObj(chan, string); if (result < 0) { goto error; @@ -187,6 +188,7 @@ Tcl_PutsObjCmd( goto error; } } + Tcl_Release(chan); return TCL_OK; /* @@ -202,6 +204,7 @@ Tcl_PutsObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); return TCL_ERROR; } @@ -248,6 +251,7 @@ Tcl_FlushObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); if (Tcl_Flush(chan) != TCL_OK) { /* * TIP #219. @@ -261,8 +265,10 @@ Tcl_FlushObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -295,6 +301,7 @@ Tcl_GetsObjCmd( int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; + int code = TCL_OK; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?varName?"); @@ -310,6 +317,7 @@ Tcl_GetsObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); linePtr = Tcl_NewObj(); lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { @@ -329,7 +337,8 @@ Tcl_GetsObjCmd( TclGetString(chanObjPtr), "\": ", Tcl_PosixError(interp), NULL); } - return TCL_ERROR; + code = TCL_ERROR; + goto done; } lineLen = -1; } @@ -339,11 +348,12 @@ Tcl_GetsObjCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen)); - return TCL_OK; } else { Tcl_SetObjResult(interp, linePtr); } - return TCL_OK; + done: + Tcl_Release(chan); + return code; } /* @@ -542,6 +552,7 @@ Tcl_SeekObjCmd( mode = modeArray[optionIndex]; } + Tcl_Preserve(chan); result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { /* @@ -555,8 +566,10 @@ Tcl_SeekObjCmd( TclGetString(objv[1]), "\": ", Tcl_PosixError(interp), NULL); } + Tcl_Release(chan); return TCL_ERROR; } + Tcl_Release(chan); return TCL_OK; } @@ -587,6 +600,7 @@ Tcl_TellObjCmd( { Tcl_Channel chan; /* The channel to tell on. */ Tcl_WideInt newLoc; + int code; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -602,6 +616,7 @@ Tcl_TellObjCmd( return TCL_ERROR; } + Tcl_Preserve(chan); newLoc = Tcl_Tell(chan); /* @@ -610,7 +625,10 @@ Tcl_TellObjCmd( * them into the regular interpreter result. */ - if (TclChanCaughtErrorBypass(interp, chan)) { + + code = TclChanCaughtErrorBypass(interp, chan); + Tcl_Release(chan); + if (code) { return TCL_ERROR; } -- cgit v0.12