Tcl Source Code

Check-in [6fe50c20de]
Login

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

Overview
Comment:merge 8.7
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 6fe50c20def1afa5c4188fb310fdb349d395294e752ecf93b9c5f40dfc4e2e3a
User & Date: jan.nijtmans 2018-05-01 18:43:55.452
Context
2018-05-03
16:24
Syntax error in msgcat documentation fixed. Ticket [af69c6966d] check-in: 1eedc1f86b user: oehhar tags: trunk
2018-05-01
19:02
Start implementing TIP #497. regexp's now are >BMP-aware. WIP check-in: 47ace058d4 user: jan.nijtmans tags: tip-497
18:43
merge 8.7 check-in: 6fe50c20de user: jan.nijtmans tags: trunk
18:42
merge 8.6 check-in: bea1cbc1ad user: jan.nijtmans tags: core-8-branch
2018-04-29
21:15
Merge 8.7 (= upgrade to Unicode 11 beta) check-in: ef6636a2ea user: jan.nijtmans tags: trunk
Changes
Unified Diff Ignore Whitespace Patch
Changes to generic/tclFCmd.c.
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
	}

	/*
	 * 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);







<
<
<
<
<
<
|
<







359
360
361
362
363
364
365






366

367
368
369
370
371
372
373
	}

	/*
	 * 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);
402
403
404
405
406
407
408






409

410
411
412
413
414
415
416
417
418
419
420
421
422
		}
	    }
	} 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.







>
>
>
>
>
>
|
>
|




|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
		}
	    }
	} 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 generic/tclUtf.c.
1030
1031
1032
1033
1034
1035
1036


1037

1038
1039
1040
1041
1042
1043
1044
	if (!bytes) {
	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
	    bytes = TclUtfToUniChar(src, &ch);
	    /* Combine surrogates */
	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	}
#endif


	lowChar = Tcl_UniCharToLower(lowChar);


	if (bytes < TclUtfCount(lowChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(lowChar, dst);
	}







>
>
|
>







1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
	if (!bytes) {
	    /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
	    bytes = TclUtfToUniChar(src, &ch);
	    /* Combine surrogates */
	    lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
	}
#endif
	/* Special exception for Gregorian characters, which don't have titlecase */
	if ((lowChar < 0x1C90) || (lowChar >= 0x1CC0)) {
	    lowChar = Tcl_UniCharToLower(lowChar);
	}

	if (bytes < TclUtfCount(lowChar)) {
	    memcpy(dst, src, (size_t) bytes);
	    dst += bytes;
	} else {
	    dst += Tcl_UniCharToUtf(lowChar, dst);
	}
1351
1352
1353
1354
1355
1356
1357

1358
1359
1360
1361
1362
1363
1364
1365
1366

int
Tcl_UniCharToLower(
    int ch)			/* Unicode character to convert. */
{
    if (!UNICODE_OUT_OF_RANGE(ch)) {
	int info = GetUniCharInfo(ch);


	if (GetCaseType(info) & 0x02) {
	    ch += GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}

/*







>

|







1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370

int
Tcl_UniCharToLower(
    int ch)			/* Unicode character to convert. */
{
    if (!UNICODE_OUT_OF_RANGE(ch)) {
	int info = GetUniCharInfo(ch);
	int mode = GetCaseType(info);

	if ((mode & 0x02) && (mode != 0x7)) {
	    ch += GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}

/*
1388
1389
1390
1391
1392
1393
1394

1395

1396
1397
1398
1399
1400
1401
1402
	int mode = GetCaseType(info);

	if (mode & 0x1) {
	    /*
	     * Subtract or add one depending on the original case.
	     */


	    ch += ((mode & 0x4) ? -1 : 1);

	} else if (mode == 0x4) {
	    ch -= GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}








>
|
>







1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
	int mode = GetCaseType(info);

	if (mode & 0x1) {
	    /*
	     * Subtract or add one depending on the original case.
	     */

	    if (mode != 0x7) {
		ch += ((mode & 0x4) ? -1 : 1);
	    }
	} else if (mode == 0x4) {
	    ch -= GetDelta(info);
	}
    }
    return ch & 0x1FFFFF;
}

Changes to tests/fileName.test.
774
775
776
777
778
779
780


781
782
783
784
785
786
787
    glob ~\\/globTest
} [list [file join $env(HOME) globTest]]
test filename-11.16 {Tcl_GlobCmd} {
    glob globTest
} {globTest}
set globname "globTest"
set horribleglobname "glob\[\{Test"


test filename-11.17 {Tcl_GlobCmd} {unix} {
    lsort [glob -directory $globname *]
} [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]\
	[file join $globname x1.c]\







>
>







774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
    glob ~\\/globTest
} [list [file join $env(HOME) globTest]]
test filename-11.16 {Tcl_GlobCmd} {
    glob globTest
} {globTest}
set globname "globTest"
set horribleglobname "glob\[\{Test"
set tildeglobname "./~test.txt"

