Tcl Source Code

Check-in [92c4bfbe32]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge fix-1613456fff, closes [1613456fffffffff] and [27b682284974d0cd]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-5-branch
Files: files | file ages | folders
SHA3-256: 92c4bfbe327e9a9636bfb5faa519a75e2d17f049a7f20cbd0dd15e58489d10bf
User & Date: sebres 2018-04-30 11:10:14
Context
2018-04-30
12:11
Contain platform-specific things in the constraint-controlled parts of the test. check-in: 74af01d8ff user: dgp tags: core-8-5-branch
11:36
merge core-8-5-branch (fix-1613456fff) check-in: 0eb9289e85 user: sebres tags: core-8-6-branch
11:10
merge fix-1613456fff, closes [1613456fffffffff] and [27b682284974d0cd] check-in: 92c4bfbe32 user: sebres tags: core-8-5-branch
2018-04-19
01:39
An [array set] from a dict can only take shortcuts when the dict is "pure", that is, has no string r... check-in: 7ad9a0d2cb user: dgp tags: core-8-5-branch
2018-04-11
11:28
win: some test-cases missing constraint for testexcept (if compiled without test) Closed-Leaf check-in: eb6c47f3cb user: sebres tags: fix-1613456fff
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclFCmd.c.

369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
...
412
413
414
415
416
417
418






419

