merge trunk

7 files changed, 310 insertions, 34 deletions

diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index b9444b6..360d6b0 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -19,7 +19,6 @@ 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]]
-testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
 
 test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
     lsort
@@ -154,10 +153,10 @@ test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
 test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
     lsort -ascii -nocase [list \0 \x7f \x80 \uffff]
 } [list \0 \x7f \x80 \uffff]
-test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
+test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
     lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
 } [list \0 \x7f \x80 \uffff \U01ffff]
-test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
+test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
     lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
 } [list \0 \x7f \x80 \uffff \U01ffff]
 test cmdIL-1.41 {lsort -stride and -index} -body {
diff --git a/tests/encoding.test b/tests/encoding.test
index e447c20..ab60617 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -36,7 +36,7 @@ proc runtests {} {
 testConstraint testencoding [llength [info commands testencoding]]
 testConstraint testbytestring [llength [info commands testbytestring]]
 testConstraint teststringbytes [llength [info commands teststringbytes]]
-testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
+testConstraint tip389 [expr {[string length \U010000] == 2}]
 testConstraint exec [llength [info commands exec]]
 testConstraint testgetencpath [llength [info commands testgetencpath]]
 
@@ -323,16 +323,16 @@ test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
     set z
 } c080
 
-test encoding-16.1 {UnicodeToUtfProc} {
+test encoding-16.1 {UnicodeToUtfProc} -constraints tip389 -body {
     set val [encoding convertfrom unicode NN]
     list $val [format %x [scan $val %c]]
-} "\u4e4e 4e4e"
-test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
+} -result "\u4e4e 4e4e"
+test encoding-16.2 {UnicodeToUtfProc} -constraints tip389 -body {
     set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"]
     list $val [format %x [scan $val %c]]
 } -result "\U460dc 460dc"
 
-test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body {
+test encoding-17.1 {UtfToUnicodeProc} -constraints tip389 -body {
     encoding convertto unicode "\U460dc"
 } -result "\xd8\xd8\xdc\xdc"
 
diff --git a/tests/fileName.test b/tests/fileName.test
index ce89623..7f983a7 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -778,6 +778,8 @@ test filename-11.16 {Tcl_GlobCmd} {
 } {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]\
@@ -917,11 +919,12 @@ test filename-11.21.1 {Tcl_GlobCmd} -body {
 } -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 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]\
@@ -1040,7 +1043,9 @@ test filename-11.41 {Tcl_GlobCmd} -body {
 test filename-11.42 {Tcl_GlobCmd} -body {
     set res [list]
     foreach f [glob -dir [pwd] *] {
-	lappend res [file tail $f]
+	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
@@ -1080,8 +1085,9 @@ test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body {
 } -result {bad argument to "-types": abcde}
 
 file rename $horribleglobname globTest
+file delete -force $tildeglobname
 set globname globTest
-unset horribleglobname
+unset horribleglobname tildeglobname
 
 test filename-12.1 {simple globbing} {unixOrPc} {
     glob {}
diff --git a/tests/process.test b/tests/process.test
index fb3a5e2..5454a31 100644
--- a/tests/process.test
+++ b/tests/process.test
@@ -13,19 +13,269 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
     namespace import -force ::tcltest::*
 }
 
+# Utilities
+set path(sleep) [makeFile {
+    after [expr $argv*1000]
+    exit
+} sleep]
+set path(exit) [makeFile {
+    exit $argv
+} exit]
+
+# Basic syntax checking
 test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
     tcl::process
 } -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
-test process-1.2 {tcl::process command basic syntax} -returnCodes error -body {
+test process-1.2 {tcl::process subcommands} -returnCodes error -body {
     tcl::process ?
 } -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
 
-test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1}
-test process-2.2 {tcl::process autopurge set true} {
+# Autopurge flag
+# - Default state
+test process-2.1 {autopurge default} -body {
+    tcl::process autopurge
+} -result {1}
+# - Enabling autopurge
+test process-2.2 {enable autopurge} -body {
     tcl::process autopurge true
     tcl::process autopurge
-} {1}
-test process-2.3 {tcl::process autopurge set false} {
+} -result {1}
+# - Disabling autopurge
+test process-2.3 {disable autopurge} -body {
     tcl::process autopurge false
     tcl::process autopurge
-} {0}
+} -result {0} -cleanup {tcl::process autopurge true}
+
+# Subprocess list & status
+test process-3.1 {empty subprocess list} -body {
+    llength [tcl::process list]
+} -result {0}
+test process-3.2 {empty subprocess status} -body {
+    dict size [tcl::process status]
+} -result {0}
+
+# Spawn subprocesses using [exec]
+# - One child
+test process-4.1 {exec one child} -body {
+    tcl::process autopurge 0
+    set pid [exec [interpreter] $path(exit) 0 &]
+    set list [tcl::process list]
+    set statuses [tcl::process status -wait]
+    set status [lindex [tcl::process status $pid] 1]
+    expr {
+           [llength $list] eq 1 
+        && [lindex $list 0] eq $pid
+        && [dict size $statuses] eq 1
+        && [dict get $statuses $pid] eq $status
+        && $status eq 0
+    }
+} -result {1} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+# - Two children
+test process-4.2 {exec two children in parallel} -body {
+    tcl::process autopurge 0
+    set pid1 [exec [interpreter] $path(exit) 0 &]
+    set pid2 [exec [interpreter] $path(exit) 0 &]
+    set list [tcl::process list]
+    set statuses [tcl::process status -wait]
+    set status1 [lindex [tcl::process status $pid1] 1]
+    set status2 [lindex [tcl::process status $pid2] 1]
+    expr {
+           [llength $list] eq 2
+        && [lsearch $list $pid1] >= 0
+        && [lsearch $list $pid2] >= 0
+        && [dict size $statuses] eq 2
+        && [dict get $statuses $pid1] eq $status1
+        && [dict get $statuses $pid2] eq $status2
+        && $status1 eq 0
+        && $status2 eq 0
+    }
+} -result {1} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+# - 3-stage pipe
+test process-4.3 {exec 3-stage pipe} -body {
+    tcl::process autopurge 0
+    set pids [exec \
+          [interpreter] $path(exit) 0 \
+        | [interpreter] $path(exit) 0 \
+        | [interpreter] $path(exit) 0 \
+    &]
+    lassign $pids pid1 pid2 pid3
+    set list [tcl::process list]
+    set statuses [tcl::process status -wait]
+    set status1 [lindex [tcl::process status $pid1] 1]
+    set status2 [lindex [tcl::process status $pid2] 1]
+    set status3 [lindex [tcl::process status $pid3] 1]
+    expr {
+           [llength $pids] eq 3
+        && [llength $list] eq 3
+        && [lsearch $list $pid1] >= 0
+        && [lsearch $list $pid2] >= 0
+        && [lsearch $list $pid3] >= 0
+        && [dict size $statuses] eq 3
+        && [dict get $statuses $pid1] eq $status1
+        && [dict get $statuses $pid2] eq $status2
+        && [dict get $statuses $pid3] eq $status3
+        && $status1 eq 0
+        && $status2 eq 0
+        && $status3 eq 0
+    }
+} -result {1} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+
+# Spawn subprocesses using [open "|"]
+# - One child
+test process-5.1 {exec one child} -body {
+    tcl::process autopurge 0
+    set f [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+    set pid [pid $f]
+    set list [tcl::process list]
+    set statuses [tcl::process status -wait]
+    set status [lindex [tcl::process status $pid] 1]
+    expr {
+           [llength $list] eq 1 
+        && [lindex $list 0] eq $pid
+        && [dict size $statuses] eq 1
+        && [dict get $statuses $pid] eq $status
+        && $status eq 0
+    }
+} -result {1} -cleanup {
+    close $f
+    tcl::process purge
+    tcl::process autopurge 1
+}
+# - Two children
+test process-5.2 {exec two children in parallel} -body {
+    tcl::process autopurge 0
+    set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+    set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"]
+    set pid1 [pid $f1]
+    set pid2 [pid $f2]
+    set list [tcl::process list]
+    set statuses [tcl::process status -wait]
+    set status1 [lindex [tcl::process status $pid1] 1]
+    set status2 [lindex [tcl::process status $pid2] 1]
+    expr {
+           [llength $list] eq 2
+        && [lsearch $list $pid1] >= 0
+        && [lsearch $list $pid2] >= 0
+        && [dict size $statuses] eq 2
+        && [dict get $statuses $pid1] eq $status1
+        && [dict get $statuses $pid2] eq $status2
+        && $status1 eq 0
+        && $status2 eq 0
+    }
+} -result {1} -cleanup {
+    close $f1
+    close $f2
+    tcl::process purge
+    tcl::process autopurge 1
+}
+# - 3-stage pipe
+test process-5.3 {exec 3-stage pipe} -body {
+    tcl::process autopurge 0
+    set f [open "|
+          \"[interpreter]\" \"$path(exit)\" 0
+        | \"[interpreter]\" \"$path(exit)\" 0
+        | \"[interpreter]\" \"$path(exit)\" 0
+    "]
+    set pids [pid $f]
+    lassign $pids pid1 pid2 pid3
+    set list [tcl::process list]
+    set statuses [tcl::process status -wait]
+    set status1 [lindex [tcl::process status $pid1] 1]
+    set status2 [lindex [tcl::process status $pid2] 1]
+    set status3 [lindex [tcl::process status $pid3] 1]
+    expr {
+           [llength $pids] eq 3
+        && [llength $list] eq 3
+        && [lsearch $list $pid1] >= 0
+        && [lsearch $list $pid2] >= 0
+        && [lsearch $list $pid3] >= 0
+        && [dict size $statuses] eq 3
+        && [dict get $statuses $pid1] eq $status1
+        && [dict get $statuses $pid2] eq $status2
+        && [dict get $statuses $pid3] eq $status3
+        && $status1 eq 0
+        && $status2 eq 0
+        && $status3 eq 0
+    }
+} -result {1} -cleanup {
+    close $f
+    tcl::process purge
+    tcl::process autopurge 1
+}
+
+# Async child status
+test process-6.1 {async status} -body {
+    tcl::process autopurge 0
+    set pid [exec [interpreter] $path(sleep) 1 &]
+    set status1 [lindex [tcl::process status $pid] 1]
+    set status2 [lindex [tcl::process status -wait $pid] 1]
+    expr {
+           $status1 eq {}
+        && $status2 eq 0
+    }
+} -result {1} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+test process-6.2 {selective wait} -body {
+    tcl::process autopurge 0
+    # Child 1 sleeps 1s
+    set pid1 [exec [interpreter] $path(sleep) 1 &]
+    # Child 2 sleeps 1s
+    set pid2 [exec [interpreter] $path(sleep) 2 &]
+    # Initial status
+    set status1_1 [lindex [tcl::process status $pid1] 1]
+    set status1_2 [lindex [tcl::process status $pid2] 1]
+    # Wait until child 1 termination
+    set status2_1 [lindex [tcl::process status -wait $pid1] 1]
+    set status2_2 [lindex [tcl::process status $pid2] 1]
+    # Wait until child 2 termination
+    set status3_2 [lindex [tcl::process status -wait $pid2] 1]
+    set status3_1 [lindex [tcl::process status $pid1] 1]
+    expr {
+           $status1_1 eq {}
+        && $status1_2 eq {}
+        && $status2_1 eq 0
+        && $status2_2 eq {}
+        && $status3_1 eq 0
+        && $status3_2 eq 0
+    }
+} -result {1} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+
+# Error codes
+test process-7.1 {normal exit} -body {
+    tcl::process autopurge 0
+    set pid [exec [interpreter] $path(exit) 0 &]
+    lindex [tcl::process status -wait $pid] 1
+} -result {0} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+test process-7.2 {abnormal exit} -body {
+    tcl::process autopurge 0
+    set pid [exec [interpreter] $path(exit) 1 &]
+    lindex [tcl::process status -wait $pid] 1
+} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
+test process-7.3 {child killed} -body {
+    tcl::process autopurge 0
+    set pid [exec [interpreter] $path(exit) -1 &]
+    lindex [tcl::process status -wait $pid] 1
+} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup {
+    tcl::process purge
+    tcl::process autopurge 1
+}
diff --git a/tests/tcltest.test b/tests/tcltest.test
index cd3c621..286f017 100644
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -551,6 +551,7 @@ switch -- $::tcl_platform(platform) {
 	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}
     }
@@ -567,9 +568,10 @@ test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
 # 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]]
+       ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]]
+    || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]]
 }]