test filename-11.17 {Tcl_GlobCmd} {unix} {
    lsort [glob -directory $globname *]
} [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]\
	[file join $globname x1.c]\
913
914
915
916
917
918
919
920
921
922
923
924



925
926
927
928
929
930
931
    touch {[tcl].testremains}
    lsort [glob -path {[tcl]} *]
} -cleanup {
    file delete -force {[tcl].testremains}
} -result {{[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} {
    lsort [glob -dir $globname *]
} [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]\
	[file join $globname x1.c]\







<
|
<


>
>
>







915
916
917
918
919
920
921

922

923
924
925
926
927
928
929
930
931
932
933
934
    touch {[tcl].testremains}
    lsort [glob -path {[tcl]} *]
} -cleanup {
    file delete -force {[tcl].testremains}
} -result {{[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} {
    lsort [glob -dir $globname *]
} [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]\
	[file join $globname x1.c]\
1036
1037
1038
1039
1040
1041
1042


1043
1044
1045
1046
1047
1048
1049
1050
} -match compareWords -result equal
test filename-11.41 {Tcl_GlobCmd} -body {
    list [glob -dir [pwd] -tails *] [glob -dir [pwd] *]
} -match compareWords -result "not equal"
test filename-11.42 {Tcl_GlobCmd} -body {
    set res [list]
    foreach f [glob -dir [pwd] *] {


	lappend res [file tail $f]
    }
    list $res [glob *]
} -match compareWords -result equal
test filename-11.43 {Tcl_GlobCmd} -returnCodes error -body {
    glob -t *
} -result {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.44 {Tcl_GlobCmd} -returnCodes error -body {







>
>
|







1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
} -match compareWords -result equal
test filename-11.41 {Tcl_GlobCmd} -body {
    list [glob -dir [pwd] -tails *] [glob -dir [pwd] *]
} -match compareWords -result "not equal"
test filename-11.42 {Tcl_GlobCmd} -body {
    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
    }
    list $res [glob *]
} -match compareWords -result equal
test filename-11.43 {Tcl_GlobCmd} -returnCodes error -body {
    glob -t *
} -result {ambiguous option "-t": must be -directory, -join, -nocomplain, -path, -tails, -types, or --}
test filename-11.44 {Tcl_GlobCmd} -returnCodes error -body {
1076
1077
1078
1079
1080
1081
1082

1083
1084
1085
1086
1087
1088
1089
1090
1091
    glob -types abcde -dir foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
    glob -types abcde -path foo -join * *
} -result {bad argument to "-types": abcde}

file rename $horribleglobname globTest

set globname globTest
unset horribleglobname

test filename-12.1 {simple globbing} {unixOrPc} {
    glob {}
} {.}
test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body {
    glob -types f {}
} -returnCodes error -result {no files matched glob pattern ""}







>

|







1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
    glob -types abcde -dir foo -join * *
} -result {bad argument to "-types": abcde}
test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
    glob -types abcde -path foo -join * *
} -result {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} {
    glob {}
} {.}
test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body {
    glob -types f {}
} -returnCodes error -result {no files matched glob pattern ""}
Changes to tests/tcltest.test.
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

switch -- $::tcl_platform(platform) {
    unix {
	file attributes $notReadableDir -permissions 00333
	file attributes $notWriteableDir -permissions 00555
    }
    default {

	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 {
    ![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*}







>
















|
>

|







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
580
581

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/utf.test.
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
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
    string toupper \u00e3ab
} \u00c3AB
test utf-11.4 {Tcl_UtfToUpper} {
    string toupper \u01e3ab
} \u01e2AB




test utf-12.1 {Tcl_UtfToLower} {
    string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
    string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
    string tolower \u00c3AB
} \u00e3ab
test utf-12.4 {Tcl_UtfToLower} {
    string tolower \u01e2AB
} \u01e3ab




test utf-13.1 {Tcl_UtfToTitle} {
    string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
    string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
    string totitle \u00e3ab
} \u00c3ab
test utf-13.4 {Tcl_UtfToTitle} {
    string totitle \u01f3ab
} \u01f2ab







test utf-14.1 {Tcl_UtfNcasecmp} {
    string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
    string compare -nocase b a
} 1







>
>
>













>
>
>













>
>
>
>
>
>







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
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
    string toupper \u00e3ab
} \u00c3AB
test utf-11.4 {Tcl_UtfToUpper} {
    string toupper \u01e3ab
} \u01e2AB
test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} {
    string toupper \u10d0\u1c90
} \u1c90\u1c90

