Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Remove dependencies between tests in env.test. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | core-8-6-branch |
Files: | files | file ages | folders |
SHA3-256: |
9e55a28229e17dbc2ab5fe3595f825ad |
User & Date: | pooryorick 2018-06-17 08:47:29 |
Context
2018-06-17
| ||
16:07 | Fix [53cad613d8]: TIP 389 implementation makes Tk tests fon... check-in: 8702869d89 user: jan.nijtmans tags: core-8-6-branch | |
08:47 | Remove dependencies between tests in env.test. check-in: 9e55a28229 user: pooryorick tags: core-8-6-branch | |
2018-06-16
| ||
22:56 | Add tests/tcltests.tcl as a place to store common code for tests. check-in: aeaf8492d3 user: pooryorick tags: core-8-6-branch | |
Changes
Changes to tests/env.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } | | | > > > > | > > | > > | | | > > > | > > > > > > | | | > | > > | | > > > > | > > > > | | | > > | > | | > > > > > | > | | < | | < | > | > > | > | | > | | < | | | > | > > > > > > | > | | | < < < < < < | | | | | | > | > | > > | > | | > > > > > > > > < > > | > > > | < < < < < < < < | > | | | < < | | < | | | | | | | | > | < | < > | < < | > > | | > > | | < | < | | < | | | | | | > < < | | < < | | < | < < < | < | | | | > | < | | | | > | < > > < < < | > | > | | | > | < | | | | > > > | > > > > | > > > > | > | | | > | > | > | > | | | | > | > > | | > > > > > > | 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 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 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 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 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 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } package require tcltests # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { global printenvScript catch {exec [interpreter] $printenvScript} out if {$out eq "child process exited abnormally"} { set out {} } return $out } proc envrestore {} { # Restore the environment variables at the end of the test. global env variable env2 foreach name [array names env] { unset env($name) } array set env $env2 return } proc envprep {} { # Save the current environment variables at the start of the test. global env variable keep variable env2 set env2 [array get env] foreach name [array names env] { # Keep some environment variables that support operation of the tcltest # package. if {[string toupper $name] ni $keep} { unset env($name) } } return } proc encodingrestore {} { variable sysenc encoding system $sysenc return } proc encodingswitch encoding { variable sysenc # Need to run [getenv] in known encoding, so save the current one here... set sysenc [encoding system] encoding system $encoding return } proc setup1 {} { global env envprep encodingswitch iso8859-1 } proc setup2 {} { global env setup1 set env(NAME1) {test string} set env(NAME2) {new value} set env(XYZZY) {garbage} } proc cleanup1 {} { encodingrestore envrestore } variable keep { TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING SECURITYSESSIONID LANG WINDIR TERM CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { encoding system iso8859-1 proc lrem {listname name} { upvar $listname list set i [lsearch -nocase $list $name] if {$i >= 0} { set list [lreplace $list $i $i] } return $list } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s return [subst -novariables $s] } proc manglechar c { return [format {\u%04x} [scan $c %c]] } set names [lsort [array names env]] if {$tcl_platform(platform) eq "windows"} { lrem names HOME lrem names COMSPEC lrem names ComSpec lrem names "" } foreach name @keep@ { lrem names $name } foreach p $names { puts [mangle $p]=[mangle $env($p)] } exit }] printenv] test env-1.1 {propagation of env values to child interpreters} -setup { catch {interp delete child} catch {unset env(test)} } -body { interp create child set env(test) garbage child eval {set env(test)} } -cleanup { interp delete child unset env(test) } -result {garbage} # This one crashed on Solaris under Tcl8.0, so we only want to make sure it # runs. test env-1.2 {lappend to env value} -setup { catch {unset env(test)} } -body { set env(test) aaaaaaaaaaaaaaaa append env(test) bbbbbbbbbbbbbb unset env(test) } test env-1.3 {reflection of env by "array names"} -setup { catch {interp delete child} catch {unset env(test)} } -body { interp create child child eval {set env(test) garbage} expr {"test" in [array names env]} } -cleanup { interp delete child catch {unset env(test)} } -result 1 test env-2.1 { adding environment variables } -constraints exec -setup setup1 -body { getenv } -cleanup cleanup1 -result {} test env-2.2 { adding environment variables } -constraints exec -setup setup1 -body { set env(NAME1) "test string" getenv } -cleanup cleanup1 -result {NAME1=test string} test env-2.3 {adding environment variables} -constraints exec -setup { setup1 set env(NAME1) "test string" } -body { set env(NAME2) "more" getenv } -cleanup cleanup1 -result {NAME1=test string NAME2=more} test env-2.4 { adding environment variables } -constraints exec -setup { setup1 set env(NAME1) "test string" set env(NAME2) "more" } -body { set env(XYZZY) "garbage" getenv } -cleanup { cleanup1 } -result {NAME1=test string NAME2=more XYZZY=garbage} test env-3.1 { changing environment variables } -constraints exec -setup setup2 -body { set result [getenv] unset env(NAME2) set result } -cleanup { cleanup1 } -result {NAME1=test string NAME2=new value XYZZY=garbage} test env-4.1 { unsetting environment variables } -constraints exec -setup setup2 -body { unset -nocomplain env(NAME2) getenv } -cleanup cleanup1 -result {NAME1=test string XYZZY=garbage} # env-4.2 is deleted test env-4.3 { setting international environment variables } -constraints exec -setup setup1 -body { set env(\ua7) \ub6 getenv } -cleanup cleanup1 -result {\u00a7=\u00b6} test env-4.4 { changing international environment variables } -constraints exec -setup setup1 -body { set env(\ua7) \ua7 getenv } -cleanup cleanup1 -result {\u00a7=\u00a7} test env-4.5 { unsetting international environment variables } -constraints exec -setup { setup1 set env(\ua7) \ua7 } -body { set env(\ub6) \ua7 unset env(\ua7) getenv } -cleanup cleanup1 -result {\u00b6=\u00a7} test env-5.0 { corner cases - set a value, it should exist } -setup setup1 -body { set env(temp) a set env(temp) } -cleanup cleanup1 -result a test env-5.1 { corner cases - remove one elem at a time } -setup setup1 -body { # When no environment variables exist, the env var will contain no # entries. The "array names" call synchs up the C-level environ array with # the Tcl level env array. Make sure an empty Tcl array is created. foreach e [array names env] { unset env($e) } array size env } -cleanup cleanup1 -result 0 test env-5.2 {corner cases - unset the env array} -setup { interp create i } -body { # Unsetting a variable in an interp detaches the C-level traces from the # Tcl "env" variable. i eval { unset env set env(THIS_SHOULDNT_EXIST) a } info exists env(THIS_SHOULDNT_EXIST) } -cleanup { interp delete i } -result {0} test env-5.3 {corner cases: unset the env in master should unset child} -setup { setup1 interp create i } -body { # Variables deleted in a master interp should be deleted in child interp # too. i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] unset env(THIS_SHOULD_EXIST) lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] } -cleanup { cleanup1 interp delete i } -result {a 1} test env-5.4 {corner cases - unset the env array} -setup { setup1 interp create i } -body { # The info exists command should be in synch with the env array. # Know Bug: 1737 i eval {set env(THIS_SHOULD_EXIST) a} set result [info exists env(THIS_SHOULD_EXIST)] lappend result [set env(THIS_SHOULD_EXIST)] lappend result [info exists env(THIS_SHOULD_EXIST)] } -cleanup { cleanup1 interp delete i } -result {1 a 1} test env-5.5 { corner cases - cannot have null entries on Windows } -constraints win -body { set env() a catch {set env()} } -cleanup cleanup1 -result 1 test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} } -cleanup cleanup1 -result 100 test env-7.1 {[219226]: whole env array should not be unset by read} -body { set n [array size env] set s [array startsearch env] while {[array anymore env $s]} { array nextelement env $s incr n -1 } array donesearch env $s return $n } -result 0 test env-7.2 { [219226]: links to env elements should not be removed by read } -setup setup1 -body { apply {{} { set ::env(test7_2) ok upvar env(test7_2) elem set ::env(PATH) return $elem }} } -cleanup cleanup1 -result ok test env-7.3 { [9b4702]: testing existence of env(some_thing) should not destroy trace } -setup setup1 -body { apply {{} { catch {unset ::env(test7_3)} proc foo args { set ::env(test7_3) ok } trace add variable ::env(not_yet_existent) write foo info exists ::env(not_yet_existent) set ::env(not_yet_existent) "Now I'm here"; return [info exists ::env(test7_3)] }} } -cleanup cleanup1 -result 1 test env-8.0 { memory usage - valgrind does not report reachable memory } -body { set res [set env(__DUMMY__) {i'm with dummy}] unset env(__DUMMY__) return $res } -result {i'm with dummy} # cleanup rename getenv {} rename envrestore {} rename envprep {} rename encodingrestore {} rename encodingswitch {} removeFile $printenvScript ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/tcltests.tcl.
1 2 3 | #! /usr/bin/env tclsh testConstraint notValgrind [expr {![testConstraint valgrind]}] | > > > > | 1 2 3 4 5 6 7 | #! /usr/bin/env tclsh # Some tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] testConstraint notValgrind [expr {![testConstraint valgrind]}] |