Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Fixed bugs 1521, 1578, 1608--tests were failing due to bad test construction and failure to use constraints. |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | core-8-1-branch-old |
Files: | files | file ages | folders |
SHA1: |
b21b17308673042af5530207c2b59eb5 |
User & Date: | hershey 1999-03-25 04:32:16.000 |
Context
1999-03-25
| ||
17:20 | defs: lint io.test: fix for bug 1580--"after 100" calls in test scripts were not waiting long ... check-in: 5c981db38c user: hershey tags: core-8-1-branch-old | |
04:32 | Fixed bugs 1521, 1578, 1608--tests were failing due to bad test construction and failure to use cons... check-in: b21b173086 user: hershey tags: core-8-1-branch-old | |
03:55 | * tests/execute.test: * generic/tclExecute.c (TclExecuteByteCode): Fixed expression code that incorr... check-in: d1a8033603 user: stanton tags: core-8-1-branch-old | |
Changes
Changes to tests/basic.test.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: basic.test,v 1.1.2.6 1999/03/25 04:32:16 hershey Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } catch {namespace delete test_ns_basic} |
︙ | ︙ | |||
39 40 41 42 43 44 45 | } } } list [interp eval test_interp {test_ns_basic::p}] \ [interp delete test_interp] } {::test_ns_basic {}} | | | | | | | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | } } } list [interp eval test_interp {test_ns_basic::p}] \ [interp delete test_interp] } {::test_ns_basic {}} test basic-2.1 {TclHideUnsafeCommands} {emptyTest} { } {} test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} { } {} test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} { } {} test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} { } {} test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} { } {} test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} { } {} test basic-8.1 {Tcl_InterpDeleted} {emptyTest} { } {} test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} { } {} test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { namespace eval test_ns_basic { |
︙ | ︙ | |||
222 223 224 225 226 227 228 | proc test_ns_basic::cmd {} { ;# proc requires that ns already exist return [namespace current] } list [test_ns_basic::cmd] \ [namespace delete test_ns_basic] } {::test_ns_basic {}} | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | proc test_ns_basic::cmd {} { ;# proc requires that ns already exist return [namespace current] } list [test_ns_basic::cmd] \ [namespace delete test_ns_basic] } {::test_ns_basic {}} test basic-16.1 {TclInvokeStringCommand} {emptyTest} { } {} test basic-17.1 {TclInvokeObjCommand} {emptyTest} { } {} test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {rename cmd ""} namespace eval test_ns_basic { proc p {} { |
︙ | ︙ | |||
292 293 294 295 296 297 298 | } } list [test_ns_basic::callP] \ [rename q test_ns_basic::p] \ [test_ns_basic::callP] } {{p in ::} {} {q in ::test_ns_basic}} | | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | } } list [test_ns_basic::callP] \ [rename q test_ns_basic::p] \ [test_ns_basic::callP] } {{p in ::} {} {q in ::test_ns_basic}} test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { } {} if {[info commands testcmdtoken] == {}} { puts "This application hasn't been compiled with the \"testcmdtoken\"" puts "command, so I can't test Tcl_GetCommandInfo." } else { test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} { |
︙ | ︙ | |||
321 322 323 324 325 326 327 | set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] list [testcmdtoken name $x] \ [rename test_ns_basic::test_ns_basic2::p q] \ [testcmdtoken name $x] } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} } | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] list [testcmdtoken name $x] \ [rename test_ns_basic::test_ns_basic2::p q] \ [testcmdtoken name $x] } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} } test basic-21.1 {Tcl_GetCommandName} {emptyTest} { } {} test basic-22.1 {Tcl_GetCommandFullName} { catch {eval namespace delete [namespace children :: test_ns_*]} namespace eval test_ns_basic1 { namespace export cmd* proc cmd1 {} {} |
︙ | ︙ | |||
347 348 349 350 351 352 353 | [namespace which -command q] \ [namespace which -command p] \ [namespace which -command cmd1] \ [namespace which -command ::test_ns_basic2::cmd2] } } {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} | | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 | [namespace which -command q] \ [namespace which -command p] \ [namespace which -command cmd1] \ [namespace which -command ::test_ns_basic2::cmd2] } } {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { } {} test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { catch {interp delete test_interp} catch {unset x} interp create test_interp interp eval test_interp { |
︙ | ︙ | |||
408 409 410 411 412 413 414 | list [test_ns_basic2::callP] \ [info commands test_ns_basic2::*] \ [rename test_ns_basic::p ""] \ [catch {test_ns_basic2::callP} msg] $msg \ [info commands test_ns_basic2::*] } {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} | | | | | | | | | | | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 | list [test_ns_basic2::callP] \ [info commands test_ns_basic2::*] \ [rename test_ns_basic::p ""] \ [catch {test_ns_basic2::callP} msg] $msg \ [info commands test_ns_basic2::*] } {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} test basic-25.1 {TclCleanupCommand} {emptyTest} { } {} test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} { # If object isn't preserved, errorInfo would be set to # "foo\n while executing\n\"garbage bytes\"" because the object's # string would have been freed, leaving garbage bytes for the error # message. proc bgerror {args} {set ::x $::errorInfo} set f [open test1 w] fileevent $f writable "fileevent $f writable {}; error foo" set x {} vwait x close $f file delete test1 rename bgerror {} set x } "foo\n while executing\n\"error foo\"" test basic-27.1 {Tcl_ExprLong} {emptyTest} { } {} test basic-28.1 {Tcl_ExprDouble} {emptyTest} { } {} test basic-29.1 {Tcl_ExprBoolean} {emptyTest} { } {} test basic-30.1 {Tcl_ExprLongObj} {emptyTest} { } {} test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} { } {} test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} { } {} test basic-33.1 {TclInvoke} {emptyTest} { } {} test basic-34.1 {TclGlobalInvoke} {emptyTest} { } {} test basic-35.1 {TclObjInvokeGlobal} {emptyTest} { } {} test basic-36.1 {TclObjInvoke, lookup of "unknown" command} { catch {eval namespace delete [namespace children :: test_ns_*]} catch {interp delete test_interp} interp create test_interp interp eval test_interp { |
︙ | ︙ | |||
474 475 476 477 478 479 480 | } } list [interp alias test_interp newAlias test_interp doesntExist] \ [catch {interp eval test_interp {newAlias}} msg] $msg \ [interp delete test_interp] } {newAlias 0 {global unknown} {}} | | | | | | | | | | | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | } } list [interp alias test_interp newAlias test_interp doesntExist] \ [catch {interp eval test_interp {newAlias}} msg] $msg \ [interp delete test_interp] } {newAlias 0 {global unknown} {}} test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} { } {} test basic-38.1 {Tcl_ExprObj} {emptyTest} { } {} if {[info commands testcmdtrace] == {}} { puts "This application hasn't been compiled with the \"testcmdtrace\"" puts "command, so I can't test Tcl_CreateTrace." } else { test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace tracetest {set stuff [expr 14 + 16]} } {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace tracetest {set stuff [info tclversion]} } {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.1}} test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} { testcmdtrace deletetest {set stuff [info tclversion]} } 8.1 } test basic-40.1 {Tcl_DeleteTrace} {emptyTest} { } {} test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} { } {} test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} { } {} test basic-43.1 {Tcl_VarEval} {emptyTest} { } {} test basic-44.1 {Tcl_GlobalEval} {emptyTest} { } {} test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} { } {} test basic-46.1 {Tcl_AllowExceptions} {emptyTest} { } {} # cleanup catch {eval namespace delete [namespace children :: test_ns_*]} catch {namespace delete george} catch {interp delete test_interp} catch {rename p ""} |
︙ | ︙ |
Changes to tests/io.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: io.test,v 1.1.2.11 1999/03/25 04:32:17 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } if {"[info commands testchannel]" != "testchannel"} { puts "Skipping io tests. This application does not seem to have the" |
︙ | ︙ | |||
62 63 64 65 66 67 68 | vwait forever } cat set thisScript [file join $::tcltest::testsDir [info script]] # These tests are disabled until we decide what to do with "unsupported0". # | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | vwait forever } cat set thisScript [file join $::tcltest::testsDir [info script]] # These tests are disabled until we decide what to do with "unsupported0". # test io-1.1 {unsupported0 command} {knownBug} { removeFile test1 set f1 [open iocmd.test] set f2 [open test1 w] unsupported0 $f1 $f2 close $f1 catch {close $f2} set s1 [file size $thisScript] set s2 [file size test1] set x ok if {"$s1" != "$s2"} { set x broken } set x } ok test io-1.2 {unsupported0 command} {knownBug} { removeFile test1 set f1 [open $thisScript] set f2 [open test1 w] unsupported0 $f1 $f2 40 close $f1 close $f2 file size test1 } 40 test io-1.3 {unsupported0 command} {knownBug} { removeFile test1 set f1 [open $thisScript] set f2 [open test1 w] unsupported0 $f1 $f2 -1 close $f1 close $f2 set x ok set s1 [file size $thisScript] set s2 [file size test1] if {$s1 != $s2} { set x broken } set x } ok test io-1.4 {unsupported0 command} {knownBug unixOrPc} { removeFile pipe removeFile test1 set f1 [open pipe w] puts $f1 {puts ready} puts $f1 {gets stdin} puts $f1 {set f1 [open $thisScript r]} puts $f1 {puts [read $f1 100]} puts $f1 {close $f1} close $f1 set f1 [open "|[list $tcltest pipe]" r+] gets $f1 puts $f1 ready flush $f1 set f2 [open test1 w] set c [unsupported0 $f1 $f2 40] catch {close $f1} close $f2 set s1 [file size test1] set x ok if {$s1 != "40"} { set x broken } list $c $x } {40 ok} proc contents {file} { set f [open $file] fconfigure $f -translation binary set a [read $f] close $f return $a } test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { # no test, need to cause an async error. } {} test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open test1 w] fconfigure $f -encoding binary puts -nonewline $f "a\u4e4d\0" close $f |
︙ | ︙ | |||
6404 6405 6406 6407 6408 6409 6410 | set result } {0 0 ok} test io-52.8 {TclCopyChannel} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] fconfigure $f1 -translation lf | | | | | | | | 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 | set result } {0 0 ok} test io-52.8 {TclCopyChannel} {stdio} { removeFile test1 removeFile pipe set f1 [open pipe w] fconfigure $f1 -translation lf puts $f1 [subst { puts ready gets stdin set f1 \[open $thisScript r\] fconfigure \$f1 -translation lf puts \[read \$f1 100\] close \$f1 }] close $f1 set f1 [open "|[list $tcltest pipe]" r+] fconfigure $f1 -translation lf gets $f1 puts $f1 ready flush $f1 set f2 [open test1 w] |
︙ | ︙ |
Changes to tests/pkgMkIndex.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # # RCS: @(#) $Id: pkgMkIndex.test,v 1.4.2.7 1999/03/25 04:32:18 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } # temporarily copy the pkg and pkg1 dirs from testsDir to tmpDir if {"$::tcltest::testsDir" != "$::tcltest::workingDir"} { |
︙ | ︙ | |||
325 326 327 328 329 330 331 | } "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl] source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}" test pkgMkIndex-9.1 {circular packages} { pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl } {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}} | | | > > | | | > | | | | | < < < | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 | } "0 {{pkg2:1.0 {source [file join pkg pkg2_a.tcl] source [file join pkg pkg2_b.tcl]}} {pkg5:1.0 {source [file join pkg pkg5.tcl]}}}" test pkgMkIndex-9.1 {circular packages} { pkgtest::runIndex pkg circ1.tcl circ2.tcl circ3.tcl } {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}} # Some tests require the existence of one of the DLLs in the dltest directory set x [file join $::tcltest::testsDir \ ../unix/dltest/pkga[info sharedlibextension]] set dll "[file tail $x]Required" set ::tcltest::testConfig($dll) [file exists $x] test pkgMkIndex-10.1 {package in DLL and script} $dll { file copy -force $x pkg pkgtest::runIndex pkg pkga[info sharedlibextension] pkga.tcl } "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} $dll { pkgtest::runIndex -load Pkg* -- pkg pkga[info sharedlibextension] } {0 {}} # cleanup namespace delete pkgtest cd $::tcltest::workingDir if {[info exists removePkgDir]} { # strange error deleting the pkg dir only once--needs be done twice! catch {file delete -force $newPkgDir} |
︙ | ︙ |
Changes to tests/unixFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the tclUnixFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This file tests the tclUnixFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: unixFCmd.test,v 1.1.2.7 1999/03/25 04:32:18 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } # Several tests require need to match results against the unix username set user {} |
︙ | ︙ | |||
68 69 70 71 72 73 74 | list [catch {file rename td2 td1} msg] $msg } {1 {error renaming "td2" to "td1/td2": file already exists}} test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} { cleanup file mkdir td1 list [catch {file rename td1 td1} msg] $msg } {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} | | | > | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | list [catch {file rename td2 td1} msg] $msg } {1 {error renaming "td2" to "td1/td2": file already exists}} test unixFCmd-1.3 {TclpRenameFile: EINVAL} {unixOnly notRoot} { cleanup file mkdir td1 list [catch {file rename td1 td1} msg] $msg } {1 {error renaming "td1" to "td1/td1": trying to rename a volume or move a directory into itself}} test unixFCmd-1.4 {TclpRenameFile: EISDIR} {emptyTest unixOnly notRoot} { # can't make it happen } {} test unixFCmd-1.5 {TclpRenameFile: ENOENT} {unixOnly notRoot} { cleanup file mkdir td1 list [catch {file rename td2 td1} msg] $msg } {1 {error renaming "td2": no such file or directory}} test unixFCmd-1.6 {TclpRenameFile: ENOTDIR} {emptyTest unixOnly notRoot} { # can't make it happen } {} test unixFCmd-1.7 {TclpRenameFile: EXDEV} {unixOnly notRoot} { cleanup file mkdir foo/bar file attr foo -perm 040555 set catchResult [catch {file rename foo/bar /tmp} msg] set msg [lindex [split $msg :] end] catch {file delete /tmp/bar} catch {file attr foo -perm 040777} catch {file delete -force foo} list $catchResult $msg } {1 { permission denied}} test unixFCmd-1.8 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { testalarm after 2000 list [testgotsig] [testgotsig] } {1 0} test unixFCmd-1.9 {Checking EINTR Bug} {unixOnly notRoot nonPortable} { cleanup |
︙ | ︙ |
Changes to tests/unixInit.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # The file tests the functions in the tclUnixInit.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > > > > > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | # The file tests the functions in the tclUnixInit.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: unixInit.test,v 1.1.2.7 1999/03/25 04:32:19 hershey Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { source [file join [pwd] [file dirname [info script]] defs.tcl] } if {[catch {csh -c "setenv LANG japanese"}] == 0} { set ::tcltest::testConfig(japanese) 1 } catch {set oldlibrary $env(TCL_LIBRARY); unset env(TCL_LIBRARY)} catch {set oldlang $env(LANG)} set env(LANG) C # Some tests will fail if they are run on a machine that doesn't have # this Tcl version installed (as opposed to built) on it. if {[catch { set f [open "|[list $tcltest]" w+] exec kill -PIPE [pid $f] close $f }]} { set ::tcltest::testConfig(installedTcl) 0 } else { set ::tcltest::testConfig(installedTcl) 1 } test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} { set x {} set f [open "|[list $tcltest]" w+] exec kill -PIPE [pid $f] lappend x [catch {close $f}] set f [open "|[list $tcltest]" w+] |
︙ | ︙ | |||
43 44 45 46 47 48 49 | fconfigure $f -buffering none puts $f {puts $tcl_libPath; exit} set path [gets $f] close $f return $path } | > > > > > | > | > | | > | > | > | | | > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 | fconfigure $f -buffering none puts $f {puts $tcl_libPath; exit} set path [gets $f] close $f return $path } # Some tests require the testgetdefenc command set ::tcltest::testConfig(testgetdefenc) \ [expr {[info commands testgetdefenc] != {}}] test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \ {unixOnly testgetdefenc} { set origDir [testgetdefenc] testsetdefenc slappy set path [testgetdefenc] testsetdefenc $origDir set path } {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \ {unixOnly installedTcl} { set path [getlibpath] set installLib lib/tcl[info tclversion] if {[string match {*[ab]*} [info patchlevel]]} { set developLib tcl[info patchlevel]/library } else { set developLib tcl[info tclversion]/library } set prefix [file dirname [file dirname $tcltest]] set x {} lappend x [string compare [lindex $path 0] $prefix/$installLib] lappend x [string compare [lindex $path 1] [file dirname $prefix]/$developLib] set x } {0 0} test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly installedTcl} { # ((str != NULL) && (str[0] != '\0')) set env(TCL_LIBRARY) sparkly set path [getlibpath] unset env(TCL_LIBRARY) lindex $path 0 } "sparkly" test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \ {unixOnly installedTcl} { # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) set env(TCL_LIBRARY) /a/b/tcl1.7 set path [getlibpath] unset env(TCL_LIBRARY) lrange $path 0 1 } [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \ {unixOnly installedTcl} { # Child process translates env variable from native encoding. set env(TCL_LIBRARY) "\xa7" set x [lindex [getlibpath] 0] unset env(TCL_LIBRARY) unset env(LANG) set x } "\xa7" test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \ {emptyTest unixOnly} { # cannot test } {} test unixInit-2.6 {TclpInitLibraryPath: executable relative} \ {unixOnly installedTcl} { file delete -force /tmp/sparkly file mkdir /tmp/sparkly/bin file copy $tcltest /tmp/sparkly/bin/tcltest file mkdir /tmp/sparkly/lib/tcl[info tclversion] close [open /tmp/sparkly/lib/tcl[info tclversion]/init.tcl w] set x [lrange [getlibpath /tmp/sparkly/bin/tcltest] 0 1] file delete -force /tmp/sparkly set x } [list /tmp/sparkly/lib/tcl[info tclversion] /tmp/tcl[info patchlevel]/library] test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \ {emptyTest unixOnly} { # would need test command to get defaultLibDir and compare it to # [lindex $auto_path end] } {} test unixInit-3.1 {TclpSetInitialEncodings} {unixOnly installedTcl} { set env(LANG) C set f [open "|[list $tcltest]" w+] fconfigure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f unset env(LANG) set enc } {iso8859-1} test unixInit-3.1 {TclpSetInitialEncodings} \ {unixOnly japanese installedTcl nonPortable} { set env(LANG) japanese set f [open "|[list $tcltest]" w+] fconfigure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f |
︙ | ︙ |