test utf-12.1 {Tcl_UtfToLower} {
    string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
    string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
    string tolower \u00c3AB
} \u00e3ab
test utf-12.4 {Tcl_UtfToLower} {
    string tolower \u01e2AB
} \u01e3ab
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
    string tolower \u10d0\u1c90
} \u10d0\u10d0

test utf-13.1 {Tcl_UtfToTitle} {
    string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
    string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
    string totitle \u00e3ab
} \u00c3ab
test utf-13.4 {Tcl_UtfToTitle} {
    string totitle \u01f3ab
} \u01f2ab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
    string totitle \u10d0\u1c90
} \u10d0\u1c90
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
    string totitle \u1c90\u10d0
} \u1c90\u10d0

test utf-14.1 {Tcl_UtfNcasecmp} {
    string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
    string compare -nocase b a
} 1
Changes to tests/winFCmd.test.
1052
1053
1054
1055
1056
1057
1058









1059
1060
1061
1062
1063
1064
1065
    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.7 {ConvertFileNameFormat} -body {
    string tolower [file attributes //bisque/tcl/ws -longname]
} -constraints {nonPortable win} -result {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} -setup {
    cleanup
} -constraints {win longFileNames} -body {
    createfile td1 {}







>
>
>
>
>
>
>
>
>







1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
    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 equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \
	    [string tolower [file normalize $::env(TEMP)]/td1]]
} -cleanup {
    file delete -force -- $::env(TEMP)/td1
} -result 1
test winFCmd-12.7 {ConvertFileNameFormat} -body {
    string tolower [file attributes //bisque/tcl/ws -longname]
} -constraints {nonPortable win} -result {//bisque/tcl/ws}
test winFCmd-12.8 {ConvertFileNameFormat} -setup {
    cleanup
} -constraints {win longFileNames} -body {
    createfile td1 {}
Changes to tools/uniClass.tcl.
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
    set numchars 0
    set extchars 0
    set extranges 0

    for {set i 0} {$i <= 0x10ffff} {incr i} {
    if {$i == 0xd800} {
	# Skip surrogates
	set i 0xdc00
    }
	if {[string is $type [format %c $i]]} {
	    if {$i == ($last + 1)} {
		set last $i
	    } else {
		if {$first >= 0} {
		    emitRange $first $last







|







62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
    set numchars 0
    set extchars 0
    set extranges 0

    for {set i 0} {$i <= 0x10ffff} {incr i} {
    if {$i == 0xd800} {
	# Skip surrogates
	set i 0xe000
    }
	if {[string is $type [format %c $i]]} {
	    if {$i == ($last + 1)} {
		set last $i
	    } else {
		if {$first >= 0} {
		    emitRange $first $last
Changes to win/tclWinFile.c.
1557
1558
1559
1560
1561
1562
1563
1564

1565

1566
1567
1568
1569
1570
1571
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
	/*
	 * 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.







<
>
|
>
|

|







|
|
|
|

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







1557
1558
1559
1560
1561
1562
1563

1564
1565
1566
1567
1568
1569
1570
1571
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
	/*
	 * 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 = CreateFile(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.
1788
1789
1790
1791
1792
1793
1794

1795
1796
1797

1798
1799
1800
1801
1802
1803
1804
1805
	return 0;
    }

    if (path[len-4] != '.') {
	return 0;
    }


    if ((_tcsicmp(path+len-3, TEXT("exe")) == 0)
	    || (_tcsicmp(path+len-3, TEXT("com")) == 0)
	    || (_tcsicmp(path+len-3, TEXT("cmd")) == 0)

	    || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) {
	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------







>
|
|
|
>
|







1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
	return 0;
    }

    if (path[len-4] != '.') {
	return 0;
    }

    path += len-3;
    if ((_tcsicmp(path, TEXT("exe")) == 0)
	    || (_tcsicmp(path, TEXT("com")) == 0)
	    || (_tcsicmp(path, TEXT("cmd")) == 0)
	    || (_tcsicmp(path, TEXT("cmd")) == 0)
	    || (_tcsicmp(path, TEXT("bat")) == 0)) {
	return 1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------