-# FAT permissions are fairly hopeless; ignore this test if that FS is used
+# 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 {
diff --git a/tests/utf.test b/tests/utf.test
index 6c3208c..64189cd 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -21,7 +21,7 @@ testConstraint testbytestring [llength [info commands testbytestring]]
 catch {unset x}
 
 # Some tests require support for 4-byte UTF-8 sequences
-testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
+testConstraint tip389 [expr {[string length \U010000] == 2}]
 
 test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
     expr {"\x01" eq [testbytestring "\x01"]}
@@ -41,7 +41,7 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
 test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
     expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]}
 } 1
-test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints {fullutf testbytestring} -body {
+test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints testbytestring -body {
     expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]}
 } -result 1
 
@@ -66,10 +66,10 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin
 test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
     string length [testbytestring "\xE4\xb9\x8e"]
 } {1}
-test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
+test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body {
     string length [testbytestring "\xF0\x90\x80\x80"]
 } -result {2}
-test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
+test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body {
     string length [testbytestring "\xF4\x8F\xBF\xBF"]
 } -result {2}
 test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
@@ -228,15 +228,13 @@ bsCheck \U4e21	20001
 bsCheck \U004e21	20001
 bsCheck \U00004e21	20001
 bsCheck \U0000004e21	78
-if {[testConstraint fullutf]} {
-    bsCheck \U00110000	69632
-    bsCheck \U01100000	69632
-    bsCheck \U11000000	69632
-    bsCheck \U0010FFFF	1114111
-    bsCheck \U010FFFF0	1114111
-    bsCheck \U10FFFF00	1114111
-    bsCheck \UFFFFFFFF	1048575
-}
+bsCheck \U00110000	69632
+bsCheck \U01100000	69632
+bsCheck \U11000000	69632
+bsCheck \U0010FFFF	1114111
+bsCheck \U010FFFF0	1114111
+bsCheck \U10FFFF00	1114111
+bsCheck \UFFFFFFFF	1048575
 
 test utf-11.1 {Tcl_UtfToUpper} {
     string toupper {}
@@ -250,6 +248,9 @@ test utf-11.3 {Tcl_UtfToUpper} {
 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 {}
@@ -263,6 +264,9 @@ test utf-12.3 {Tcl_UtfToLower} {
 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 {}
@@ -276,6 +280,12 @@ test utf-13.3 {Tcl_UtfToTitle} {
 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
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 294745c..e9886dc 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -1056,6 +1056,15 @@ test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
 } -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}