diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2012-07-31 11:00:25 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2012-07-31 11:00:25 (GMT) |
| commit | ddad954e2df0db369c13c4c39d647a2c4abd67da (patch) | |
| tree | f8b70029a1b0635ea9c4954f14d160d90c3fb0ff | |
| parent | 0a213115cc2d64e0bf3608839b2b3f079e89c04e (diff) | |
| parent | cb75a6048aea230290902a214ce83d0a75e30a30 (diff) | |
| download | tcl-bug_3545363.zip tcl-bug_3545363.tar.gz tcl-bug_3545363.tar.bz2 | |
merge trunkbug_3545363
87 files changed, 494 insertions, 209 deletions
@@ -1,17 +1,59 @@ 2012-07-24 Trevor Davel <twylite@crypt.co.za> - * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file - descriptors for a socket where required (TcpCloseProc, SocketProc). Refactor - socket/descriptor setup to manage linked list operations in one place. Fix - memory leak in socket close (TcpCloseProc) and related dangling pointers in - SocketEventProc. - + * win/tclWinSock.c: [Bug: 3545363]: Loop over multiple underlying file + descriptors for a socket where required (TcpCloseProc, SocketProc). + Refactor socket/descriptor setup to manage linked list operations in + one place. Fix memory leak in socket close (TcpCloseProc) and related + dangling pointers in SocketEventProc. + 2012-07-19 Reinhard Max <max@suse.de> * win/tclWinSock.c (TcpAccept): [Bug: 3545363]: Use a large enough - buffer for accept()ing IPv6 connections. Fix conversion of host - and port for passing to the accept proc to be independent of the - IP version. + buffer for accept()ing IPv6 connections. Fix conversion of host and + port for passing to the accept proc to be independent of the IP + version. + +2012-07-31 Jan Nijtmans <nijtmans@users.sf.net> + + * win/nmakehlp.c: Add -Q option from sampleextension. + +2012-07-29 Jan Nijtmans <nijtmans@users.sf.net> + + * win/Makefile.in: No longer build tcltest.exe to run the tests, + but use tclsh86.exe in combination with tcltest86.dll to do that. + * tests/*.test: load tcltest86.dll if necessary. + +2012-07-28 Jan Nijtmans <nijtmans@users.sf.net> + + * tests/clock.test: [Bug 3549770] Multiple test failures running tcltest + * tests/registry.test: outside build tree + * tests/winDde.test: + +2012-07-27 Jan Nijtmans <nijtmans@users.sf.net> + + * generic/tclUniData.c: Support Unicode 6.2 (Add Turkish lira sign) + * generic/regc_locale.c: + +2012-07-25 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * win/tclWinPipe.c: [Bug 3547994]: Abandon the synchronous Windows + pipe driver to its fate when needed to honour TIP#398. + +2012-07-23 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * generic/tclIO.c: [Bug 3545365]: Never try a bg-flush on a dead + channel, just like before 2011-08-17. + +2012-07-19 Joe Mistachkin <joe@mistachkin.com> + + * generic/tclTest.c: Fix several more missing mutex-locks in + TestasyncCmd. + +2012-07-19 Alexandre Ferrieux <ferrieux@users.sourceforge.net> + + * generic/tclTest.c: [Bug 3544685]: Missing mutex-lock in + TestasyncCmd since 2011-08-19. Unbounded gratitude to Stuart + Cassoff for spotting it. 2012-07-17 Jan Nijtmans <nijtmans@users.sf.net> @@ -8101,6 +8101,10 @@ and Tcl_FSMountsChanged(). (porter) 2012-07-08 (bug fix)[3531209] accept IPv6 URLs (max) => http 2.8.4 +2012-07-24 (bug fix) stop mem corruption in stacked channel events (max,porter) + +2012-07-25 (bug fix)[3546275] [auto_execok] search match [exec] (danckaert) + Many revisions to better support a Cygwin environment (nijtmans) --- Released 8.6b3, July 30, 2012 --- See ChangeLog for details --- diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 188d6de..40791f4 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -617,7 +617,7 @@ static const crange graphRangeTable[] = { {0x1f48, 0x1f4d}, {0x1f50, 0x1f57}, {0x1f5f, 0x1f7d}, {0x1f80, 0x1fb4}, {0x1fb6, 0x1fc4}, {0x1fc6, 0x1fd3}, {0x1fd6, 0x1fdb}, {0x1fdd, 0x1fef}, {0x1ff2, 0x1ff4}, {0x1ff6, 0x1ffe}, {0x2010, 0x2027}, {0x2030, 0x205e}, - {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20b9}, {0x20d0, 0x20f0}, + {0x2074, 0x208e}, {0x2090, 0x209c}, {0x20a0, 0x20ba}, {0x20d0, 0x20f0}, {0x2100, 0x2189}, {0x2190, 0x23f3}, {0x2400, 0x2426}, {0x2440, 0x244a}, {0x2460, 0x26ff}, {0x2701, 0x2b4c}, {0x2b50, 0x2b59}, {0x2c00, 0x2c2e}, {0x2c30, 0x2c5e}, {0x2c60, 0x2cf3}, {0x2cf9, 0x2d25}, {0x2d30, 0x2d67}, diff --git a/generic/tclIO.c b/generic/tclIO.c index ea6c2d7..2de8b53 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -427,7 +427,10 @@ TclFinalizeIOSubsystem(void) statePtr != NULL; statePtr = statePtr->nextCSPtr) { chanPtr = statePtr->topChanPtr; - if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD) + if (GotFlag(statePtr, CHANNEL_DEAD)) { + continue; + } + if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED ) || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { ResetFlag(statePtr, BG_FLUSH_SCHEDULED); active = 1; @@ -8822,6 +8825,7 @@ TclChannelEventScriptInvoker( */ Tcl_Preserve(interp); + Tcl_Preserve(chanPtr); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* @@ -8838,6 +8842,7 @@ TclChannelEventScriptInvoker( } Tcl_BackgroundException(interp, result); } + Tcl_Release(chanPtr); Tcl_Release(interp); } diff --git a/generic/tclTest.c b/generic/tclTest.c index 3f06be0..b4192b2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -313,11 +313,8 @@ static int TestexitmainloopCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestfinexitObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int TestparserObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -638,7 +635,6 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL); Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd, NULL, NULL); @@ -870,6 +866,7 @@ TestasyncCmd( || (Tcl_GetInt(interp, argv[4], &code) != TCL_OK)) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -878,6 +875,7 @@ TestasyncCmd( } } Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); + Tcl_MutexUnlock(&asyncTestMutex); return code; #ifdef TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { @@ -887,6 +885,7 @@ TestasyncCmd( if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) { return TCL_ERROR; } + Tcl_MutexLock(&asyncTestMutex); for (asyncPtr = firstHandler; asyncPtr != NULL; asyncPtr = asyncPtr->nextPtr) { if (asyncPtr->id == id) { @@ -895,11 +894,13 @@ TestasyncCmd( INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } break; } } + Tcl_MutexUnlock(&asyncTestMutex); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create, delete, int, mark, or marklater", NULL); @@ -4547,47 +4548,6 @@ TestpanicCmd( return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * TestfinexitObjCmd -- - * - * Calls a variant of [exit] including the full finalization path. - * - * Results: - * Error, or doesn't return. - * - * Side effects: - * Exits application. - * - *---------------------------------------------------------------------- - */ - -static int -TestfinexitObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int value; - - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); - return TCL_ERROR; - } - - if (objc == 1) { - value = 0; - } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { - return TCL_ERROR; - } - Tcl_Finalize(); - TclpExit(value); - /*NOTREACHED*/ - return TCL_ERROR; /* Better not ever reach this! */ -} - static int TestfileCmd( ClientData dummy, /* Not used. */ diff --git a/generic/tclUniData.c b/generic/tclUniData.c index 2fabe58..5c88639 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -882,7 +882,7 @@ static const unsigned char groupMap[] = { 18, 18, 18, 18, 7, 7, 7, 5, 6, 85, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 85, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, - 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 111, 111, 111, 111, 86, 111, 111, 111, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 86, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, diff --git a/library/init.tcl b/library/init.tcl index d8de540..51c7f29 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -689,13 +689,14 @@ proc auto_execok name { } } - foreach dir [split $path {;}] { - # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq "")} { - continue - } - set checked($dir) {} - foreach ext $execExtensions { + foreach ext $execExtensions { + unset -nocomplain checked + foreach dir [split $path {;}] { + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} set file [file join $dir ${name}${ext}] if {[file exists $file] && ![file isdirectory $file]} { return [set auto_execs($name) [list $file]] diff --git a/tests/assocd.test b/tests/assocd.test index 1ca1c9b..d1489b3 100644 --- a/tests/assocd.test +++ b/tests/assocd.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testgetassocdata [llength [info commands testgetassocdata]] testConstraint testsetassocdata [llength [info commands testsetassocdata]] testConstraint testdelassocdata [llength [info commands testdelassocdata]] diff --git a/tests/async.test b/tests/async.test index 35dda88..cb67cc2 100644 --- a/tests/async.test +++ b/tests/async.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testasync [llength [info commands testasync]] testConstraint threaded [::tcl::pkgconfig get threaded] diff --git a/tests/basic.test b/tests/basic.test index e072bea..7435571 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -18,6 +18,9 @@ package require tcltest 2 namespace import -force ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testevalex [llength [info commands testevalex]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] testConstraint testcreatecommand [llength [info commands testcreatecommand]] diff --git a/tests/chanio.test b/tests/chanio.test index fbc9854..9bb11f7 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -29,6 +29,9 @@ namespace eval ::tcl::test::io { variable msg variable expected + ::tcltest::loadTestedCommands + catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testchannel [llength [info commands testchannel]] testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 diff --git a/tests/clock.test b/tests/clock.test index fd74512..0202fc7 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -17,11 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } if {[testConstraint win]} { - if {[catch {package require registry 1.1}] - && [catch {load {} Registry}] - && [catch { + if {[catch { ::tcltest::loadTestedCommands - load $::reglib Registry + package require registry }]} { namespace eval ::tcl::clock {variable NoRegistry {}} } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 291df8d..2ecf626 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 4b1002a..efb0bce 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] testConstraint testobj [llength [info commands testobj]] diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index 86aa6e1..69d7171 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testcmdinfo [llength [info commands testcmdinfo]] testConstraint testcmdtoken [llength [info commands testcmdtoken]] diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bb19151..bae26a0 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { testConstraint testmathfunctions 0 } else { diff --git a/tests/compExpr.test b/tests/compExpr.test index 8e27f1f..14c875d 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -13,6 +13,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { testConstraint testmathfunctions 0 } else { diff --git a/tests/compile.test b/tests/compile.test index d6048be..4d91940 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -14,6 +14,9 @@ package require tcltest 2 namespace import -force ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint exec [llength [info commands exec]] testConstraint memory [llength [info commands memory]] testConstraint testevalex [llength [info commands testevalex]] diff --git a/tests/coroutine.test b/tests/coroutine.test index 7f40a7b..8272717 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testnrelevels [llength [info commands testnrelevels]] testConstraint memory [llength [info commands memory]] diff --git a/tests/dcall.test b/tests/dcall.test index 8977c31..3df0ac8 100644 --- a/tests/dcall.test +++ b/tests/dcall.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testdcall [llength [info commands testdcall]] test dcall-1.1 {deletion callbacks} testdcall { diff --git a/tests/dstring.test b/tests/dstring.test index bcc304d..06121a3 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -16,6 +16,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testdstring [llength [info commands testdstring]] if {[testConstraint testdstring]} { testdstring free diff --git a/tests/encoding.test b/tests/encoding.test index b4ee7c3..0374e2d 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -15,6 +15,11 @@ namespace eval ::tcl::test::encoding { namespace import -force ::tcltest::* +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] +} + proc toutf {args} { variable x lappend x "toutf $args" @@ -31,7 +36,6 @@ proc runtests {} { testConstraint testencoding [llength [info commands testencoding]] testConstraint exec [llength [info commands exec]] testConstraint testgetdefenc [llength [info commands testgetdefenc]] -testConstraint testfinexit [llength [info commands testfinexit]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -418,13 +422,14 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec { gets $f } } {} -test encoding-24.2 {EscapeFreeProc on open channels} {exec testfinexit} { +test encoding-24.2 {EscapeFreeProc on open channels} {exec} { # Bug #524674 output viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator fconfigure stdout -encoding iso2022-jp puts ab\u4e4e\u68d9g - testfinexit + set env(TCL_FINALIZE_ON_EXIT) 1 + exit }] } "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)" test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { diff --git a/tests/event.test b/tests/event.test index 0ee7558..0d1b06c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -12,6 +12,13 @@ package require tcltest 2 namespace import -force ::tcltest::* +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] +} + + testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] @@ -427,6 +434,7 @@ catch {rename bgerror {}} test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; exit" flush $child @@ -440,6 +448,7 @@ odd 41 test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 41" puts $child "testexithandler create 16; exit" @@ -453,6 +462,7 @@ even 4 } test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 4" puts $child "testexithandler create 16; exit" @@ -466,6 +476,7 @@ odd 41 } test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler create 4" puts $child "testexithandler create 6; testexithandler delete 6" puts $child "testexithandler create 16; exit" @@ -479,6 +490,7 @@ odd 41 } test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} { set child [open |[list [interpreter]] r+] + puts $child "catch {load $::tcltestlib Tcltest}" puts $child "testexithandler create 41; testexithandler delete 41" puts $child "testexithandler create 16; exit" flush $child diff --git a/tests/execute.test b/tests/execute.test index 012b3a7..94af158 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -19,6 +19,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset x} diff --git a/tests/expr-old.test b/tests/expr-old.test index c05a925..4f3cb2e 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] diff --git a/tests/expr.test b/tests/expr.test index 6679569..6ad7208 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testmathfunctions [expr { ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"}) }] diff --git a/tests/fCmd.test b/tests/fCmd.test index 72b7da9..325b374 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] diff --git a/tests/fileName.test b/tests/fileName.test index 251f12c..19503f8 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] testConstraint linkDirectory 1 diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 9950dde..9469af0 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -19,6 +19,17 @@ namespace eval ::tcl::test::fileSystem { file delete -force [file join dir.dir linkinside.file] } +testConstraint loaddll 0 +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::ddever [package require dde] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1] + set ::regver [package require registry] + set ::reglib [lindex [package ifneeded registry $::regver] 1] + testConstraint loaddll 0 +} + # Test for commands defined in Tcltest executable testConstraint testfilesystem [llength [info commands ::testfilesystem]] testConstraint testsetplatform [llength [info commands ::testsetplatform]] @@ -305,7 +316,7 @@ test filesystem-1.39 {file normalisation with volume relative} -setup { file norm [string range $drv 0 1] } -cleanup { cd $old -} -match glob -result {*[^/]} +} -match regexp -result {.*[^/]} test filesystem-1.40 {file normalisation with repeated separators} { testPathEqual [file norm foo////bar] [file norm foo/bar] } ok @@ -501,13 +512,12 @@ if {[testConstraint testfilesystem]} { test filesystem-7.1.1 {load from vfs} -setup { set dir [pwd] -} -constraints {win testsimplefilesystem} -body { +} -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname [info nameof]] - set dde [lindex [glob *dde*[info sharedlib]] 0] + cd [file dirname $::reglib] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation - load simplefs:/$dde dde + load simplefs:/[file tail $::ddelib] dde testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. @@ -516,14 +526,13 @@ test filesystem-7.1.1 {load from vfs} -setup { } -result ok test filesystem-7.1.2 {load from vfs, and then unload again} -setup { set dir [pwd] -} -constraints {win testsimplefilesystem} -body { +} -constraints {win testsimplefilesystem loaddll} -body { # This may cause a crash on exit - cd [file dirname [info nameof]] - set reg [lindex [glob tclreg*[info sharedlib]] 0] + cd [file dirname $::reglib] testsimplefilesystem 1 # This loads reg via a complex copy-to-temp operation - load simplefs:/$reg Registry - unload simplefs:/$reg + load simplefs:/[file tail $::reglib] Registry + unload simplefs:/[file tail $::reglib] testsimplefilesystem 0 return ok # The real result of this test is what happens when Tcl exits. diff --git a/tests/get.test b/tests/get.test index 40ec98f..d51ec6d 100644 --- a/tests/get.test +++ b/tests/get.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testgetint [llength [info commands testgetint]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] diff --git a/tests/indexObj.test b/tests/indexObj.test index 479cc3b..646cb02 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testparseargs [llength [info commands testparseargs]] diff --git a/tests/info.test b/tests/info.test index 3323281..7dd63b7 100644 --- a/tests/info.test +++ b/tests/info.test @@ -20,6 +20,9 @@ if {{::tcltest} ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -231,7 +234,6 @@ test info-6.11 {info default option} { } } {0 {} 1 27} - test info-7.1 {info exists option} -body { set value foo info exists value @@ -731,8 +733,6 @@ proc etrace {} { return $res } -## - test info-22.0 {info frame, levels} {!singleTestInterp} { info frame } 7 @@ -763,7 +763,7 @@ test info-22.7 {info frame, global, absolute} {!singleTestInterp} { } {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} test info-22.8 {info frame, basic trace} -match glob -body { join [lrange [etrace] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} unset -nocomplain msg @@ -803,7 +803,7 @@ test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body { test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body { set script {etrace} join [lrange [eval $script] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}} @@ -1318,7 +1318,7 @@ test info-37.0 {eval pure list, single line} -match glob -body { }] eval $cmd return $res -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 2 cmd etrace proc ::tcltest::RunTest} * {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c} @@ -1359,7 +1359,7 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b etrace } join [lrange [uplevel \#0 $script] 0 2] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::tcltest::RunTest} * {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} @@ -1378,7 +1378,7 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g etrace } join [lrange [control y $script] 0 3] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} @@ -1395,7 +1395,7 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { join [lrange [datav] 0 4] \n -} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} * {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} * {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} @@ -1412,7 +1412,7 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo testConstraint testevalex [llength [info commands testevalex]] test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n -} -result {* {type source line 728 file info.test cmd {info frame \$level} proc ::etrace level 0} +} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} * {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} diff --git a/tests/interp.test b/tests/interp.test index ab91f77..0af9887 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -15,6 +15,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testinterpdelete [llength [info commands testinterpdelete]] set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} diff --git a/tests/io.test b/tests/io.test index f3c39f4..9621138 100644 --- a/tests/io.test +++ b/tests/io.test @@ -17,6 +17,10 @@ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + namespace eval ::tcl::test::io { namespace import ::tcltest::* diff --git a/tests/ioCmd.test b/tests/ioCmd.test index cf913ff..5eb0206 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Custom constraints used in this file testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 7da4329..db9a2cb 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}] diff --git a/tests/iogt.test b/tests/iogt.test index 60d7ab8..d4c31d2 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -14,6 +14,10 @@ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + namespace eval ::tcl::test::iogt { namespace import ::tcltest::* diff --git a/tests/lindex.test b/tests/lindex.test index 07abff8..b86e2e0 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + set minus - testConstraint testevalex [llength [info commands testevalex]] diff --git a/tests/link.test b/tests/link.test index 60d0799..00e490c 100644 --- a/tests/link.test +++ b/tests/link.test @@ -16,6 +16,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testlink [llength [info commands testlink]] foreach i {int real bool string} { diff --git a/tests/listObj.test b/tests/listObj.test index 53017b1..8b24aa9 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testobj [llength [info commands testobj]] catch {unset x} diff --git a/tests/load.test b/tests/load.test index b7c1a59..78bf64c 100644 --- a/tests/load.test +++ b/tests/load.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Figure out what extension is used for shared libraries on this # platform. if {![info exists ext]} { @@ -197,7 +200,7 @@ test load-9.1 {Tcl_StaticPackage, load already-loaded package into another inter [child1 eval { info loaded {} }] \ [child2 eval { info loaded {} }] } \ - -result {{{{} Loadninepointone} {{} Tcltest}} {{{} Loadninepointone} {{} Tcltest}}} \ + -match glob -result {{{{} Loadninepointone} {* Tcltest}} {{{} Loadninepointone} {* Tcltest}}} \ -cleanup { interp delete child1 ; interp delete child2 } test load-10.1 {load from vfs} \ diff --git a/tests/lset.test b/tests/lset.test index 3f4914d..1c1300b 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + proc failTrace {name1 name2 op} { error "trace failed" } diff --git a/tests/misc.test b/tests/misc.test index fe19ebe..6ddc718 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] test misc-1.1 {error in variable ref. in command in array reference} { diff --git a/tests/namespace.test b/tests/namespace.test index f07d8cf..1d46bf0 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -16,6 +16,9 @@ package require tcltest 2 namespace import -force ::tcltest::* testConstraint memory [llength [info commands memory]] +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # # REMARK: the tests for 'namespace upvar' are not done here. They are to be # found in the file 'upvar.test'. diff --git a/tests/notify.test b/tests/notify.test index ba52c50..d2b9123 100755 --- a/tests/notify.test +++ b/tests/notify.test @@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testevent [llength [info commands testevent]] test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \ diff --git a/tests/nre.test b/tests/nre.test index 295f02e..b8ef2e0 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testnrelevels [llength [info commands testnrelevels]] # diff --git a/tests/obj.test b/tests/obj.test index 126d5ca..71a39b4 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] diff --git a/tests/parse.test b/tests/parse.test index 3523975..0f76d64 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -16,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} { namespace eval ::tcl::test::parse { namespace import ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testparser [llength [info commands testparser]] testConstraint testevalobjv [llength [info commands testevalobjv]] testConstraint testevalex [llength [info commands testevalex]] diff --git a/tests/parseExpr.test b/tests/parseExpr.test index cd0342a..7910974 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Note that the Tcl expression parser (tclCompExpr.c) does not check # the semantic validity of the expressions it parses. It does not check, # for example, that a math function actually exists, or that the operands diff --git a/tests/parseOld.test b/tests/parseOld.test index 132481c..0edcbf0 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -18,6 +18,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testwordend [llength [info commands testwordend]] # Save the argv value for restoration later diff --git a/tests/platform.test b/tests/platform.test index 92ca7ab..aab7c78 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testCPUID [llength [info commands testcpuid]] test platform-1.1 {TclpSetVariables: tcl_platform} { diff --git a/tests/reg.test b/tests/reg.test index abfc9ca..a0ea850 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # All tests require the testregexp command, return if this # command doesn't exist diff --git a/tests/registry.test b/tests/registry.test index 400277f..77588e3 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -17,13 +17,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint reg 0 if {[testConstraint win]} { - catch { - # Is the registry extension already static to this shell? - if [catch {load {} Registry; set ::reglib {}}] { - # try the location given to use on the commandline to tcltest + if {![catch { ::tcltest::loadTestedCommands - load $::reglib Registry - } + set ::regver [package require registry 1.3.0] + }]} { testConstraint reg 1 } } @@ -34,6 +31,9 @@ testConstraint english [expr { && [string match "English*" [testlocale all ""]] }] +test registry-1.0 {check if we are testing the right dll} {win reg} { + set ::regver +} {1.3.0} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} @@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly} { +test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar diff --git a/tests/rename.test b/tests/rename.test index 9ac49b4..1fa0441 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testdel [llength [info commands testdel]] # Must eliminate the "unknown" command while the test is running, especially diff --git a/tests/resolver.test b/tests/resolver.test index bb9f59d..e73ea50 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -15,6 +15,9 @@ if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testinterpresolver [llength [info commands testinterpresolver]] test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup { diff --git a/tests/result.test b/tests/result.test index f080654..3391ce1 100644 --- a/tests/result.test +++ b/tests/result.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Some tests require the testsaveresult command testConstraint testsaveresult [llength [info commands testsaveresult]] diff --git a/tests/set.test b/tests/set.test index 9e0ddc0..1d88553 100644 --- a/tests/set.test +++ b/tests/set.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testset2 [llength [info commands testset2]] catch {unset x} diff --git a/tests/string.test b/tests/string.test index b3326ae..8cacd07 100644 --- a/tests/string.test +++ b/tests/string.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] diff --git a/tests/stringComp.test b/tests/stringComp.test index ff18819..56fb69d 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -20,6 +20,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] diff --git a/tests/stringObj.test b/tests/stringObj.test index d93bb82..6f331d3 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testobj [llength [info commands testobj]] testConstraint testdstring [llength [info commands testdstring]] diff --git a/tests/tailcall.test b/tests/tailcall.test index e9ec188..2d04f82 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testnrelevels [llength [info commands testnrelevels]] # diff --git a/tests/thread.test b/tests/thread.test index 44789fa..f2735da 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Some tests require the testthread command testConstraint testthread [expr {[info commands testthread] != {}}] diff --git a/tests/trace.test b/tests/trace.test index 693dbad..0f48dcf 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index e8148e9..2453e01 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testchmod [llength [info commands testchmod]] # These tests really need to be run from a writable directory, which diff --git a/tests/unixFile.test b/tests/unixFile.test index 0ea0ec1..8147f48 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -14,6 +14,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testfindexecutable [llength [info commands testfindexecutable]] set oldpwd [pwd] diff --git a/tests/unload.test b/tests/unload.test index a103cc5..5a374c4 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Figure out what extension is used for shared libraries on this # platform. if {![info exists ext]} { diff --git a/tests/upvar.test b/tests/upvar.test index cd78c31..e2c9ffd 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -16,6 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testupvar [llength [info commands testupvar]] test upvar-1.1 {reading variables with upvar} { diff --git a/tests/utf.test b/tests/utf.test index fcd2a73..c41cfe3 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -13,6 +13,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + catch {unset x} test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { diff --git a/tests/util.test b/tests/util.test index 1da533c..0e50483 100644 --- a/tests/util.test +++ b/tests/util.test @@ -12,6 +12,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint controversialNaN 1 testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] diff --git a/tests/var.test b/tests/var.test index f2923de..ed7e930 100644 --- a/tests/var.test +++ b/tests/var.test @@ -19,6 +19,9 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] testConstraint testsetnoerr [llength [info commands testsetnoerr]] diff --git a/tests/winDde.test b/tests/winDde.test index 83f3598..9e0b20a 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -15,16 +15,14 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -if [catch { - # Is the dde extension already static to this shell? - if [catch {load {} Dde; set ::ddelib {}}] { - # try the location given to use on the commandline to tcltest - ::tcltest::loadTestedCommands - load $::ddelib Dde +testConstraint dde 0 +if {[testConstraint win]} { + if {![catch { + ::tcltest::loadTestedCommands + set ::ddever [package require dde 1.4.0b1] + set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { + testConstraint dde 1 } - testConstraint dde 1 -}] { - testConstraint dde 0 } @@ -39,9 +37,7 @@ proc createChildProcess {ddeServerName args} { set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] - if {$::ddelib != ""} { - puts $f [list load $::ddelib Dde] - } + puts $f [list load $::ddelib dde] puts $f { # DDE child server - # @@ -105,6 +101,9 @@ proc createChildProcess {ddeServerName args} { } # ------------------------------------------------------------------------- +test winDde-1.0 {check if we are testing the right dll} {win dde} { + set ::ddever +} {1.4.0b1} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] diff --git a/tests/winFCmd.test b/tests/winFCmd.test index b49356d..28a0e9f 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + # Initialise the test constraints testConstraint winVista 0 diff --git a/tests/winFile.test b/tests/winFile.test index ad34624..fba9bcb 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -16,6 +16,9 @@ if {[catch {package require tcltest 2.0.2}]} { } namespace import -force ::tcltest::* +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 testConstraint win2000 0 diff --git a/tests/winNotify.test b/tests/winNotify.test index f9c75a3..3e9aa29 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testeventloop [expr {[info commands testeventloop] != {}}] # There is no explicit test for InitNotifier or NotifierExitHandler diff --git a/tests/winPipe.test b/tests/winPipe.test index 62d7d0d..d2e804d 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -16,6 +16,12 @@ package require tcltest namespace import -force ::tcltest::* unset -nocomplain path +catch { + ::tcltest::loadTestedCommands + package require -exact Tcltest [info patchlevel] + set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] +} + set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] @@ -23,6 +29,8 @@ testConstraint exec [llength [info commands exec]] testConstraint cat32 [file exists $cat32] testConstraint AllocConsole [catch {puts console1 ""}] testConstraint RealConsole [expr {![testConstraint AllocConsole]}] +testConstraint testexcept [llength [info commands testexcept]] + set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big @@ -190,30 +198,34 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { vwait x list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" -test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec} { +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept float_underflow" set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGFPE} -test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec} { +test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept access_violation" set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGSEGV} -test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec} { +test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept illegal_instruction" set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] } {1 1 SIGILL} -test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec} { +test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {win exec testexcept} { set f [open "|[list [interpreter]]" w+] set pid [pid $f] + puts $f "load $::tcltestlib Tcltest" puts $f "testexcept ctrl+c" set status [catch {close $f}] list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] diff --git a/tests/winTime.test b/tests/winTime.test index 278db32..add8f98 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -15,6 +15,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + testConstraint testwinclock [llength [info commands testwinclock]] # The next two tests will crash on Windows if the check for negative diff --git a/unix/Makefile.in b/unix/Makefile.in index 2e47714..068cb12 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1701,7 +1701,7 @@ packages: configure-packages ${STUB_LIB_FILE} pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ echo "Building package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory; ) || exit $$?; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \ fi; \ fi; \ done @@ -1712,7 +1712,7 @@ install-packages: packages pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ echo "Installing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory install \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) install \ "DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \ fi; \ fi; \ @@ -1723,10 +1723,8 @@ test-packages: tcltest packages if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - echo ""; \ - echo ""; \ echo "Testing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) \ "@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \ "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \ "TCLLIBPATH=../../pkgs" test \ @@ -1740,7 +1738,7 @@ clean-packages: if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory clean; ) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ fi; \ fi; \ done @@ -1750,7 +1748,7 @@ distclean-packages: if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory distclean; ) \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ fi; \ rm -rf $(PKG_DIR)/$$pkg; \ fi; \ @@ -1764,7 +1762,7 @@ dist-packages: configure-packages if [ -d $$i ]; then \ pkg=`basename $$i`; \ if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) --no-print-directory dist \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \ "DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \ fi; \ fi; \ diff --git a/unix/configure.in b/unix/configure.in index 79a546d..c8f0bc6 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -220,7 +220,7 @@ AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH, 1, [Do we have realpath()])]) SC_TCL_IPV6 -#-------------------------------------------------------------------- +#-------------------------------------------------------------------- # Look for thread-safe variants of some library functions. #-------------------------------------------------------------------- @@ -398,7 +398,7 @@ AC_CHECK_TYPE([intptr_t], [ for tcl_cv_intptr_t in "int" "long" "long long" none; do if test "$tcl_cv_intptr_t" != none; then AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], + [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], [tcl_ok=yes], [tcl_ok=no]) test "$tcl_ok" = yes && break; fi done]) @@ -414,7 +414,7 @@ AC_CHECK_TYPE([uintptr_t], [ none; do if test "$tcl_cv_uintptr_t" != none; then AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], - [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], + [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], [tcl_ok=yes], [tcl_ok=no]) test "$tcl_ok" = yes && break; fi done]) @@ -681,7 +681,7 @@ AC_ARG_WITH(tzdata, # Any directories that get added here must also be added to the # search path in ::tcl::clock::Initialize (library/clock.tcl). # -case $tcl_ok in +case $tcl_ok in no) AC_MSG_RESULT([supplied by OS vendor]) ;; @@ -708,7 +708,7 @@ case $tcl_ok in fi ;; *) - AC_MSG_ERROR([invalid argument: $tcl_ok]) + AC_MSG_ERROR([invalid argument: $tcl_ok]) ;; esac if test $tcl_ok = yes @@ -782,7 +782,7 @@ TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX} eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}" # tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed -# since on some platforms TCL_LIB_FILE contains shell escapes. +# since on some platforms TCL_LIB_FILE contains shell escapes. # (See also: TCL_TRIM_DOTS). eval "TCL_LIB_FILE=${TCL_LIB_FILE}" diff --git a/unix/install-sh b/unix/install-sh index c68581d..7c34c3f 100755 --- a/unix/install-sh +++ b/unix/install-sh @@ -156,8 +156,8 @@ while test $# -ne 0; do -s) stripcmd=$stripprog;; - -S) stripcmd="$stripprog $2" - shift;; + -S) stripcmd="$stripprog $2" + shift;; -t) dst_arg=$2 shift;; diff --git a/win/Makefile.in b/win/Makefile.in index d5a335d..bb9a830 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -140,7 +140,6 @@ SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} -TCLTEST = tcltest${EXEEXT} CAT32 = cat32$(EXEEXT) MAN2TCL = man2tcl$(EXEEXT) @@ -403,7 +402,7 @@ TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc packages -tcltest: $(TCLTEST) +tcltest: $(TCLSH) $(TEST_DLL_FILE) binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH) @@ -416,11 +415,6 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) @VC_MANIFEST_EMBED_EXE@ -$(TCLTEST): testMain.$(OBJEXT) ${TEST_DLL_FILE} @LIBRARIES@ $(TCL_STUB_LIB_FILE) $(CAT32) tclsh.$(RES) - $(CC) $(CFLAGS) testMain.$(OBJEXT) ${TEST_LIB_FILE} $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) - @VC_MANIFEST_EMBED_EXE@ - cat32.$(OBJEXT): cat.c $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) @@ -719,17 +713,19 @@ install-private-headers: libraries test: test-tcl test-packages -test-tcl: binaries $(TCLTEST) +test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ - set ::reglib [file normalize ${REG_DLL_FILE}]" | ./$(CAT32) + ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ + -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.0b1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) -# Useful target to launch a built tcltest with the proper path,... -runtest: binaries $(TCLTEST) +# Useful target to launch a built tclsh with the proper path,... +runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) $(TESTFLAGS) -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ - set ::reglib [file normalize ${REG_DLL_FILE}]" $(SCRIPT) + ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.0b1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` @@ -753,7 +749,7 @@ cleanhelp: clean: cleanhelp clean-packages $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(TCLTEST) $(CAT32) + $(RM) $(TCLSH) $(CAT32) $(RM) *.pch *.ilk *.pdb distclean: distclean-packages clean @@ -24,28 +24,28 @@ In order to compile Tcl for Windows, you need the following: or - Linux + MinGW-w64 (any distribution e.g. Ubuntu) - (for either 32-bit or 64-bit executables) + Linux + MinGW-w64 [http://mingw-w64.sourceforge.net/] + (win32 or win64) or Cygwin + MinGW-w64 [http://cygwin.com/install.html] - (for either 32-bit or 64-bit executables) + (win32 or win64) or Darwin + MinGW-w64 [http://mingw-w64.sourceforge.net/] - (for either 32-bit or 64-bit executables) + (win32 or win64) or Msys + MinGW-w64 [http://mingw-w64.sourceforge.net/] - (for either 32-bit or 64-bit executables) + (win32 or win64) or - Msys + Mingw [http://www.mingw.org/download.shtml] - (32-bit executables only) + Msys + MinGW [http://www.mingw.org/download.shtml] + (win32 only) In practice, this release is built with Visual C++ 6.0 and the TEA @@ -67,20 +67,20 @@ configure/build process works just like the UNIX one, so you will want to refer to ../unix/README for available configure options. If you want 64-bit executables (x86_64), you need to configure using -the --enable-64bit option. Then make sure that the x86_64-w64-mingw32 +the --enable-64bit option. Make sure that the x86_64-w64-mingw32 compiler is present. For Cygwin this compiler can be found in the "mingw64-x86_64-gcc-core" package, which can be installed through the normal Cygwin install process. If you only want 32-bit executables, -the "mingw64-i686-gcc-core" package is what you need. If your Linux -distribution does not have a MinGW-w64 package, you can download one -from [https://sourceforge.net/projects/mingw-w64/files/] +the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin +and Msys, you can download a suitable win32 or win64 compiler from +[https://sourceforge.net/projects/mingw-w64/files/] Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is on -your path, in the system directory, or in the directory containing +Note that in order to run tclsh85.exe, you must ensure that tcl85.dll is +on your path, in the system directory, or in the directory containing tclsh86.exe. Note: Tcl no longer provides support for Win32s. diff --git a/win/configure b/win/configure index fed0959..f5a23fe 100755 --- a/win/configure +++ b/win/configure @@ -840,18 +840,18 @@ if test -n "$ac_init_help"; then Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --enable-threads build with threads - --enable-shared build and link with shared libraries --enable-shared + --enable-threads build with threads (default: on) + --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (where applicable) --enable-wince enable Win/CE support (where applicable) - --enable-symbols build with debugging symbols --disable-symbols + --enable-symbols build with debugging symbols (default: off) --enable-embedded-manifest embed manifest if possible (default: yes) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-encoding encoding for configuration values + --with-encoding encoding for configuration values --with-celib=DIR use Windows/CE support library from DIR Some influential environment variables: @@ -3068,8 +3068,8 @@ else fi; if test "$tcl_ok" = "yes"; then - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 + echo "$as_me:$LINENO: result: yes (default)" >&5 +echo "${ECHO_T}yes (default)" >&6 TCL_THREADS=1 cat >>confdefs.h <<\_ACEOF #define TCL_THREADS 1 @@ -3598,8 +3598,8 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" - extra_ldflags="$extra_ldflags -pipe" extra_cflags="$extra_cflags -pipe" + extra_ldflags="$extra_ldflags -pipe" if test "${SHARED_BUILD}" = "0" ; then # static diff --git a/win/configure.in b/win/configure.in index 2377938..d17f815 100644 --- a/win/configure.in +++ b/win/configure.in @@ -219,7 +219,7 @@ if test "$tcl_cv_intrinsics" = "yes"; then [Defined when the compilers supports intrinsics]) fi -# See if the <wspiapi.h> header file is present +# See if the <wspiapi.h> header file is present AC_CACHE_CHECK(for wspiapi.h, tcl_cv_wspiapi_h, diff --git a/win/makefile.vc b/win/makefile.vc index 5183504..6c8a5e3 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -121,7 +121,8 @@ the build instructions. # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default -# when not specified. +# when not specified. If the CPU environment variable has been +# set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR=<path> # OUT_DIR=<path> @@ -564,27 +565,27 @@ install: install-binaries install-libraries install-docs install-pkgs test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT:\=/)/../library + set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" - $(DEBUGGER) $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << - set ::ddelib [file normalize $(TCLDDELIB:\=/)] - set ::reglib [file normalize $(TCLREGLIB:\=/)] + $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << + package ifneeded dde 1.4.0b1 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.0 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... - $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - set ::ddelib [file normalize $(TCLDDELIB:\=/)] - set ::reglib [file normalize $(TCLREGLIB:\=/)] + $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log + package ifneeded dde 1.4.0b1 "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.0 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif runtest: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library + set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls - set TCL_LIBRARY=$(ROOT)/library + set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLSH) $(SCRIPT) setup: @@ -819,7 +820,6 @@ install-docs: @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" !endif -#" #--------------------------------------------------------------------- # Build tclConfig.sh for the TEA build system. #--------------------------------------------------------------------- @@ -1158,15 +1158,15 @@ install-libraries: tclConfig install-msgs install-tzdata install-tzdata: @echo Installing time zone data - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo Installing message catalogs - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- # Clean up diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b5e0788..2868857 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -14,8 +14,13 @@ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> +#define NO_SHLWAPI_GDI +#define NO_SHLWAPI_STREAM +#define NO_SHLWAPI_REG +#include <shlwapi.h> #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") +#pragma comment (lib, "shlwapi.lib") #include <stdio.h> #include <math.h> @@ -37,12 +42,13 @@ /* protos */ -int CheckForCompilerFeature(const char *option); -int CheckForLinkerFeature(const char *option); -int IsIn(const char *string, const char *substring); -int SubstituteFile(const char *substs, const char *filename); -const char * GetVersionFromFile(const char *filename, const char *match); -DWORD WINAPI ReadFromPipe(LPVOID args); +static int CheckForCompilerFeature(const char *option); +static int CheckForLinkerFeature(const char *option); +static int IsIn(const char *string, const char *substring); +static int SubstituteFile(const char *substs, const char *filename); +static int QualifyPath(const char *path); +static const char *GetVersionFromFile(const char *filename, const char *match); +static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ @@ -149,10 +155,21 @@ main( } printf("%s\n", GetVersionFromFile(argv[2], argv[3])); return 0; + case 'Q': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -Q path\n" + "Emit the fully qualified path\n" + "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return QualifyPath(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -c|-l|-f|-g|-V ...\n" + "usage: %s -c|-f|-l|-Q|-s|-V ...\n" "This is a little helper app to equalize shell differences between WinNT and\n" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); @@ -160,7 +177,7 @@ main( return 2; } -int +static int CheckForCompilerFeature( const char *option) { @@ -245,7 +262,7 @@ CheckForCompilerFeature( FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); - WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } @@ -294,7 +311,7 @@ CheckForCompilerFeature( || strstr(Err.buffer, "D2021") != NULL); } -int +static int CheckForLinkerFeature( const char *option) { @@ -373,7 +390,7 @@ CheckForLinkerFeature( FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); - WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } @@ -419,7 +436,7 @@ CheckForLinkerFeature( strstr(Err.buffer, "LNK4044") != NULL); } -DWORD WINAPI +static DWORD WINAPI ReadFromPipe( LPVOID args) { @@ -444,7 +461,7 @@ ReadFromPipe( return 0; /* makes the compiler happy */ } -int +static int IsIn( const char *string, const char *substring) @@ -459,7 +476,7 @@ IsIn( * package provide or package ifneeded. */ -const char * +static const char * GetVersionFromFile( const char *filename, const char *match) @@ -565,7 +582,7 @@ list_free(list_item_t **listPtrPtr) * << */ -int +static int SubstituteFile( const char *substitutions, const char *filename) @@ -641,6 +658,30 @@ SubstituteFile( fclose(fp); return 0; } + +/* + * QualifyPath -- + * + * This composes the current working directory with a provided path + * and returns the fully qualified and normalized path. + * Mostly needed to setup paths for testing. + */ + +static int +QualifyPath( + const char *szPath) +{ + char szCwd[MAX_PATH + 1]; + char szTmp[MAX_PATH + 1]; + char *p; + GetCurrentDirectory(MAX_PATH, szCwd); + while ((p = strchr(szPath, '/')) && *p) + *p = '\\'; + PathCombine(szTmp, szCwd, szPath); + PathCanonicalize(szCwd, szTmp); + printf("%s\n", szCwd); + return 0; +} /* * Local variables: diff --git a/win/rules.vc b/win/rules.vc index 3fbaaaf..f09e2ea 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -8,7 +8,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. -# Copyright (c) 2003-2007 Patrick Thoyts +# Copyright (c) 2003-2008 Patrick Thoyts #------------------------------------------------------------------------------ !ifndef _RULES_VC @@ -243,9 +243,9 @@ TCL_USE_STATIC_PACKAGES = 1 TCL_USE_STATIC_PACKAGES = 0 !endif !if [nmakehlp -f $(OPTS) "nothreads"] +!message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 !else -!message *** Doing threads TCL_THREADS = 1 USE_THREAD_ALLOC= 1 !endif @@ -287,7 +287,7 @@ LOIMPACT = 0 USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] -!message *** Doing thrdalloc +!message *** Doing tclalloc USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index cc696a2..f36f797 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1875,12 +1875,26 @@ PipeClose2Proc( && (pipePtr->writeFile != NULL)) { if (pipePtr->writeThread) { /* - * Wait for the writer thread to finish the current buffer, then - * terminate the thread and close the handles. If the channel is - * nonblocking, there should be no pending write operations. + * Wait for the writer thread to finish the current buffer, then + * terminate the thread and close the handles. If the channel is + * nonblocking but blocked during exit, bail out since the worker + * thread is not interruptible and we want TIP#398-fast-exit. */ + if (TclInExit() + && (pipePtr->flags & PIPE_ASYNC)) { - WaitForSingleObject(pipePtr->writable, INFINITE); + /* give it a chance to leave honorably */ + SetEvent(pipePtr->stopWriter); + + if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) { + return EAGAIN; + } + + } else { + + WaitForSingleObject(pipePtr->writable, INFINITE); + + } /* * The thread may already have closed on it's own. Check its exit @@ -2945,6 +2959,10 @@ PipeWriterThread( * an error, so exit. */ + if (waitResult == WAIT_OBJECT_0) { + SetEvent(infoPtr->writable); + } + break; } |