From f3f5448b0aa89dfc3c913d3f2e43e34e1c0c106c Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 8 Jun 2012 15:51:00 +0000 Subject: Work in progress fixing 3532959 --- generic/tclBasic.c | 3 ++- generic/tclProc.c | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 954b2b3..1d289f2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1388,7 +1388,8 @@ DeleteInterpProc( hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); - + Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); + procPtr->iPtr = NULL; if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); } diff --git a/generic/tclProc.c b/generic/tclProc.c index 43e88c6..325506b 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2198,7 +2198,7 @@ TclProcCleanupProc( * the same ProcPtr is overwritten with a new CmdFrame. */ - if (!iPtr) { + if (iPtr == NULL || iPtr->linePBodyPtr == NULL) { return; } -- cgit v0.12 From ac5377745066c2cc9fdc1d30ff2d449e2bb5b6d4 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 10 Jun 2012 23:34:45 +0000 Subject: 3532959 Arrange for every lambda to place an entry in the linePBodyPtr hash table. Then the two teardowns of data in that table synchronize so that the first to run signals the other not to operate. Test proc-7.4 in a mem debug build of Tcl will detect Bug 3532959 by crashing. --- generic/tclBasic.c | 10 ++++++---- generic/tclProc.c | 22 +++++++++++++--------- tests/proc.test | 8 ++++++++ 3 files changed, 27 insertions(+), 13 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 1d289f2..fa13b50 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1390,11 +1390,13 @@ DeleteInterpProc( CmdFrame *cfPtr = Tcl_GetHashValue(hPtr); Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr); procPtr->iPtr = NULL; - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + } + ckfree((char *) cfPtr->line); + ckfree((char *) cfPtr); } - ckfree((char *) cfPtr->line); - ckfree((char *) cfPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->linePBodyPtr); diff --git a/generic/tclProc.c b/generic/tclProc.c index 325506b..7a93dbf 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2198,7 +2198,7 @@ TclProcCleanupProc( * the same ProcPtr is overwritten with a new CmdFrame. */ - if (iPtr == NULL || iPtr->linePBodyPtr == NULL) { + if (iPtr == NULL) { return; } @@ -2209,13 +2209,15 @@ TclProcCleanupProc( cfPtr = (CmdFrame *) Tcl_GetHashValue(hePtr); - if (cfPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(cfPtr->data.eval.path); - cfPtr->data.eval.path = NULL; + if (cfPtr) { + if (cfPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(cfPtr->data.eval.path); + cfPtr->data.eval.path = NULL; + } + ckfree((char *) cfPtr->line); + cfPtr->line = NULL; + ckfree((char *) cfPtr); } - ckfree((char *) cfPtr->line); - cfPtr->line = NULL; - ckfree((char *) cfPtr); Tcl_DeleteHashEntry(hePtr); } @@ -2447,7 +2449,7 @@ SetLambdaFromAny( Interp *iPtr = (Interp *) interp; char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; - int objc, result; + int isNew, objc, result; Proc *procPtr; if (interp == NULL) { @@ -2512,6 +2514,8 @@ SetLambdaFromAny( * common elements into a single function. */ + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, + &isNew), NULL); if (iPtr->cmdFramePtr) { CmdFrame *contextPtr; @@ -2544,7 +2548,7 @@ SetLambdaFromAny( if (contextPtr->line && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { - int isNew, buf[2]; + int buf[2]; CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); /* diff --git a/tests/proc.test b/tests/proc.test index 5673caa..c0f80e3 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -391,6 +391,14 @@ test proc-7.3 {Returning loop exception from redefined cmd: Bug 729692} { set res } {0 4} +test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { + set lambda x + lappend lambda {set a 1} + interp create slave + slave eval [list apply $lambda foo] + interp delete slave + unset lambda +} {} # cleanup -- cgit v0.12 From 2c0667d7b04e34fa929ccc4758a19af166cf4206 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 11 Jun 2012 12:21:30 +0000 Subject: Revised so that we avoid hashing twice. --- generic/tclProc.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 7a93dbf..2c6d300 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2450,6 +2450,7 @@ SetLambdaFromAny( char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr; int isNew, objc, result; + CmdFrame *cfPtr = NULL; Proc *procPtr; if (interp == NULL) { @@ -2514,8 +2515,6 @@ SetLambdaFromAny( * common elements into a single function. */ - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, - &isNew), NULL); if (iPtr->cmdFramePtr) { CmdFrame *contextPtr; @@ -2549,13 +2548,13 @@ SetLambdaFromAny( if (contextPtr->line && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) { int buf[2]; - CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ + cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; @@ -2571,9 +2570,6 @@ SetLambdaFromAny( cfPtr->cmd.str.cmd = NULL; cfPtr->cmd.str.len = 0; - - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, - (char *) procPtr, &isNew), cfPtr); } /* @@ -2585,6 +2581,8 @@ SetLambdaFromAny( } TclStackFree(interp, contextPtr); } + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->linePBodyPtr, (char *) procPtr, + &isNew), cfPtr); /* * Set the namespace for this lambda: given by objv[2] understood as a -- cgit v0.12 From b1856533641e3211ef6e5b973ef1b0ea065c20ea Mon Sep 17 00:00:00 2001 From: dkf Date: Tue, 12 Jun 2012 12:35:18 +0000 Subject: add test that triggered reporting of [Bug 3530230] --- tests/safe.test | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/tests/safe.test b/tests/safe.test index 4bd8509..8879518 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -309,6 +309,20 @@ test safe-8.9 {safe source and return} -setup { catch {safe::interpDelete $i} removeFile $returnScript } -result ok +test safe-8.10 {safe source and return} -setup { + set returnScript [makeFile {return -level 2 "ok"} return.tcl] + catch {safe::interpDelete $i} +} -body { + safe::interpCreate $i + set token [safe::interpAddToAccessPath $i [file dirname $returnScript]] + $i eval [list apply {filename { + source $filename + error boom + }} $token/[file tail $returnScript]] +} -cleanup { + catch {safe::interpDelete $i} + removeFile $returnScript +} -result ok test safe-9.1 {safe interps' deleteHook} { set i "a"; -- cgit v0.12 From 9e832d51f5cf8e1317b58eae1f0b7ded6e0b198d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jun 2012 07:27:05 +0000 Subject: more readable --- library/dde/pkgIndex.tcl | 2 +- library/platform/shell.tcl | 2 +- library/reg/pkgIndex.tcl | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index db67e98..1450276 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,5 +1,5 @@ if {![package vsatisfies [package provide Tcl] 8]} return -if {[string compare [info sharedlibextension] .dll]} return +if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { package ifneeded dde 1.2.5 [list load [file join $dir tcldde12g.dll] dde] } else { diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl index e0a129a..d37cdcd 100644 --- a/library/platform/shell.tcl +++ b/library/platform/shell.tcl @@ -187,7 +187,7 @@ proc ::platform::shell::TEMP {} { } } } - if {[string compare $channel ""]} { + if {$channel != ""} { return -code error "Failed to open a temporary file: $channel" } else { return -code error "Failed to find an unused temporary file name" diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 35b1143..40032a5 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,5 +1,5 @@ if {![package vsatisfies [package provide Tcl] 8]} return -if {[string compare [info sharedlibextension] .dll]} return +if {[info sharedlibextension] != ".dll"} return if {[info exists ::tcl_platform(debug)]} { package ifneeded registry 1.1.5 \ [list load [file join $dir tclreg11g.dll] registry] -- cgit v0.12 From 7485fdafcf89b96cc2194aed57e115adebe20580 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jun 2012 13:56:20 +0000 Subject: fix fCmd-6.19 on win32, which was broken by [a7e00a0e02] --- tests/fCmd.test | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/tests/fCmd.test b/tests/fCmd.test index f2adcef..4775f05 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -48,15 +48,15 @@ if {[testConstraint unix]} { set group [lindex $groupList 0] testConstraint foundGroup 1 } +} - proc dev dir { - file stat $dir stat - return $stat(dev) - } +proc dev dir { + file stat $dir stat + return $stat(dev) +} - if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { - testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] - } +if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { + testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] } # Also used in winFCmd... -- cgit v0.12 From c27b10d62b0addac6746257f64433a0c9ebd7ce5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Jun 2012 09:02:06 +0000 Subject: upgrade to 1.2.7 build of dll --- compat/zlib/win32/zlib1.dll | Bin 100352 -> 107520 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll index 869b00d..9943b3e 100644 Binary files a/compat/zlib/win32/zlib1.dll and b/compat/zlib/win32/zlib1.dll differ -- cgit v0.12 From bccf168ae55a2c314248ee8e3a2369efba47f317 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Jun 2012 09:39:34 +0000 Subject: alternative fix for [a7e00a0e02] breakage: just make sure that the variable $tmpspace is always set --- tests/fCmd.test | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/tests/fCmd.test b/tests/fCmd.test index 4775f05..72b7da9 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -39,6 +39,7 @@ if {[testConstraint win]} { } } +set tmpspace /tmp;# default value # Find a group that exists on this Unix system, or else skip tests that # require Unix groups. testConstraint foundGroup [expr {![testConstraint unix]}] @@ -48,15 +49,15 @@ if {[testConstraint unix]} { set group [lindex $groupList 0] testConstraint foundGroup 1 } -} -proc dev dir { - file stat $dir stat - return $stat(dev) -} + proc dev dir { + file stat $dir stat + return $stat(dev) + } -if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { - testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] + if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { + testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] + } } # Also used in winFCmd... @@ -591,7 +592,7 @@ test fCmd-6.18 {CopyRenameOneFile: errno != EXDEV} -setup { [subst {error renaming "td2" to "[file join td1 td2]": file *}] test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} -setup { cleanup $tmpspace -} -constraints {xdev notRoot} -body { +} -constraints {unix notRoot} -body { createfile tf1 file rename tf1 $tmpspace glob -nocomplain tf* [file join $tmpspace tf1] @@ -610,21 +611,21 @@ test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} -constraints {win} -setup { } -result {d:/tcl8975@} test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} -setup { cleanup $tmpspace -} -constraints {xdev notRoot} -body { +} -constraints {unix notRoot} -body { file mkdir td1 file rename td1 $tmpspace glob -nocomplain td* [file join $tmpspace td*] } -result [file join $tmpspace td1] test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} -setup { cleanup $tmpspace -} -constraints {xdev notRoot} -body { +} -constraints {unix notRoot} -body { createfile tf1 file rename tf1 $tmpspace glob -nocomplain tf* [file join $tmpspace tf*] } -result [file join $tmpspace tf1] test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace -} -constraints {notRoot xdev} -body { +} -constraints {xdev notRoot} -body { file mkdir td1/td2/td3 file attributes td1 -permissions 0000 file rename td1 $tmpspace @@ -693,7 +694,7 @@ test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} -setup { } -result [file join $tmpspace td1 td2] test fCmd-6.30 {CopyRenameOneFile: TclpRemoveDirectory failed} -setup { cleanup $tmpspace -} -constraints {xdev notRoot} -body { +} -constraints {unix notRoot} -body { file mkdir foo/bar file attr foo -perm 040555 file rename foo/bar $tmpspace @@ -1353,7 +1354,7 @@ test fCmd-12.8 {renamefile: generic error} -setup { } -result {1} test fCmd-12.9 {renamefile: moving a file across volumes} -setup { cleanup $tmpspace -} -constraints {xdev notRoot} -body { +} -constraints {unix notRoot} -body { set s [createfile tfa] file rename tfa $tmpspace list [checkcontent [file join $tmpspace tfa] $s] [file exists tfa] -- cgit v0.12