merge trunkdgp_dup_encoding_fix

5 files changed, 213 insertions, 4 deletions

diff --git a/tests/clock.test b/tests/clock.test
index b2ccdf2..08036ca 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -34992,6 +34992,10 @@ test clock-29.1800 {time parsing} {
 } 86399
 # END testcases29
 
+
+# BEGIN testcases30
+
+# Test [clock add]
 test clock-30.1 {clock add years} {
     set t [clock scan 2000-01-01 -format %Y-%m-%d -timezone :UTC]
     set f [clock add $t 1 year -timezone :UTC]
@@ -35218,6 +35222,57 @@ test clock-30.25 {clock add seconds at DST conversion} {
     set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S %z} \
 		-timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00]
 } {2004-10-31 01:00:00 -0500}
+test clock-30.26 {clock add weekdays} {
+    set t [clock scan {2013-11-20}] ;# Wednesday
+    set f1 [clock add $t 3 weekdays]
+    set x1 [clock format $f1 -format {%Y-%m-%d}]
+} {2013-11-25}
+test clock-30.27 {clock add weekdays starting on Saturday} {
+    set t [clock scan {2013-11-23}] ;# Saturday
+    set f1 [clock add $t 1 weekday]
+    set x1 [clock format $f1 -format {%Y-%m-%d}]
+} {2013-11-25}
+test clock-30.28 {clock add weekdays starting on Sunday} {
+    set t [clock scan {2013-11-24}] ;# Sunday
+    set f1 [clock add $t 1 weekday]
+    set x1 [clock format $f1 -format {%Y-%m-%d}]
+} {2013-11-25}
+test clock-30.29 {clock add 0 weekdays starting on a weekend} {
+    set t [clock scan {2016-02-27}] ;# Saturday
+    set f1 [clock add $t 0 weekdays]
+    set x1 [clock format $f1 -format {%Y-%m-%d}]
+} {2016-02-27}
+test clock-30.30 {clock add weekdays and back} -body {
+    set n [clock seconds]
+    # we start on each day of the week
+    for {set i 0} {$i < 7} {incr i} {
+        set start  [clock add $n $i days]
+        set startu [clock format $start -format %u]
+        # add 0 - 100 weekdays
+        for {set j 0} {$j < 100} {incr j} {
+            set forth [clock add $start $j weekdays]
+            set back  [clock add $forth -$j weekdays]
+            # If $s was a weekday or $j was 0, $b must be the same day.
+            # Otherwise, $b must be the immediately preceeding Friday
+            set fail 0
+            if {$j == 0 || $startu < 6} {
+                if {$start != $back} { set fail 1}
+            } else {
+                set friday [clock add $start -[expr {$startu % 5}] days]
+                if {$friday != $back} { set fail 1 }
+            }
+            if {$fail} {
+                set sdate [clock format $start -format {%Y-%m-%d}]
+                set bdate [clock format $back  -format {%Y-%m-%d}]
+                return "$sdate + $j - $j := $bdate"
+            }
+        }
+    }
+    return "OK"
+} -result {OK}
+
+# END testcases30
+
 
 test clock-31.1 {system locale} \
     -constraints win \
diff --git a/tests/lreplace.test b/tests/lreplace.test
index 55a36a8..d7f8226 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -98,7 +98,12 @@ test lreplace-1.26 {lreplace command} {
         [set foo [lreplace $foo end end]] \
         [set foo [lreplace $foo end end]]
 } {a {} {}}