420
421
422
423
424
425
426
427
428
429
430
431
432
	}

	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
	    /*
	     * Trying to delete a file that does not exist is not considered
	     * an error, just a no-op
	     */

	    if (errno != ENOENT) {
		result = TCL_ERROR;
	    }
	} else if (S_ISDIR(statBuf.st_mode)) {
	    /*
	     * We own a reference count on errorBuffer, if it was set as a
	     * result of this call.
	     */

	    result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
................................................................................
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(objv[i]);
	}

	if (result != TCL_OK) {






	    result = TCL_ERROR;


	    /*
	     * It is important that we break on error, otherwise we might end
	     * up owning reference counts on numerous errorBuffers.
	     */

	    break;
	}
    }
    if (result != TCL_OK) {
	if (errfile == NULL) {
	    /*
	     * We try to accomodate poor error results from our Tcl_FS calls.






<
<
<
<
<
<
|
<







 







>
>
>
>
>
>
|
>
|




|







369
370
371
372
373
374
375






376

377
378
379
380
381
382
383
...
405
406
407
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
	}

	/*
	 * Call lstat() to get info so can delete symbolic link itself.
	 */

	if (Tcl_FSLstat(objv[i], &statBuf) != 0) {






	    result = TCL_ERROR;

	} else if (S_ISDIR(statBuf.st_mode)) {
	    /*
	     * We own a reference count on errorBuffer, if it was set as a
	     * result of this call.
	     */

	    result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
................................................................................
		}
	    }
	} else {
	    result = Tcl_FSDeleteFile(objv[i]);
	}

	if (result != TCL_OK) {

	    /*
	     * Avoid possible race condition (file/directory deleted after call
	     * of lstat), so bypass ENOENT because not an error, just a no-op
	     */
	    if (errno == ENOENT) {
		result = TCL_OK;
		continue;
	    }
	    /*
	     * It is important that we break on error, otherwise we might end
	     * up owning reference counts on numerous errorBuffers.
	     */
	    result = TCL_ERROR;
	    break;
	}
    }
    if (result != TCL_OK) {
	if (errfile == NULL) {
	    /*
	     * We try to accomodate poor error results from our Tcl_FS calls.

Changes to tests/fileName.test.

766
767
768
769
770
771
772

773
774
775
776
777
778
779
...
936
937
938
939
940
941
942
943
944
945
946
947


948
949
950
951
952
953
954
....
1063
1064
1065
1066
1067
1068
1069
1070


1071
1072
1073
1074
1075
1076
1077
....
1105
1106
1107
1108
1109
1110
1111

1112
1113
1114
1115
1116
1117
1118
1119
1120
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.16 {Tcl_GlobCmd} {
    list [catch {glob globTest} msg] $msg
} {0 globTest}

set globname "globTest"
set horribleglobname "glob\[\{Test"


test filename-11.17 {Tcl_GlobCmd} {unix} {
    list [catch {lsort [glob -directory $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
	[file join $globname a3]\
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
................................................................................
    set res [list [catch {lsort [glob -path {[tcl]} *]} msg] $msg]
    file delete -force {[tcl].testremains}
    set res
} [list 0 {{[tcl].testremains}}]

# Get rid of file/dir if it exists, since it will have
# been left behind by a previous failed run.
if {[file exists $horribleglobname]} {
    file delete -force $horribleglobname
}
file rename globTest $horribleglobname
set globname $horribleglobname



test filename-11.22 {Tcl_GlobCmd} {unix} {
    list [catch {lsort [glob -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
	[file join $globname a3]\
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
................................................................................
} {1}
test filename-11.41 {Tcl_GlobCmd} {
    expr {[glob -dir [pwd] -tails *] != [glob -dir [pwd] *]}
} {1}
test filename-11.42 {Tcl_GlobCmd} {
    set res [list]
    foreach f [glob -dir [pwd] *] {
	lappend res [file tail $f]


    }
    expr {$res == [glob *]}
} {1}
test filename-11.43 {Tcl_GlobCmd} {
    list [catch {glob -t *} msg] $msg
} {1 {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
test filename-11.44 {Tcl_GlobCmd} {
................................................................................
    list [catch {glob -types abcde -dir foo -join * *} msg] $msg
} {1 {bad argument to "-types": abcde}}
test filename-11.49 {Tcl_GlobCmd} {
    list [catch {glob -types abcde -path foo -join * *} msg] $msg
} {1 {bad argument to "-types": abcde}}

file rename $horribleglobname globTest

set globname globTest
unset horribleglobname

test filename-12.1 {simple globbing} {unixOrPc} {
    list [catch {glob {}} msg] $msg
} {0 .}
test filename-12.1.1 {simple globbing} {unixOrPc} {
    list [catch {glob -types f {}} msg] $msg
} {1 {no files matched glob pattern ""}}






>







 







<
|
<


>
>







 







|
>
>







 







>

|







766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
...
937
938
939
940
941
942
943

944

945
946
947
948
949
950
951
952
953
954
955
....
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
....
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
} [list 0 [list [file join $env(HOME) globTest]]]
test filename-11.16 {Tcl_GlobCmd} {
    list [catch {glob globTest} msg] $msg
} {0 globTest}

set globname "globTest"
set horribleglobname "glob\[\{Test"
set tildeglobname "./~test.txt"

test filename-11.17 {Tcl_GlobCmd} {unix} {
    list [catch {lsort [glob -directory $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
	[file join $globname a3]\
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
................................................................................
    set res [list [catch {lsort [glob -path {[tcl]} *]} msg] $msg]
    file delete -force {[tcl].testremains}
    set res
} [list 0 {{[tcl].testremains}}]

# Get rid of file/dir if it exists, since it will have
# been left behind by a previous failed run.

file delete -force $horribleglobname

file rename globTest $horribleglobname
set globname $horribleglobname
file delete -force $tildeglobname
close [open $tildeglobname w]

test filename-11.22 {Tcl_GlobCmd} {unix} {
    list [catch {lsort [glob -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
	[file join $globname a3]\
	[file join $globname "weird name.c"]\
	[file join $globname x,z1.c]\
................................................................................
} {1}
test filename-11.41 {Tcl_GlobCmd} {
    expr {[glob -dir [pwd] -tails *] != [glob -dir [pwd] *]}
} {1}
test filename-11.42 {Tcl_GlobCmd} {
    set res [list]
    foreach f [glob -dir [pwd] *] {
	set f [file tail $f]
	regsub {^./} $f {} f; # until glob bug [2511011fff] don't fixed (tilde expansion prevention).
	lappend res $f
    }
    expr {$res == [glob *]}
} {1}
test filename-11.43 {Tcl_GlobCmd} {
    list [catch {glob -t *} msg] $msg
} {1 {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}}
test filename-11.44 {Tcl_GlobCmd} {
................................................................................
    list [catch {glob -types abcde -dir foo -join * *} msg] $msg
} {1 {bad argument to "-types": abcde}}
test filename-11.49 {Tcl_GlobCmd} {
    list [catch {glob -types abcde -path foo -join * *} msg] $msg
} {1 {bad argument to "-types": abcde}}

file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname

test filename-12.1 {simple globbing} {unixOrPc} {
    list [catch {glob {}} msg] $msg
} {0 .}
test filename-12.1.1 {simple globbing} {unixOrPc} {
    list [catch {glob -types f {}} msg] $msg
} {1 {no files matched glob pattern ""}}

Changes to tests/tcltest.test.

545
546
547
548
549
550
551

552
553
554
555
556
557
558
559
560
...
561
562
563
564
565
566
567
568

569
570
571
572
573
574
575
576
577
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {

	catch {file attributes $notWriteableDir -readonly 1}
	catch {testchmod 000 $notWriteableDir}
    }
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
    -constraints {unix notRoot}
    -body {
	slave msg $a -tmpdir $notReadableDir
	return $msg
................................................................................
    }
    -result {*not readable*}
    -match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
    ![string match "FAT*" [lindex [file system $notWriteableDir] 1]]

}]
# FAT permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
    -constraints {unixOrPc notRoot notFAT}
    -body {
	slave msg $a -tmpdir $notWriteableDir
	return $msg
    }
    -result {*not writeable*}






>

|







 







|
>

|







545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
...
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {
	# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
	catch {file attributes $notWriteableDir -readonly 1}
	catch {testchmod 0 $notWriteableDir}
    }
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
    -constraints {unix notRoot}
    -body {
	slave msg $a -tmpdir $notReadableDir
	return $msg
................................................................................
    }
    -result {*not readable*}
    -match glob
}
# This constraint doesn't go at the top of the file so that it doesn't
# interfere with tcltest-5.5
testConstraint notFAT [expr {
       ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
    || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
}]
# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
    -constraints {unixOrPc notRoot notFAT}
    -body {
	slave msg $a -tmpdir $notWriteableDir
	return $msg
    }
    -result {*not writeable*}

Changes to tests/winFCmd.test.

13
14
15
16
17
18
19


20
21
22
23
24
25
26
..
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
...
889
890
891
892
893
894
895
896
897

898
899


900








901
902
903
904
905
906
907
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Initialise the test constraints



testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile       [llength [info commands testfile]]
testConstraint testchmod      [llength [info commands testchmod]]
testConstraint cdrom 0
testConstraint exdev 0
testConstraint longFileNames 0

................................................................................
	    set x [glob -directory $p tf* td*]
	}
	if {$x != ""} {
	    catch {file delete -force -- {*}$x}
	}
    }
}










# find a CD-ROM so we can test read-only filesystems.

proc findfile {dir} {
    foreach p [glob -directory $dir *] {
        if {[file type $p] == "file"} {
	    return $p
	}
    }
    foreach p [glob -directory $dir *] {
        if {[file type $p] == "directory"} {
	    set f [findfile $p]
	    if {$f != ""} {
	        return $f
	    }
	}
    }
    return ""
}

if {[testConstraint testvolumetype]} {
    foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
        if {![catch {testvolumetype ${p}:} result] && $result eq "CDFS"} {
            set cdrom ${p}:
	    set cdfile [findfile $cdrom]
	    testConstraint cdrom 1
	    break
        }
    }
}
................................................................................
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {win} {
    list [file attributes / -longname] [file attributes \\ -longname]
} {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} {win} {
    catch {file delete -force -- c:/td1}

    close [open c:/td1 w]
    list [catch {string tolower [file attributes c:/td1 -longname]} msg] $msg [file delete -force -- c:/td1]


} {0 c:/td1 {}}








test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable win} {
    string tolower [file attributes //bisque/tcl/ws -longname]
} {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} {win longFileNames} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]






>
>







 







>
>
>
>
>
>
>
>
>




|
<
|
|
<
|
<
|
|
|
<







|







 







|

>
|
|
>
>
|
>
>
>
>
>
>
>
>







13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
..
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
...
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}

# Initialise the test constraints

testConstraint winVista 0
testConstraint winXP 0
testConstraint testvolumetype [llength [info commands testvolumetype]]
testConstraint testfile       [llength [info commands testfile]]
testConstraint testchmod      [llength [info commands testchmod]]
testConstraint cdrom 0
testConstraint exdev 0
testConstraint longFileNames 0

................................................................................
	    set x [glob -directory $p tf* td*]
	}
	if {$x != ""} {
	    catch {file delete -force -- {*}$x}
	}
    }
}

if {[testConstraint win]} {
    set major [string index $tcl_platform(osVersion) 0]
    if {$major > 5} {
	testConstraint winVista 1
    } elseif {$major == 5} {
	testConstraint winXP 1
    }
}

# find a CD-ROM so we can test read-only filesystems.

proc findfile {dir} {
    foreach p [glob -nocomplain -type f -directory $dir *] {

	return $p
    }

    foreach p [glob -nocomplain -type d -directory $dir *] {

	set f [findfile $p]
	if {$f ne ""} {
	    return $f

	}
    }
    return ""
}

if {[testConstraint testvolumetype]} {
    foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
        if {![catch {testvolumetype ${p}:} result] && $result in {CDFS UDF}} {
            set cdrom ${p}:
	    set cdfile [findfile $cdrom]
	    testConstraint cdrom 1
	    break
        }
    }
}
................................................................................
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes ./td1 -longname]} msg] $msg [cleanup]
} {0 ./td1 {}}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} {win} {
    list [file attributes / -longname] [file attributes \\ -longname]
} {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
    catch {file delete -force -- c:/td1}
} -constraints {win winXP} -body {
    createfile c:/td1 {}
    string tolower [file attributes c:/td1 -longname]
} -cleanup {
    file delete -force -- c:/td1
} -result {c:/td1}
test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
    catch {file delete -force -- $::env(TEMP)/td1}
} -constraints {win} -body {
    createfile $::env(TEMP)/td1 {}
    string tolower [file attributes $::env(TEMP)/td1 -longname]
} -cleanup {
    file delete -force -- $::env(TEMP)/td1
} -result [string tolower [file normalize $::env(TEMP)]/td1]
test winFCmd-12.7 {ConvertFileNameFormat} {nonPortable win} {
    string tolower [file attributes //bisque/tcl/ws -longname]
} {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} {win longFileNames} {
    cleanup
    close [open td1 w]
    list [catch {string tolower [file attributes td1 -longname]} msg] $msg [cleanup]

Changes to tests/winPipe.test.

17
18
19
20
21
22
23

24
25
26
27
28
29
30
...
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
unset -nocomplain path


set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]

testConstraint exec         [llength [info commands exec]]

testConstraint cat32        [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole  [expr {![testConstraint AllocConsole]}]

set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big	
................................................................................
    fconfigure $f  -buffering none -blocking 0
    fileevent $f readable "readResults $f"
    set x 0
    set result ""
    vwait x
    list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {win exec} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    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} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    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} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    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} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    puts $f "testexcept ctrl+c"
    set status [catch {close $f}]
    list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}







>







 







|






|






|






|







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
...
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
unset -nocomplain path


set bindir [file join [pwd] [file dirname [info nameofexecutable]]]
set cat32 [file join $bindir cat32.exe]

testConstraint exec         [llength [info commands exec]]
testConstraint testexcept   [llength [info commands testexcept]]
testConstraint cat32        [file exists $cat32]
testConstraint AllocConsole [catch {puts console1 ""}]
testConstraint RealConsole  [expr {![testConstraint AllocConsole]}]

set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big	
................................................................................
    fconfigure $f  -buffering none -blocking 0
    fileevent $f readable "readResults $f"
    set x 0
    set result ""
    vwait x
    list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
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 "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 testexcept} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    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 testexcept} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    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 testexcept} {
    set f [open "|[list [interpreter]]" w+]
    set pid [pid $f]
    puts $f "testexcept ctrl+c"
    set status [catch {close $f}]
    list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2]
} {1 1 SIGINT}

Changes to win/tclWinFile.c.

1572
1573
1574
1575
1576
1577
1578
1579

1580

1581
1582
1583

1584
1585
1586
1587
1588
1589
1590



1591



1592
1593
1594







1595
1596
1597
1598
1599
1600
1601






1602


1603
1604
1605


1606
1607
1608
1609
1610
1611
1612
....
1807
1808
1809
1810
1811
1812
1813

1814
1815
1816


1817
1818
1819
1820
1821
1822
1823
	/*
	 * File exists, nothing else to check.
	 */

	return 0;
    }

    if ((mode & W_OK)

	&& (attr & FILE_ATTRIBUTE_READONLY)

	&& !(attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*
	 * The attributes say the file is not writable.	 If the file is a

	 * regular file (i.e., not a directory), then the file is not
	 * writable, full stop.	 For directories, the read-only bit is
	 * (mostly) ignored by Windows, so we can't ascertain anything about
	 * directory access from the attrib data.  However, if we have the
	 * advanced 'getFileSecurityProc', then more robust ACL checks
	 * will be done below.
	 */







	Tcl_SetErrno(EACCES);
	return -1;
    }








    if (mode & X_OK) {
	if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) {
	    /*
	     * It's not a directory and doesn't have the correct extension.
	     * Therefore it can't be executable
	     */









	    Tcl_SetErrno(EACCES);
	    return -1;
	}


    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.
................................................................................
	    return 0;
	}

	/*
	 * Use wide-char case-insensitive comparison
	 */


	if ((_wcsicmp(path+len-3, L"exe") == 0)
		|| (_wcsicmp(path+len-3, L"com") == 0)
		|| (_wcsicmp(path+len-3, L"bat") == 0)) {


	    return 1;
	}
    } else {
	const char *p;

	/*
	 * We are only looking for pure ascii.






<
>
|
>
|

<
>







>
>
>
|
>
>
>
|
|
|
>
>
>
>
>
>
>

<
<
<
<
<
<
>
>
>
>
>
>
|
>
>
|
|
|
>
>







 







>
|
|
|
>
>







1572
1573
1574
1575
1576
1577
1578

1579
1580
1581
1582
1583

1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609






1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
....
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
	/*
	 * File exists, nothing else to check.
	 */

	return 0;
    }


    /* 
     * If it's not a directory (assume file), do several fast checks:
     */
    if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) {
	/*

	 * If the attributes say this is not writable at all.  The file is a
	 * regular file (i.e., not a directory), then the file is not
	 * writable, full stop.	 For directories, the read-only bit is
	 * (mostly) ignored by Windows, so we can't ascertain anything about
	 * directory access from the attrib data.  However, if we have the
	 * advanced 'getFileSecurityProc', then more robust ACL checks
	 * will be done below.
	 */
	if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}

	/* If doesn't have the correct extension, it can't be executable */
	if ((mode & X_OK) && !NativeIsExec(nativePath)) {
	    Tcl_SetErrno(EACCES);
	    return -1;
	}
	/* Special case for read/write/executable check on file */
	if ((mode & (R_OK|W_OK|X_OK)) && !(mode & ~(R_OK|W_OK|X_OK))) {
	    DWORD mask = 0;
	    HANDLE hFile;
	    if (mode & R_OK) { mask |= GENERIC_READ;  }
	    if (mode & W_OK) { mask |= GENERIC_WRITE; }
	    if (mode & X_OK) { mask |= GENERIC_EXECUTE; }







	    hFile = (tclWinProcs->createFileProc)(nativePath, mask,
		FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
		OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
	    if (hFile != INVALID_HANDLE_VALUE) {
		CloseHandle(hFile);
		return 0;
	    }
	    /* fast exit if access was denied */
	    if (GetLastError() == ERROR_ACCESS_DENIED) {
		Tcl_SetErrno(EACCES);
		return -1;
	    }
	}
	/* We cannnot verify the access fast, check it below using security info. */
    }

    /*
     * It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
     * we have a more complex permissions structure so we try to check that.
     * The code below is remarkably complex for such a simple thing as finding
     * what permissions the OS has set for a file.
................................................................................
	    return 0;
	}

	/*
	 * Use wide-char case-insensitive comparison
	 */

	path += len-3;
	if ((_wcsicmp(path, L"exe") == 0)
		|| (_wcsicmp(path, L"com") == 0)
		|| (_wcsicmp(path, L"cmd") == 0)
		|| (_wcsicmp(path, L"ps1") == 0)
		|| (_wcsicmp(path, L"bat") == 0)) {
	    return 1;
	}
    } else {
	const char *p;

	/*
	 * We are only looking for pure ascii.