From e11daf6fb666f377464fdedddde9126ba31658d7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Jun 2016 09:01:26 +0000 Subject: (cherry-pick) [c30087b04f] Install man pages with permissions 644 instead of 444. --- unix/installManPage | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/installManPage b/unix/installManPage index 6bdccf0..1dbd232 100755 --- a/unix/installManPage +++ b/unix/installManPage @@ -105,7 +105,7 @@ for Target in $Names; do First=$Target sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \ $ManPage > $Dir/$First - chmod 444 $Dir/$First + chmod 644 $Dir/$First $Gzip $Dir/$First else ln $SymOrLoc$First$Gz $Dir/$Target$Gz -- cgit v0.12 From 8f0cfce66a4fd94536faac0595c3d7d7c7844d64 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 8 Jul 2016 12:38:35 +0000 Subject: (cherry-pick): Bugfix [5d7ea04580]. Treat .cmd and .ps1 files are executable on Windows. --- doc/file.n | 4 +++- win/tclWinFile.c | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/doc/file.n b/doc/file.n index 36eae79..43eae7a 100644 --- a/doc/file.n +++ b/doc/file.n @@ -156,7 +156,9 @@ returns \fB/home\fR (or something similar). \fBfile executable \fIname\fR . Returns \fB1\fR if file \fIname\fR is executable by the current user, -\fB0\fR otherwise. +\fB0\fR otherwise. On Windows, which does not have an executable attribute, +the command treats all directories and any files with extensions +\fBexe\fR, \fBcom\fR, \fBcmd\fR, \fBbat\fR or \fBps1\fR as executable. .TP \fBfile exists \fIname\fR . diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 41de4a8..e671058 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1783,7 +1783,7 @@ NativeAccess( * NativeIsExec -- * * Determines if a path is executable. On windows this is simply defined - * by whether the path ends in any of ".exe", ".com", or ".bat" + * by whether the path ends in a standard executable extension. * * Results: * 1 = executable, 0 = not. @@ -1834,6 +1834,8 @@ NativeIsExec( if ((strcasecmp(p, "exe") == 0) || (strcasecmp(p, "com") == 0) + || (strcasecmp(p, "cmd") == 0) + || (strcasecmp(p, "ps1") == 0) || (strcasecmp(p, "bat") == 0)) { /* * File that ends with .exe, .com, or .bat is executable. -- cgit v0.12 From 812e86e692342eea4435ae5eb01bce552c7350e2 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Jul 2016 11:56:28 +0000 Subject: [77d58e3a7a] Test case independence: unload. --- tests/tcltest.test | 7 ++- tests/unload.test | 170 +++++++++++++++++++++++++++++++++++++---------------- 2 files changed, 125 insertions(+), 52 deletions(-) diff --git a/tests/tcltest.test b/tests/tcltest.test index e66678b..728a018 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -46,6 +46,7 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -1824,9 +1825,13 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/unload.test b/tests/unload.test index 5a374c4..73f1091 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -45,6 +45,14 @@ testConstraint teststaticpkg [llength [info commands teststaticpkg]] testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] +proc loadIfNotPresent {pkg args} { + global testDir ext + set loaded [lmap x [info loaded {*}$args] {lindex $x 1}] + if {[string totitle $pkg] ni $loaded} { + load [file join $testDir $pkg$ext] + } +} + # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload @@ -73,7 +81,7 @@ set pkgua_detached {} set pkgua_unloaded {} # Tests for loading/unloading in trusted (non-safe) interpreters... test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] { - load [file join $testDir pkga$ext] + loadIfNotPresent pkga list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] { @@ -82,28 +90,43 @@ test unload-2.2 {basic loading of unloadable package, with guess for package nam [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} -test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} [list $dll $loaded] { - list [catch {unload [file join $testDir pkga$ext]} msg] \ - [string map [list [file join $testDir pkga$ext] file] $msg] -} {1 {file "file" cannot be unloaded under a trusted interpreter}} -test unload-2.4 {basic unloading of unloadable package, with guess for package name} [list $dll $loaded] { +test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} -setup { + loadIfNotPresent pkga +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkga$ext] +} -result {file "*" cannot be unloaded under a trusted interpreter} +test unload-2.4 {basic unloading of unloadable package, with guess for package name} -setup { + loadIfNotPresent pkgua +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {. {} {} {} {} . . .} -test unload-2.5 {reloading of unloaded package, with guess for package name} [list $dll $loaded] { +} -result {. {} {} {} {} . . .} +test unload-2.5 {reloading of unloaded package, with guess for package name} -setup { + if {$pkgua_loaded eq ""} { + loadIfNotPresent pkgua + unload [file join $testDir pkgua$ext] + } +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} -test unload-2.6 {basic unloading of re-loaded package, with guess for package name} [list $dll $loaded] { +} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} +test unload-2.6 {basic unloading of re-loaded package, with guess for package name} -setup { + # Establish expected state + if {$pkgua_loaded eq ""} { + loadIfNotPresent pkgua + unload [file join $testDir pkgua$ext] + load [file join $testDir pkgua$ext] + } +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {.. . . {} {} .. .. ..} +} -result {.. . . {} {} .. .. ..} # Tests for loading/unloading in safe interpreters... interp create -safe child @@ -127,38 +150,52 @@ test unload-3.2 {basic loading of unloadable package in a safe interpreter, with [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} -test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} \ - [list $dll $loaded] { - list [catch {unload [file join $testDir pkga$ext] {} child} msg] \ - [string map [list [file join $testDir pkga$ext] file] $msg] -} {1 {file "file" has never been loaded in this interpreter}} -test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { - list [catch {unload [file join $testDir pkgb$ext] {} child} msg] \ - [string map [list [file join $testDir pkgb$ext] file] $msg] -} {1 {file "file" cannot be unloaded under a safe interpreter}} -test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup { + loadIfNotPresent pkga +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkga$ext] {} child +} -result {file "*" has never been loaded in this interpreter} +test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { + if {[lsearch -index 1 [info loaded child] Pkgb] == -1} { + load [file join $testDir pkgb$ext] pKgB child + } +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkgb$ext] {} child +} -result {file "*" cannot be unloaded under a safe interpreter} +test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { + if {[lsearch -index 1 [info loaded child] Pkgua] == -1} { + load [file join $testDir pkgua$ext] pkgua child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. {} {}} {} {} {. . .}} -test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +} -result {{. {} {}} {} {} {. . .}} +test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} -setup { + if {[child eval set pkgua_loaded] eq ""} { + load [file join $testDir pkgua$ext] {} child + unload [file join $testDir pkgua$ext] {} child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] {} child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} -test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} \ - [list $dll $loaded] { +} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} +test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} -setup { + if {[child eval set pkgua_loaded] eq ""} { + load [file join $testDir pkgua$ext] {} child + unload [file join $testDir pkgua$ext] {} child + load [file join $testDir pkgua$ext] {} child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] pKgUa child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{.. . .} {} {} {.. .. ..}} +} -result {{.. . .} {} {} {.. .. ..}} # Tests for loading/unloading of a package among multiple interpreters... interp create child-trusted @@ -167,56 +204,89 @@ child-trusted eval { set pkgua_detached {} set pkgua_unloaded {} } +array set load {M 0 C 0 T 0} ## Load package in main trusted interpreter... -test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} -setup { + set pkgua_loaded "" + set pkgua_detached "" + set pkgua_unloaded "" + incr load(M) +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] -} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-safe interpreter... -test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ - [list $dll $loaded] { +test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} -setup { + child eval { + set pkgua_loaded "" + set pkgua_detached "" + set pkgua_unloaded "" + } + incr load(C) +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] pKgUA child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-trusted interpreter... -test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} \ - [list $dll $loaded] { +test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} -setup { + incr load(T) +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] pkguA child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Unload the package from the main trusted interpreter... -test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} -setup { + if {!$load(M)} { + load [file join $testDir pkgua$ext] + } + if {!$load(C)} { + load [file join $testDir pkgua$ext] {} child + incr load(C) + } + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + incr load(T) + } +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] -} {{... .. ..} {} {} {... ... ..}} +} -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child safe interpreter... -test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup { + if {!$load(C)} { + load [file join $testDir pkgua$ext] {} child + } + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + incr load(T) + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{... .. ..} {} {} {... ... ..}} +} -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child trusted interpreter... -test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup { + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + } +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child-trusted] \ [child-trusted eval info commands pkgua_*] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. {} {}} {} {} {. . .}} +} -result {{. {} {}} {} {} {. . .}} test unload-5.1 {unload a module loaded from vfs} \ -constraints [list $dll $loaded testsimplefilesystem] \ @@ -230,9 +300,7 @@ test unload-5.1 {unload a module loaded from vfs} \ list [catch {unload simplefs:/pkgua$ext} msg] $msg } \ -result {0 {}} - - - + # cleanup interp delete child interp delete child-trusted -- cgit v0.12 From 30b6493bb7a01568ed7fa236badef647b30ad038 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Jul 2016 12:02:27 +0000 Subject: [77d58e3a7a] Test case independence: var. --- tests/var.test | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/tests/var.test b/tests/var.test index 690bd10..297034a 100644 --- a/tests/var.test +++ b/tests/var.test @@ -169,7 +169,9 @@ test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: set result } } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} { +test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup { + unset -nocomplain test_ns_var::x +} -body { namespace eval test_ns_var { variable result {} variable x @@ -181,7 +183,7 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: namespace delete [namespace current] set result } -} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} +} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { [format set] thisvar(doesntexist) } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} -- cgit v0.12 From a127a9e4aa8b2a9a386cd7fe694bfef8f1cf5264 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 18 Jul 2016 16:26:44 +0000 Subject: [104f2885bb] Rework the "chan" Tcl_ObjType to properly validate cached channel name lookups. --- generic/tclIO.c | 161 ++++++++++++++++++++++++++------------------------------ generic/tclIO.h | 6 +-- tests/io.test | 19 +++++++ 3 files changed, 97 insertions(+), 89 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 7bc849e..615fe60 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -312,14 +312,20 @@ static int WillRead(Channel *chanPtr); && (strncmp(optionName, (nameString), len) == 0)) /* - * The ChannelObjType type. We actually store the ChannelState structure - * as that lives longest and we want to return the bottomChanPtr when - * requested (consistent with Tcl_GetChannel). The setFromAny and - * updateString can be NULL as they should not be called. + * The ChannelObjType type. Used to store the result of looking up + * a channel name in the context of an interp. Saves the lookup + * result and values needed to check its continued validity. */ +typedef struct ResolvedChanName { + ChannelState *statePtr; /* The saved lookup result */ + Tcl_Interp *interp; /* The interp in which the lookup was done. */ + int epoch; /* The epoch of the channel when the lookup + * was done. Use to verify validity. */ + int refCount; /* Share this struct among many Tcl_Obj. */ +} ResolvedChanName; + static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); -static int SetChannelFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void FreeChannelIntRep(Tcl_Obj *objPtr); static Tcl_ObjType chanObjType = { @@ -327,18 +333,9 @@ static Tcl_ObjType chanObjType = { FreeChannelIntRep, /* freeIntRepProc */ DupChannelIntRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc SetChannelFromAny */ + NULL /* setFromAnyProc */ }; -#define GET_CHANNELSTATE(objPtr) \ - ((ChannelState *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_CHANNELSTATE(objPtr, storePtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (storePtr)) -#define GET_CHANNELINTERP(objPtr) \ - ((Tcl_Interp *) (objPtr)->internalRep.twoPtrValue.ptr2) -#define SET_CHANNELINTERP(objPtr, storePtr) \ - ((objPtr)->internalRep.twoPtrValue.ptr2 = (void *) (storePtr)) - #define BUSY_STATE(st,fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -936,7 +933,7 @@ DeleteChannelTable( */ Tcl_DeleteHashEntry(hPtr); - SetFlag(statePtr, CHANNEL_TAINTED); + statePtr->epoch++; statePtr->refCount--; if (statePtr->refCount <= 0) { if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { @@ -1280,7 +1277,7 @@ DetachChannel( return TCL_ERROR; } Tcl_DeleteHashEntry(hPtr); - SetFlag(statePtr, CHANNEL_TAINTED); + statePtr->epoch++; /* * Remove channel handlers that refer to this interpreter, so that @@ -1413,12 +1410,57 @@ TclGetChannelFromObj( int flags) { ChannelState *statePtr; + ResolvedChanName *resPtr = NULL; + Tcl_Channel chan; + + if (interp == NULL) { + return TCL_ERROR; + } + + if (objPtr->typePtr == &chanObjType) { + /* + * Confirm validity of saved lookup results. + */ + + resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; + statePtr = resPtr->statePtr; + if ((resPtr->interp == interp) /* Same interp context */ + /* No epoch change in channel since lookup */ + && (resPtr->epoch == statePtr->epoch)) { + + /* Have a valid saved lookup. Jump to end to return it. */ + goto valid; + } + } + + chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - if (SetChannelFromAny(interp, objPtr) != TCL_OK) { + if (chan == NULL) { + if (resPtr) { + FreeChannelIntRep(objPtr); + } return TCL_ERROR; } - statePtr = GET_CHANNELSTATE(objPtr); + if (resPtr && resPtr->refCount == 1) { + /* Re-use the ResolvedCmdName struct */ + Tcl_Release((ClientData) resPtr->statePtr); + + } else { + TclFreeIntRep(objPtr); + + resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; + objPtr->typePtr = &chanObjType; + } + statePtr = ((Channel *)chan)->state; + resPtr->statePtr = statePtr; + Tcl_Preserve((ClientData) statePtr); + resPtr->interp = interp; + resPtr->epoch = statePtr->epoch; + + valid: *channelPtr = (Tcl_Channel) (statePtr->bottomChanPtr); if (modePtr != NULL) { @@ -1568,6 +1610,8 @@ Tcl_CreateChannel( statePtr->chanMsg = NULL; statePtr->unreportedMsg = NULL; + statePtr->epoch = 0; + /* * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels in @@ -10439,78 +10483,17 @@ DupChannelIntRep( register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ChannelState *statePtr = GET_CHANNELSTATE(srcPtr); + ResolvedChanName *resPtr + = (ResolvedChanName *) srcPtr->internalRep.twoPtrValue.ptr1; - SET_CHANNELSTATE(copyPtr, statePtr); - SET_CHANNELINTERP(copyPtr, GET_CHANNELINTERP(srcPtr)); - Tcl_Preserve((ClientData) statePtr); + resPtr->refCount++; + copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->typePtr = srcPtr->typePtr; } /* *---------------------------------------------------------------------- * - * SetChannelFromAny -- - * - * Create an internal representation of type "Channel" for an object. - * - * Results: - * This operation always succeeds and returns TCL_OK. - * - * Side effects: - * Any old internal reputation for objPtr is freed and the internal - * representation is set to "Channel". - * - *---------------------------------------------------------------------- - */ - -static int -SetChannelFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ -{ - ChannelState *statePtr; - - if (interp == NULL) { - return TCL_ERROR; - } - if (objPtr->typePtr == &chanObjType) { - /* - * TODO: TAINT Flag and dup'd channel values? - * The channel is valid until any call to DetachChannel occurs. - * Ensure consistency checks are done. - */ - - statePtr = GET_CHANNELSTATE(objPtr); - if (GotFlag(statePtr, CHANNEL_TAINTED|CHANNEL_CLOSED)) { - ResetFlag(statePtr, CHANNEL_TAINTED); - Tcl_Release((ClientData) statePtr); - objPtr->typePtr = NULL; - } else if (interp != GET_CHANNELINTERP(objPtr)) { - Tcl_Release((ClientData) statePtr); - objPtr->typePtr = NULL; - } - } - if (objPtr->typePtr != &chanObjType) { - Tcl_Channel chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL); - - if (chan == NULL) { - return TCL_ERROR; - } - - TclFreeIntRep(objPtr); - statePtr = ((Channel *)chan)->state; - Tcl_Preserve((ClientData) statePtr); - SET_CHANNELSTATE(objPtr, statePtr); - SET_CHANNELINTERP(objPtr, interp); - objPtr->typePtr = &chanObjType; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * FreeChannelIntRep -- * * Release statePtr storage. @@ -10528,7 +10511,15 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Release((ClientData) GET_CHANNELSTATE(objPtr)); + ResolvedChanName *resPtr + = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; + + objPtr->typePtr = NULL; + if (--resPtr->refCount) { + return; + } + Tcl_Release((ClientData) resPtr->statePtr); + ckfree((char *)resPtr); } #if 0 diff --git a/generic/tclIO.h b/generic/tclIO.h index 348a9c5..d096798 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -214,6 +214,8 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ + int epoch; /* Used to test validity of stored channelname + * lookup results. */ } ChannelState; /* @@ -275,10 +277,6 @@ typedef struct ChannelState { * usable, but it may not be closed * again from within the close * handler. */ -#define CHANNEL_TAINTED (1<<20) /* Channel stack structure has changed. - * Used by Channel Tcl_Obj type to - * determine if we have to revalidate - * the channel. */ /* * Local Variables: diff --git a/tests/io.test b/tests/io.test index 50c5808..7275b42 100644 --- a/tests/io.test +++ b/tests/io.test @@ -38,6 +38,7 @@ testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] testConstraint testthread [llength [info commands testthread]] +testConstraint testobj [llength [info commands testobj]] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -8522,6 +8523,24 @@ test io-73.5 {effect of eof on encoding end flags} -setup { removeFile io-73.5 } -result [list 1 1 more\u00a0data 1] +test io-74.1 {[104f2885bb] improper cache validity check} -setup { + set fn [makeFile {} io-74.1] + set rfd [open $fn r] + testobj freeallvars + interp create slave +} -constraints testobj -body { + teststringobj set 1 [string range $rfd 0 end] + read [teststringobj get 1] + testobj duplicate 1 2 + interp transfer {} $rfd slave + catch {read [teststringobj get 1]} + read [teststringobj get 2] +} -cleanup { + interp delete slave + testobj freeallvars + removeFile io-74.1 +} -returnCodes error -match glob -result {can not find channel named "*"} + # ### ### ### ######### ######### ######### # cleanup -- cgit v0.12