-
+test lreplace-1.27 {lreplace command} {
+    lreplace x 1 1
+} x
+test lreplace-1.28 {lreplace command} {
+    lreplace x 1 1 y
+} {x y}
 
 test lreplace-2.1 {lreplace errors} {
     list [catch lreplace msg] $msg
@@ -119,8 +124,8 @@ test lreplace-2.6 {lreplace errors} {
     list [catch {lreplace x 3 2} msg] $msg
 } {1 {list doesn't contain element 3}}
 test lreplace-2.7 {lreplace errors} {
-    list [catch {lreplace x 1 1} msg] $msg
-} {1 {list doesn't contain element 1}}
+    list [catch {lreplace x 2 2} msg] $msg
+} {1 {list doesn't contain element 2}}
 
 test lreplace-3.1 {lreplace won't modify shared argument objects} {
     proc p {} {
@@ -181,6 +186,12 @@ test lreplace-4.11 {lreplace end index first} {
 test lreplace-4.12 {lreplace end index first} {
     lreplace {0 1 2 3 4} end-2 2 a b c
 } {0 1 a b c 3 4}
+test lreplace-4.13 {lreplace empty list} {
+    lreplace {} 1 1 1
+} 1
+test lreplace-4.14 {lreplace empty list} {
+    lreplace {} 2 2 2
+} 2
 
 test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} {
     apply {x {
@@ -192,6 +203,32 @@ test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} {
 	lreplace $x end 0 A
     }} {a b c}
 } {a b A c}
+
+# Testing for compiled behaviour. Far too many variations to check with
+# spelt-out tests. Note that this *just* checks whether the compiled version
+# and the interpreted version are the same, not whether the interpreted
+# version is correct.
+apply {{} {
+    set lss     {{} {a} {a b c} {a b c d}}
+    set ins     {{} A {A B}}
+    set idxs    {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2}
+    set lreplace lreplace
+
+    foreach ls $lss {
+	foreach a $idxs {
+	    foreach b $idxs {
+		foreach i $ins {
+		    set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
+		    set tester [list lreplace $ls $a $b {*}$i]
+		    set script [list catch $tester m]
+		    set script "list \[$script\] \$m"
+		    test lreplace-6.[incr n] {lreplace battery} \
+			[list apply [list {} $script]] $expected
+		}
+	    }
+	}
+    }
+}}
 
 # cleanup
 catch {unset foo}
diff --git a/tests/uplevel.test b/tests/uplevel.test
index 3f6b2a8..737c571 100644
--- a/tests/uplevel.test
+++ b/tests/uplevel.test
@@ -101,6 +101,105 @@ test uplevel-4.4 {error: not enough args} -returnCodes error -body {
 	uplevel 1
     }}
 } -result {wrong # args: should be "uplevel ?level? command ?arg ...?"}
+test uplevel-4.5 {level parsing} {
+    apply {{} {uplevel 0 {}}}
+} {}
+test uplevel-4.6 {level parsing} {
+    apply {{} {uplevel #0 {}}}
+} {}
+test uplevel-4.7 {level parsing} {
+    apply {{} {uplevel [expr 0] {}}}
+} {}
+test uplevel-4.8 {level parsing} {
+    apply {{} {uplevel #[expr 0] {}}}
+} {}
+test uplevel-4.9 {level parsing} {
+    apply {{} {uplevel -0 {}}}
+} {}
+test uplevel-4.10 {level parsing} {
+    apply {{} {uplevel #-0 {}}}
+} {}
+test uplevel-4.11 {level parsing} {
+    apply {{} {uplevel [expr -0] {}}}
+} {}
+test uplevel-4.12 {level parsing} {
+    apply {{} {uplevel #[expr -0] {}}}
+} {}
+test uplevel-4.13 {level parsing} {
+    apply {{} {uplevel 1 {}}}
+} {}
+test uplevel-4.14 {level parsing} {
+    apply {{} {uplevel #1 {}}}
+} {}
+test uplevel-4.15 {level parsing} {
+    apply {{} {uplevel [expr 1] {}}}
+} {}
+test uplevel-4.16 {level parsing} {
+    apply {{} {uplevel #[expr 1] {}}}
+} {}
+test uplevel-4.17 {level parsing} {
+    apply {{} {uplevel -0xffffffff {}}}
+} {}
+test uplevel-4.18 {level parsing} {
+    apply {{} {uplevel #-0xffffffff {}}}
+} {}
+test uplevel-4.19 {level parsing} {
+    apply {{} {uplevel [expr -0xffffffff] {}}}
+} {}
+test uplevel-4.20 {level parsing} {
+    apply {{} {uplevel #[expr -0xffffffff] {}}}
+} {}
+test uplevel-4.21 {level parsing} -body {
+    apply {{} {uplevel -1 {}}}
+} -returnCodes error -result {invalid command name "-1"}
+test uplevel-4.22 {level parsing} -body {
+    apply {{} {uplevel #-1 {}}}
+} -returnCodes error -result {bad level "#-1"}
+test uplevel-4.23 {level parsing} -body {
+    apply {{} {uplevel [expr -1] {}}}
+} -returnCodes error -result {invalid command name "-1"}
+test uplevel-4.24 {level parsing} -body {
+    apply {{} {uplevel #[expr -1] {}}}
+} -returnCodes error -result {bad level "#-1"}
+test uplevel-4.25 {level parsing} -body {
+    apply {{} {uplevel 0xffffffff {}}}
+} -returnCodes error -result {bad level "0xffffffff"}
+test uplevel-4.26 {level parsing} -body {
+    apply {{} {uplevel #0xffffffff {}}}
+} -returnCodes error -result {bad level "#0xffffffff"}
+test uplevel-4.27 {level parsing} -body {
+    apply {{} {uplevel [expr 0xffffffff] {}}}
+} -returnCodes error -result {bad level "4294967295"}
+test uplevel-4.28 {level parsing} -body {
+    apply {{} {uplevel #[expr 0xffffffff] {}}}
+} -returnCodes error -result {bad level "#4294967295"}
+test uplevel-4.29 {level parsing} -body {
+    apply {{} {uplevel 0.2 {}}}
+} -returnCodes error -result {bad level "0.2"}
+test uplevel-4.30 {level parsing} -body {
+    apply {{} {uplevel #0.2 {}}}
+} -returnCodes error -result {bad level "#0.2"}
+test uplevel-4.31 {level parsing} -body {
+    apply {{} {uplevel [expr 0.2] {}}}
+} -returnCodes error -result {bad level "0.2"}
+test uplevel-4.32 {level parsing} -body {
+    apply {{} {uplevel #[expr 0.2] {}}}
+} -returnCodes error -result {bad level "#0.2"}
+test uplevel-4.33 {level parsing} -body {
+    apply {{} {uplevel .2 {}}}
+} -returnCodes error -result {invalid command name ".2"}
+test uplevel-4.34 {level parsing} -body {
+    apply {{} {uplevel #.2 {}}}
+} -returnCodes error -result {bad level "#.2"}
+test uplevel-4.35 {level parsing} -body {
+    apply {{} {uplevel [expr .2] {}}}
+} -returnCodes error -result {bad level "0.2"}
+test uplevel-4.36 {level parsing} -body {
+    apply {{} {uplevel #[expr .2] {}}}
+} -returnCodes error -result {bad level "#0.2"}
+
+
+
 
 proc a2 {} {
     uplevel a3
diff --git a/tests/utf.test b/tests/utf.test
index ceb1af7..a03dd6c 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -302,7 +302,7 @@ test utf-21.1 {TclUniCharIsAlnum} {
 } {1}
 test utf-21.2 {unicode alnum char in regc_locale.c} {
     # this returns 1 with Unicode 7 compliance
-    list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220]
+    list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220_\u203f\u2040\u2054\ufe33\ufe34\ufe4d\ufe4e\ufe4f\uff3f]
 } {1 1}
 test utf-21.3 {unicode print char in regc_locale.c} {
     # this returns 1 with Unicode 7 compliance
diff --git a/tests/zlib.test b/tests/zlib.test
index 7a486ba..968469d 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -875,6 +875,24 @@ test zlib-11.3 {Bug 3595576 variant} -setup {
 } -cleanup {
     removeFile $file
 } -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist}
+
+test zlib-12.1 {Tk Bug 9eb55debc5} -constraints zlib -setup {
+    set stream [zlib stream compress]
+} -body {
+    for {set opts {};set y 0} {$y < 60} {incr y} {
+	for {set line {};set x 0} {$x < 100} {incr x} {
+	    append line [binary format ccc $x $y 128]
+	}
+	if {$y == 59} {
+	    set opts -finalize
+	}
+	$stream put {*}$opts $line
+    }
+    set data [$stream get]
+    list [string length $data] [string length [zlib decompress $data]]
+} -cleanup {
+    $stream close
+} -result {12026 18000}
 
 ::tcltest::cleanupTests
 return