diff options
Diffstat (limited to 'tests')
69 files changed, 4063 insertions, 3007 deletions
diff --git a/tests/abstractlist.test b/tests/abstractlist.test new file mode 100644 index 0000000..79c30fb --- /dev/null +++ b/tests/abstractlist.test @@ -0,0 +1,635 @@ +# Exercise AbstractList via the "lstring" command defined in tclTestABSList.c +# +# Copyright © 2022 Brian Griffin +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] +} + +testConstraint testevalex [llength [info commands testevalex]] +testConstraint testobj [llength [info commands testobj]] +testConstraint lstring [llength [info commands lstring]] +testConstraint lgen [llength [info commands lgegenn]] + +set abstractlisttestvars [info var *] + +proc value-cmp {vara varb} { + upvar $vara a + upvar $varb b + set ta [tcl::unsupported::representation $a] + set tb [tcl::unsupported::representation $b] + return [string compare $ta $tb] +} + +set str "If you can keep your head when all about you Are losing theirs and blaming it on you," +set str2 "If you can trust yourself when all men doubt you, But make allowance for their doubting, too." + +test abstractlist-1.0 {error cases} -constraints lstring -body { + lstring +} \ + -returnCodes 1 \ + -result {wrong # args: should be "lstring string"} + +test abstractlist-1.1 {error cases} -constraints lstring -body { + lstring a b c +} -returnCodes 1 \ + -result {wrong # args: should be "lstring string"} + +test abstractlist-2.0 {no shimmer llength} -constraints {testobj lstring} -body { + set l [lstring $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} -cleanup { +unset l +} -result {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} + +test abstractlist-2.1 {no shimmer lindex} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set ele [lindex $l 22] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} + +test abstractlist-2.2 {no shimmer lreverse} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} + +test abstractlist-2.3 {no shimmer lrange} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +test abstractlist-2.4 {no shimmer foreach} {testobj lstring} { + set l [lstring $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-2.5 {!no shimmer lreplace} {testobj lstring} { + set l [lstring $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 78 86 { } f a i l i n g] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } f a i l i n g , { } t o o .} lstring lstring} + +test abstractlist-2.6 {no shimmer ledit} {testobj lstring} { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [testobj objtype $l] + set e [ledit l 68 67 s] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-2.7 {no shimmer linsert} -constraints {testobj lstring} -body { + # "ledit m 9 8 S" + set l [lstring $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 11 {*}[split "truly " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} -cleanup { +unset l i l-isa i-isa res p p-isa +} -result {lstring {I f { } y o u { } c a n { } t r u l y { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring y none {I f { } y o u { } c a n { } t r u l y { } t r u s t { } o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-2.8 {shimmer lassign} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} + +test abstractlist-2.9 {no shimmer lremove} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-2.10 {shimmer lreverse} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-2.11 {shimmer lset} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +# lrepeat +test abstractlist-2.12 {shimmer lrepeat} {testobj lstring} { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +test abstractlist-2.13 {no shimmer join llength==1} {testobj lstring} { + set l [lstring G] + set l-isa [testobj objtype $l] + set j [join $l :] + set j-isa [testobj objtype $j] + list ${l-isa} $l ${j-isa} $j +} {lstring G none G} + +test abstractlist-2.14 {error case lset multiple indicies} -constraints {testobj lstring} -body { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 0 1 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} -returnCodes 1 \ + -result {Multiple indicies not supported by lstring.} + +# lsort + +test abstractlist-3.0 {no shimmer llength} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} + +test abstractlist-3.1 {no shimmer lindex} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set n 22 + set ele [lindex $l $n] ;# exercise INST_LIST_INDEX + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} + +test abstractlist-3.2 {no shimmer lreverse} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} + +test abstractlist-3.3 {shimmer lrange} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring -not SLICE $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l]; # lrange defaults to list behavior + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 6 10 15 20 25 30 34 40 44 48 55 62 66 74 77 80 85} lstring list {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +test abstractlist-3.4 {no shimmer foreach} {testobj lstring} { + set l [lstring -not SLICE $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-3.5 {!no shimmer lreplace} {testobj lstring} { + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 79 86 f a i l i n g] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } f a i l i n g , { } t o o .} lstring lstring} + +test abstractlist-3.6 {no shimmer ledit} {testobj lstring} { + # "ledit m 9 8 S" + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set e [ledit l 68 67 s] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-3.7 {no shimmer linsert} {testobj lstring} { + # "ledit m 9 8 S" + set res {} + set l [lstring -not SLICE $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 35 {*}[split "wo" {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } w o m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring l none {I f { } y o u { } c a n { } t r u s t { } y o u r s e f { } w h e n { } a l l { } w o m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-3.8 {shimmer lassign} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] ;# must be using lrange internally + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} list list} + +test abstractlist-3.9 {no shimmer lremove} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-3.10 {shimmer lreverse} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-3.11 {shimmer lset} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set four 4 + set m [lset l $four-2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +# lrepeat +test abstractlist-3.12 {shimmer lrepeat} {testobj lstring} { + set l [lstring -not SLICE Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +# lsort +foreach not {{} REVERSE SLICE SETELEMENT REPLACE GETELEMENTS} { + + testConstraint [format "%sShimmer" [string totitle $not]] [expr {$not eq ""}] + set options [expr {$not ne "" ? "-not $not" : ""}] + +test abstractlist-$not-4.0 {no shimmer llength} {testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set len [llength $l] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${len} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring 85 lstring} + +test abstractlist-$not-4.1 {no shimmer lindex} {testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set ele [lindex $l 22] + set l-isa2 [testobj objtype $l] + list $l ${l-isa} ${ele} ${l-isa2} +} {{I f { } y o u { } c a n { } k e e p { } y o u r { } h e a d { } w h e n { } a l l { } a b o u t { } y o u { } A r e { } l o s i n g { } t h e i r s { } a n d { } b l a m i n g { } i t { } o n { } y o u ,} lstring e lstring} + +test abstractlist-$not-4.2 {lreverse} {ReverseShimmer testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set r [lreverse $l] + set r-isa [testobj objtype $r] + set l-isa2 [testobj objtype $l] + list $r ${l-isa} ${r-isa} ${l-isa2} +} {{, u o y { } n o { } t i { } g n i m a l b { } d n a { } s r i e h t { } g n i s o l { } e r A { } u o y { } t u o b a { } l l a { } n e h w { } d a e h { } r u o y { } p e e k { } n a c { } u o y { } f I} lstring lstring lstring} + +test abstractlist-$not-4.3 {no shimmer lrange} {RangeShimmer testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set il [lsearch -all [lstring {*}$options $str] { }] + set l-isa2 [testobj objtype $l] + lappend il [llength $l] + set start 0 + set words [lmap i $il { + set w [join [lrange $l $start $i-1] {} ] + set start [expr {$i+1}] + set w + }] + set l-isa3 [testobj objtype $l] + list ${l-isa} $il ${l-isa2} ${l-isa3} $words +} {lstring {2 7 10 16 25 29 36 39 47 55 58 63} lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +test abstractlist-$not-4.4 {no shimmer foreach} {testobj lstring} { + set l [lstring {*}$options $str] + set l-isa [testobj objtype $l] + set word {} + set words {} + foreach c $l { + if {$c eq { }} { + lappend words $word + set word {} + } else { + append word $c + } + } + if {$word ne ""} { + lappend words $word + } + set l-isa2 [testobj objtype $l] + list ${l-isa} ${l-isa2} $words +} {lstring lstring {If you can keep your head when all about you Are losing theirs and blaming it on you,}} + +# +# The TBCE implements lreplace as a lrange + lappend operation, so, in this case, $m list, not an lstring. +# +test abstractlist-$not-4.5 {!no shimmer lreplace} {RangeShimmer testobj lstring} { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set m [lreplace $l 18 23 { } f a i l ?] + set m-isa [testobj objtype $m] + set l-isa1 [testobj objtype $l] + list ${l-isa} $m ${m-isa} ${l-isa1} +} {lstring {} list lstring} + +test abstractlist-$not-4.6 {no shimmer ledit} {SetelementShimmer ReplaceShimmer testobj lstring} { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set e [ledit l 68 67 s] + set e-isa [testobj objtype $e] + list ${l-isa} $e ${e-isa} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e s { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +test abstractlist-$not-4.7 {no shimmer linsert} {ReplaceShimmer GetelementsShimmer testobj lstring} { + set l [lstring {*}$options $str2] + set l-isa [testobj objtype $l] + set i [linsert $l 12 {*}[split "almost " {}]] + set i-isa [testobj objtype $i] + set res [list ${l-isa} $i ${i-isa}] + set p [lpop i 23] + set p-isa [testobj objtype $p] + set i-isa2 [testobj objtype $i] + lappend res $p ${p-isa} $i ${i-isa2} +} {lstring {I f { } y o u { } c a n { } t r u s t { } y o u r s e l f { } w h e n { } a l l { } m e n { } d o u b t { } y o u , { } B u t { } m a k e { } a l l o w a n c e { } f o r { } t h e i r { } d o u b t i n g , { } t o o .} lstring} + +# lassign probably uses lrange internally +test abstractlist-$not-4.8 {shimmer lassign} {RangeShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lassign $l i n c] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {o n c e i v a b l e} lstring lstring} + +test abstractlist-$not-4.9 {no shimmer lremove} {ReplaceShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lremove $l 0 1] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {c o n c e i v a b l e} lstring lstring} + +test abstractlist-$not-4.10 {shimmer lreverse} {ReverseShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set l2 [lreverse $l] + set l-isa2 [testobj objtype $l] + set l2-isa [testobj objtype $l2] + list $l ${l-isa} $l2 ${l-isa2} ${l2-isa} +} {{I n c o n c e i v a b l e} lstring {e l b a v i e c n o c n I} lstring lstring} + +test abstractlist-$not-4.11 {shimmer lset} {SetelementShimmer testobj lstring} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [lset l 2 k] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +test abstractlist-$not-4.11x {lset not compiled} {SetelementShimmer testobj lstring testevalex} { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [testevalex {lset l 2 k}] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} {{I n k o n c e i v a b l e} lstring {I n k o n c e i v a b l e} lstring 0} + +test abstractlist-$not-4.11e {error case lset multiple indicies} \ + -constraints {SetelementShimmer testobj lstring testevalex} -body { + set l [lstring Inconceivable] + set l-isa [testobj objtype $l] + set m [testevalex {lset l 2 0 1 k}] + set m-isa [testobj objtype $m] + list $l ${l-isa} $m ${m-isa} [value-cmp l m] +} -returnCodes 1 \ + -result {Multiple indicies not supported by lstring.} + +# lrepeat +test abstractlist-$not-4.12 {shimmer lrepeat} -constraints {testobj lstring} -body { + set l [lstring {*}$options Inconceivable] + set l-isa [testobj objtype $l] + set m [lrepeat 3 $l] + set m-isa [testobj objtype $m] + set n [lindex $m 1] + list $l ${l-isa} $m ${m-isa} [testobj objtype $n] [value-cmp l n] +} -cleanup { +} -result {{I n c o n c e i v a b l e} lstring {{I n c o n c e i v a b l e} {I n c o n c e i v a b l e} {I n c o n c e i v a b l e}} list lstring 0} + +# Disable constraint +testConstraint [format "%sShimmer" [string totitle $not]] 1 + +} + +# +# Test fix for bug in TEBC for STR CONCAT, and LIST INDEX +# instructions. +# This example abstract list (lgen) causes a rescursive call in TEBC, +# stack management was not included for these instructions in TEBC. +# +test abstractlist-lgen-bug {bug in str concat and list operations} -constraints lgen -setup { + set lgenfile [makeFile { + # Test TIP 192 - Lazy Lists + + set res {} + set cntr 0 + + # Fatal error here when [source]'d -- It is a refcounting problem... + lappend res Index*2:[lgen 1 expr 2* ]:-- + set x [lseq 17] + set y [lgen 17 apply {{index} {expr {$index * 6}}}] ;# expr * 6 + foreach i $x n $y { + lappend res "$i -> $n" + } + proc my_expr {offset index} { + expr {$index + $offset} + } + lappend res my_expr(3):[my_expr 3 0] + + lappend res [set ss [lgen 15 my_expr 7]] + lappend res s2:[list "Index+7:" $ss ":--"] + + lappend res foo:[list "Index-8:" [lgen 15 my_expr -8] ":--"] + + set 9 [lgen 15 my_expr 7] + lappend res 9len=[llength $9] + lappend res 9(3)=[lindex $9 3] + lappend res bar:[list "Index+7:" $9 ":--"] + + lappend res Index+7:$9:-- + + lappend res Index+7:[lgen 15 my_expr 7]:-- + + proc fib {phi n} { + set d [expr {round(pow($phi, $n) / sqrt(5.0))}] + return $d + } + set phi [expr {(1 + sqrt(5.0)) / 2.0}] + + lappend res fib:[lmap n [lseq 5] {fib $phi $n}] + + set x [lgen 20 fib $phi] + lappend res "First 20 fibbinacci:[lgen 20 fib $phi]" + lappend res "First 20 fibbinacci from x :$x" + unset x + lappend res Good-Bye! + set res + } source.file] +} -body { + set tcl_traceExec 0 + set tcl_traceCompile 0 + set f $lgenfile + #set script [format "puts ====-%s-====\nsource %s\nputs ====-done-====\n" $f $f] + set script [format "source %s" $f] + #puts stderr "eval $script" + eval $script +} -cleanup { + removeFile source.file + unset res +} -result {Index*2:0:-- {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} my_expr(3):3 {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} {s2:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {foo:Index-8: {-8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6} :--} 9len=15 9(3)=10 {bar:Index+7: {7 8 9 10 11 12 13 14 15 16 17 18 19 20 21} :--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {Index+7:7 8 9 10 11 12 13 14 15 16 17 18 19 20 21:--} {fib:0 1 1 2 3} {First 20 fibbinacci:0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} {First 20 fibbinacci from x :0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181} Good-Bye!} + +test abstractlist-lgen-bug2 {bug in foreach} -constraints lgen -body { + + set x [lseq 17] + set y [lgen 17 expr 6*] + + lappend res x-[lrange [tcl::unsupported::representation $x] 0 3] + lappend res y-[lrange [tcl::unsupported::representation $y] 0 3] + foreach i $x n $y { + lappend res "$i -> $n" + } + lappend res x-[lrange [tcl::unsupported::representation $x] 0 3] + lappend res y-[lrange [tcl::unsupported::representation $y] 0 3] + +} -cleanup { + unset res +} -result {{x-value is a arithseries} {y-value is a lgenseries} {0 -> 0} {1 -> 6} {2 -> 12} {3 -> 18} {4 -> 24} {5 -> 30} {6 -> 36} {7 -> 42} {8 -> 48} {9 -> 54} {10 -> 60} {11 -> 66} {12 -> 72} {13 -> 78} {14 -> 84} {15 -> 90} {16 -> 96} {x-value is a arithseries} {y-value is a lgenseries}} + +# scalar values +test abstractlist-int {TclLengthOne: anti-shimmer of boolean, int, double, bignum} testobj { + set res {} + foreach i [list [expr {1+0}] [expr {true}] [expr {3.141592}] [expr {round(double(0x7fffffffffffffff))}]] { + lappend res [testobj objtype $i] + lappend res [llength $i] + lappend res [testobj objtype $i] + } +#set w [expr {3.141592}] +#lappend res [testobj objtype $w] [llength $w] [testobj objtype $w] + set res +} {int 1 int boolean 1 boolean double 1 double bignum 1 bignum} + +# lsort + +# cleanup +::tcltest::cleanupTests + +proc my_abstl_cleanup {vars} { + set nowvars [uplevel info vars] + foreach var $nowvars { + if {$var ni $vars} { + uplevel unset $var + lappend clean-list $var + } + } + return ${clean-list} +} + +my_abstl_cleanup $abstractlisttestvars diff --git a/tests/apply.test b/tests/apply.test index 24b27cc..a5f1f8f 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -261,7 +261,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints {memory} -body { +} -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] diff --git a/tests/assemble.test b/tests/assemble.test index 4452b38..0a7631a 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -534,18 +534,6 @@ test assemble-7.16 {incrStk} { -result 12 -cleanup {rename x {}} } -test assemble-7.17 {land/lor} { - -body { - proc x {a b} { - list \ - [assemble {load a; load b; land}] \ - [assemble {load a; load b; lor}] - } - list [x 0 0] [x 0 23] [x 35 0] [x 47 59] - } - -result {{0 0} {0 1} {0 1} {1 1}} - -cleanup {rename x {}} -} test assemble-7.18 {lappendArrayStk} { -body { proc x {} { diff --git a/tests/basic.test b/tests/basic.test index c90d80e..067f9b0 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -242,10 +242,10 @@ test basic-15.2 {Tcl_CreateObjCommand, Bug 0e4d88b650} -setup { } -test basic-16.1 {TclInvokeStringCommand} {emptyTest} { +test basic-16.1 {InvokeStringCommand} {emptyTest} { } {} -test basic-17.1 {TclInvokeObjCommand} {emptyTest} { +test basic-17.1 {InvokeObjCommand} {emptyTest} { } {} test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { diff --git a/tests/bigdata.test b/tests/bigdata.test new file mode 100644 index 0000000..a5a2077 --- /dev/null +++ b/tests/bigdata.test @@ -0,0 +1,1182 @@ +# Test cases for large sized data +# +# Copyright © 2023 Ashok P. Nadkarni +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# These are very rudimentary tests for large size arguments to commands. +# They do not exercise all possible code paths such as shared/unshared Tcl_Objs, +# literal/variable arguments etc. +# They do however test compiled and uncompiled execution. + +if {"::tcltest" ni [namespace children]} { + package require tcltest + + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact tcl::test [info patchlevel]] +source [file join [file dirname [info script]] tcltests.tcl] + +# +# bigtest and bigtestRO (RO->read only) generate compiled and uncompiled +# versions of the given test script. The difference between the two is +# that bigtest generates separate test instances for the two cases while +# bigtestRO generates a single test case covering both. The latter can +# only be used when operands are not modified and when combining tests +# does not consume too much additional memory. + +# Wrapper to generate compiled and uncompiled cases for a test. If $args does +# not contain a -body key, $comment is treated as the test body +proc bigtest {id comment result args} { + if {[dict exists $args -body]} { + set body [dict get $args -body] + dict unset args -body + } else { + set body $comment + } + dict lappend args -constraints bigdata + + uplevel 1 [list test $id.uncompiled "$comment (uncompiled)" \ + -body [list testevalex $body] \ + -result $result \ + {*}$args] + + uplevel 1 [list test $id.compiled-script "$comment (compiled script)" \ + -body [list try $body] \ + -result $result \ + {*}$args] + + return + + # TODO - is this proc compilation required separately from the compile-script above? + dict append args -setup \n[list proc testxproc {} $body] + dict append args -cleanup "\nrename testxproc {}" + uplevel 1 [list test $id.compiled-proc "$comment (compiled proc)" \ + -body {testxproc} \ + -result $result \ + {*}$args] +} + +# Like bigtest except that both compiled and uncompiled are combined into one +# test using the same inout argument. This saves time but for obvious reasons +# should only be used when the input argument is not modified. +proc bigtestRO {id comment result args} { + if {[dict exists $args -body]} { + set body [dict get $args -body] + dict unset args -body + } else { + set body $comment + } + dict lappend args -constraints bigdata + + set wrapper "" + set body "{$body}" + append wrapper "set uncompiled_result \[testevalex $body]" \n + append wrapper "set compiled_result \[try $body]" \n + append wrapper {list $uncompiled_result $compiled_result} + uplevel 1 [list test $id.uncompiled,compiled {$comment} \ + -body $wrapper \ + -result [list $result $result] \ + {*}$args] + return +} + +interp alias {} bigClean {} unset -nocomplain s s1 s2 bin bin1 bin2 l l1 l2 + +interp alias {} bigString {} testbigdata string +interp alias {} bigBinary {} testbigdata bytearray +interp alias {} bigList {} testbigdata list +proc bigPatLen {} { + proc bigPatLen {} "return [string length [testbigdata string]]" + bigPatLen +} + +# Returns list of expected elements at the indices specified +proc bigStringIndices {indices} { + set pat [testbigdata string] + set patlen [string length $pat] + lmap idx $indices { + string index $pat [expr {$idx%$patlen}] + } +} + +# Returns the largest multiple of the pattern length that is less than $limit +proc bigPatlenMultiple {limit} { + set patlen [bigPatLen] + return [expr {($limit/$patlen)*$patlen}] +} + +set ::bigLengths(intmax) 0x7fffffff +set ::bigLengths(uintmax) 0xffffffff +# Some tests are more convenient if operands are multiple of pattern length +if {[testConstraint bigdata]} { +set ::bigLengths(patlenmultiple) [bigPatlenMultiple $::bigLengths(intmax)] +set ::bigLengths(upatlenmultiple) [bigPatlenMultiple $::bigLengths(uintmax)] +} + +# +# script limits +bigtestRO script-length-bigdata-1 {Test script length limit} b -body { + try [string cat [string repeat " " 0x7ffffff7] "set a b"] +} +# TODO - different behaviour between compiled and uncompiled +test script-length-bigdata-2.compiled {Test script length limit} -body { + try [string cat [string repeat " " 0x7ffffff8] "set a b"] +} -constraints { + bigdata +} -result {Script length 2147483647 exceeds max permitted length 2147483646.} -returnCodes error +test script-length-bigdata-2.uncompiled {Test script length limit} -body { + testevalex [string cat [string repeat " " 0x7ffffff8] "set a b"] +} -constraints { + bigdata + } -result b +test script-bytecode-length-bigdata-1 {Test bytecode length limit} -body { + # Note we need to exceed bytecode limit without exceeding script char limit + set s [string repeat {{*}$x;} [expr 0x7fffffff/6]] + catch $s r e +} -cleanup { + bigClean +} -constraints panic-in-EnterCmdStartData + +# +# string cat +bigtest string-cat-bigdata-1 "string cat large small result > INT_MAX" 1 -body { + string equal \ + [string cat [bigString $::bigLengths(patlenmultiple)] [bigString]] \ + [bigString [expr {[bigPatLen]+$::bigLengths(patlenmultiple)}]] +} +bigtest string-cat-bigdata-2 "string cat small large result > INT_MAX" 1 -body { + string equal \ + [string cat [bigString] [bigString $::bigLengths(patlenmultiple)]] \ + [bigString [expr {[bigPatLen]+$::bigLengths(patlenmultiple)}]] +} +bigtest string-cat-bigdata-3 "string cat result > UINT_MAX" 1 -body { + set s [bigString $::bigLengths(patlenmultiple)] + string equal \ + [string cat $s [bigString] $s] \ + [bigString [expr {[bigPatLen]+2*$::bigLengths(patlenmultiple)}]] +} + +# +# string compare/equal +bigtestRO string-equal/compare-bigdata-1 "string compare/equal equal strings" {0 1} -body { + list [string compare $s1 $s2] [string equal $s1 $s2] +} -setup { + set s1 [bigString 0x100000000] + set s2 [bigString 0x100000000]; # Separate so Tcl_Obj is not the same +} -cleanup { + bigClean +} +bigtestRO string-equal/compare-bigdata-2 "string compare/equal -length unequal strings" {-1 0 0 1} -body { + # Also tests lengths do not wrap + set result {} + lappend result [string compare $s1 $s2] + lappend result [string equal $s1 $s2] + # Check lengths > UINT_MAX + # Also that lengths do not truncate to sizeof(int) + lappend result [string compare -length 0x100000000 $s1 $s2] + lappend result [string equal -length 0x100000000 $s1 $s2] +} -setup { + set s1 [bigString 0x100000001] + set s2 [bigString 0x100000001 0x100000000]; # Differs in last char +} -cleanup { + bigClean +} + +# +# string first +bigtestRO string-first-bigdata-1 "string first > INT_MAX" {2147483648 -1 2147483650 1} -body { + list \ + [string first X $s] \ + [string first Y $s] \ + [string first 0 $s 0x80000000] \ + [string first 1 $s end-0x80000010] +} -setup { + set s [bigString 0x8000000a 0x80000000] +} -cleanup { + bigClean +} + +bigtestRO string-first-bigdata-2 "string first > UINT_MAX" {4294967296 -1 4294967300 1} -body { + list \ + [string first X $s] \ + [string first Y $s] \ + [string first 0 $s 0x100000000] \ + [string first 1 $s end-0x100000010] +} -setup { + set s [bigString 0x10000000a 0x100000000] +} -cleanup { + bigClean +} + +bigtestRO string-first-bigdata-3 "string first - long needle" 10 -body { + string first $needle $s +} -setup { + set s [bigString 0x10000000a 0] + set needle [bigString 0x100000000] +} -cleanup { + bigClean needle +} + +# +# string index +bigtestRO string-index-bigdata-1 "string index" {6 7 5 {} 5 4 {} 9 {}} -body { + list \ + [string index $s 0x100000000] \ + [string index $s 0x100000000+1] \ + [string index $s 0x100000000-1] \ + [string index $s 0x10000000a] \ + [string index $s end] \ + [string index $s end-1] \ + [string index $s end+1] \ + [string index $s end-0x100000000] \ + [string index $s end-0x10000000a] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} + +# +# string insert +bigtestRO string-insert-bigdata-1 "string insert" 1 -body { + # Note insert at multiple of 10 to enable comparison against generated string + string equal [string insert [bigString 4294967312] 4294967310 "0123456789"] [bigString 4294967322] +} +bigtestRO string-insert-bigdata-2 "string insert" 1 -body { + string equal [string insert [bigString 4294967312] 10 "0123456789"] [bigString 4294967322] +} + +# +# string is +bigtestRO string-is-bigdata-1 "string is" {1 0 0 4294967296} -body { + # TODO - add the other "is" classes + unset -nocomplain failat result + lappend result [string is alnum -failindex failat $s] [info exists failat] + lappend result [string is digit -failindex failat $s] $failat +} -setup { + set s [bigString 0x10000000a 0x100000000] +} -cleanup { + bigClean failat +} + +# +# string last +bigtestRO string-last-bigdata-1 "string last > INT_MAX" {2 -1 2147483640 11} -body { + set s [bigString 0x80000010 2] + list \ + [string last X $s] \ + [string last Y $s] \ + [string last 0 $s 0x80000000] \ + [string last 1 $s end-0x80000000] +} -setup { + set s [bigString 0x80000010 2] +} -cleanup { + bigClean +} +bigtestRO string-last-bigdata-2 "string last > UINT_MAX" {4294967320 -1 4294967290 1} -body { + list \ + [string last 0 $s] \ + [string last Y $s] \ + [string last 0 $s 0x100000000] \ + [string last 1 $s end-0x100000010] +} -setup { + set s [bigString 0x10000001a 2] +} -cleanup { + bigClean +} +bigtestRO string-last-bigdata-3 "string last - long needle" 0 -body { + string last $needle $s +} -setup { + set s [bigString 0x10000000a 0x10000000a] + set needle [bigString 0x100000000] +} -cleanup { + bigClean needle +} + +# +# string length +bigtestRO string-length-bigdata-1 {string length $s} 4294967296 -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} + +# +# string map +bigtestRO string-map-bigdata-1 {string map} {5 0 0 5} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string map {0 5 5 0} $s] + list \ + [string index $s2 0] \ + [string index $s2 5] \ + [string index $s2 end] \ + [string index $s2 end-5] +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong + +# +# string match +bigtestRO string-match-bigdata-1 {string match} {1 0 1} -body { + list \ + [string match 0*5 $s] \ + [string match 0*4 $s] \ + [string match $s $s] +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} + +# +# string range +bigtestRO string-range-bigdata-1 "string range" {6 7 5 {} 5 4 {} 9 {}} -body { + list \ + [string range $s 0x100000000 0x100000000] \ + [string range $s 0x100000000+1 0x100000000+1] \ + [string range $s 0x100000000-1 0x100000000-1] \ + [string range $s 0x10000000a 0x10000000a] \ + [string range $s end end] \ + [string range $s end-1 end-1] \ + [string range $s end+1 end+1] \ + [string range $s end-0x100000000 end-0x100000000] \ + [string range $s end-0x10000000a end-0x10000000a] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} +bigtestRO string-range-bigdata-2 "bug ad9361fd20 case 1" aXaaaa -body { + string range [string insert [string repeat a 0x80000000] end-0x7fffffff X] 0 5 +} +bigtestRO string-range-bigdata-3 "bug ad9361fd20 case 2" 2 -body { + string length [string range $s end-0x7fffffff end-0x7ffffffe] +} -setup { + set s [string repeat a 0xffffffff] +} -cleanup { + bigClean +} +# TODO - add tests for large result range + +# +# string repeat - use bigtest, not bigtestRO !! +bigtest string-repeat-bigdata-1 "string repeat single char length > UINT_MAX" 4294967296 -body { + string length [string repeat x 0x100000000] +} +bigtest string-repeat-bigdata-2 "string repeat multiple char" {4294967296 0123456789abcdef 0123456789abcdef} -body { + set s [string repeat 0123456789abcdef [expr 0x100000000/16]] + list \ + [string length $s] \ + [string range $s 0 15] \ + [string range $s end-15 end] +} -cleanup { + bigClean +} + +# +# string replace +bigtestRO string-replace-bigdata-1 "string replace" {789012345 012345678 XYZ789012345 012345678XYZ} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result + lappend result [string replace $s 0 0x100000000] + lappend result [string replace $s end-0x100000000 end] + lappend result [string replace $s 0 0x100000000 XYZ] + lappend result [string replace $s end-0x100000000 end XYZ] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} +# TODO - +# - replacements string is large +# - replace in the middle - string length grows, shrinks +# - last < first + +# +# string reverse +bigtestRO string-reverse-bigdata-1 "string reverse" {5432109876 9876543210} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string reverse $s] + list [string range $s2 0 9] [string range $s2 end-9 end] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} + +# +# string tolower +bigtestRO string-tolower-bigdata-1 "string tolower" 1 -body { + string equal [string tolower $s] [string repeat abcd $repts] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat ABCD $repts] +} -cleanup { + bigClean repts +} +bigtestRO string-tolower-bigdata-2 "string tolower first last" {4294967312 ABCDabcdABCD 4294967312 ABCDabcdABCD 4294967312 ABCDabcdABCD} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string tolower $s 4 7] + lappend result [string length $s2] [string range $s2 0 11] + + unset s2; #Explicit free to reduce total memory + set s2 [string tolower $s 0x100000008 0x10000000b] + lappend result [string length $s2] [string range $s2 0x100000004 end] + + unset s2; #Explicit free to reduce total memory + set s2 [string tolower $s end-7 end-4] + lappend result [string length $s2] [string range $s2 0x100000004 end] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat ABCD $repts] +} -cleanup { + bigClean repts +} + +# +# string totitle +bigtestRO string-totitle-bigdata-1 "string totitle first last" {4294967312 aBcDAbcdaBcD 4294967312 aBcDAbcdaBcD 4294967312 aBcDAbcdaBcD} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string totitle $s 4 7] + lappend result [string length $s2] [string range $s2 0 11] + unset s2; #Explicit free to reduce total memory + set s2 [string totitle $s 0x100000008 0x10000000b] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] + unset s2; #Explicit free to reduce total memory + set s2 [string totitle $s end-7 end-4] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat aBcD $repts] +} -cleanup { + bigClean repts +} + +# +# string toupper +bigtestRO string-toupper-bigdata-1 "string toupper" 1 -body { + string equal [string toupper $s] [string repeat ABCD $repts] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat abcd $repts] +} -cleanup { + bigClean repts +} +bigtestRO string-toupper-bigdata-2 "string toupper first last" {4294967312 abcdABCDabcd 4294967312 abcdABCDabcd 4294967312 abcdABCDabcd} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 result + set s2 [string toupper $s 4 7] + lappend result [string length $s2] [string range $s2 0 11] + unset s2; #Explicit free to reduce total memory + set s2 [string toupper $s 0x100000008 0x10000000b] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] + unset s2; #Explicit free to reduce total memory + set s2 [string toupper $s end-7 end-4] + lappend result [string length $s2] [string range $s2 0x100000004 0x10000000f] +} -setup { + set repts [expr 0x100000010/4] + set s [string repeat abcd $repts] +} -cleanup { + bigClean repts +} + +# +# string trim +bigtestRO string-trim-bigdata-1 "string trim" {abcdyxxy yxxyabcd} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string trim $s xy] + list [string range $s2 0 7] [string range $s2 end-7 end] +} -setup { + set repts [expr 0x100000010/8] + set s [string repeat xyabcdyx $repts] +} -cleanup { + bigClean +} + +# +# string trimleft +bigtestRO string-trimleft-bigdata-1 "string trimleft" {abcdyxxy xyabcdyx} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string trimleft $s xy] + list [string range $s2 0 7] [string range $s2 end-7 end] +} -setup { + set repts [expr 0x100000010/8] + set s [string repeat xyabcdyx $repts] +} -cleanup { + bigClean +} + +# +# string trimright +bigtestRO string-trimright-bigdata-1 "string trimright" {xyabcdyx yxxyabcd} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [string trimright $s xy] + list [string range $s2 0 7] [string range $s2 end-7 end] +} -setup { + set repts [expr 0x100000010/8] + set s [string repeat xyabcdyx $repts] +} -cleanup { + bigClean +} + +# +# append +bigtestRO append-bigdata-1 "append large to small" 1 -body { + set s 0123456789 + append s [bigString 0x100000000] + string equal $s [bigString 0x10000000a] +} -cleanup { + bigClean +} +bigtest append-bigdata-2 "append small to cross UINT_MAX boundary" 1 -body { + append s 0123456789 + string equal $s [bigString 4294967300] +} -setup { + set s [bigString 4294967290] +} -cleanup { + bigClean +} +bigtest append-bigdata-3 "append small to cross UINT_MAX boundary" 1 -body { + set s2 "" + append s2 $s $s $s $s + string equal $s2 [bigString 4294967320] +} -setup { + # Make length multiple of 4 AND 10 since the bigString pattern length is 10 + set len [expr 4294967320/4] + set s [bigString $len] +} -cleanup { + bigClean +} + +# +# format +bigtestRO format-bigdata-1 "format %s" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [format %s $s] + string equal $s $s2 +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} +bigtest format-bigdata-2 "format bigstring%s" 1 -body { + set s [format $s X] + string equal $s [bigString 0x100000001 0x100000000] +} -setup { + set s [bigString 0x100000000] + append s %s +} -cleanup { + bigClean +} +bigtest format-bigdata-3 "format big width" {4294967300 { } { a}} -body { + set s [format %4294967300s a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtest format-bigdata-4 "format big negative width" {4294967300 {a } { }} -body { + set s [format %-4294967300s a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtest format-bigdata-5 "format big * width" {4294967300 { } { a}} -body { + set s [format %*s 4294967300 a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtest format-bigdata-6 "format big negative * width" {4294967300 {a } { }} -body { + set s [format %*s -4294967300 a] + list [string length $s] [string range $s 0 3] [string range $s end-3 end] +} -cleanup { + bigClean +} +bigtestRO format-bigdata-7 "format big precision" {4294967300 0123 6789} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [format %.4294967300s $s] + list [string length $s2] [string range $s2 0 3] [string range $s2 end-3 end] +} -setup { + set s [testbigdata string 4294967310] +} -cleanup { + bigClean +} +bigtestRO format-bigdata-8 "format big * precision" {4294967300 0123 6789} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain s2 + set s2 [format %.*s 4294967300 $s] + list [string length $s2] [string range $s2 0 3] [string range $s2 end-3 end] +} -setup { + set s [testbigdata string 4294967310] +} -cleanup { + bigClean +} + +# +# scan +bigtestRO scan-bigdata-1 "scan %s" {1 1 2 X 1 2 4294967300 01234X} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result digits x + lappend result [string equal [scan $s %s] $s] + lappend result [string equal [scan $s {%[0-9X]}] $s] + lappend result [scan $s {%[0-9]%s} digits x] $x + lappend result [string equal $digits [bigString 0x100000009]] + lappend result [scan $s %4294967300s%s x y] + lappend result [string length $x] $y +} -setup { + set s [bigString 0x10000000a 0x100000009] +} -cleanup { + bigClean digits +} + +# +# regexp +bigtestRO regexp-bigdata-1 "regexp" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result digits + lappend result [regexp {[[:digit:]]*X} $s] +} -setup { + set s [bigString 0x100000000 0x100000000] +} -cleanup { + bigClean digits +} +bigtestRO regexp-bigdata-2 "regexp with capture" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result digits match + lappend result [regexp {([[:digit:]])*X} $s match digits] [string equal $match $s] + puts B + unset match; # Free up memory + lappend result [string equal $digits [bigString 0x100000009]] +} -setup { + set s [bigString 0x10000000a 0x100000009] +} -cleanup { + bigClean digits match +} -constraints bug-takesTooLong + +# +# regsub +bigtestRO regsub-bigdata-1 "regsub" X -body { + regsub -all \\d $s {} +} -setup { + set s [bigString 0x100000001 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong +bigtestRO regsub-bigdata-2 "regsub" 1 -body { + string equal [regsub -all \\d $s x] [string cat [string repeat x 0x100000000] X] +} -setup { + set s [bigString 0x100000001 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong + +# +# subst +bigtestRO subst-bigdata-1 "subst" {1 1} -body { + unset -nocomplain result + lappend result [string equal [subst $s] $s] + lappend result [string equal [subst {$s}] $s] +} -setup { + set s [bigString 0x10000000a] +} -cleanup { + bigClean +} + +# +# binary format +bigtestRO binary-format-bigdata-1 "binary format aN" [list 4294967296 X\0\0\0 \0\0\0\0] -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin + set bin [binary format a4294967296 X] + list [string length $bin] [string range $bin 0 3] [string range $bin end-3 end] +} -cleanup { + bigClean +} +# TODO - do string compare and add other format specifiers + +bigtestRO binary-format-bigdata-2 "binary format a*" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin2 + set bin2 [binary format a* $bin] + string equal $bin $bin2 +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +# +# binary scan +bigtestRO binary-scan-bigdata-1 "binary scan aN" {4294967296 0123 2345} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin2 + binary scan $bin a4294967296 bin2 + list [string length $bin2] [string range $bin2 0 3] [string range $bin2 end-3 end] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} +# TODO - do string compare and add other format specifiers once above bug is fixed + +bigtestRO binary-scan-bigdata-2 "binary scan a*" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain bin2 + binary scan $bin a* bin2 + string equal $bin $bin2 +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} +# TODO - do string compare and add other format specifiers once above bug is fixed + +# +# binary encode / decode base64 +bigtestRO binary-encode/decode-base64-bigdata-1 "binary encode/decode base64" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + string equal $bin [binary decode base64 [binary encode base64 $bin]] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +# +# binary encode / decode hex +bigtestRO binary-encode/decode-hex-bigdata-1 "binary encode/decode hex" 1 -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + string equal $bin [binary decode hex [binary encode hex $bin]] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +# +# binary encode / decode uuencode +bigtestRO binary-encode/decode-uuencode-bigdata-1 "binary encode/decode uuencode" 1 -body { + string equal $bin [binary decode uuencode [binary encode uuencode $bin]] +} -setup { + set bin [bigBinary 4294967296] +} -cleanup { + bigClean +} + +################################################################ +# List commands + +# +# foreach +bigtestRO foreach-bigdata-1 "foreach" 1 -body { + # Unset explicitly before setting as bigtestRO runs the script twice. + unset -nocomplain l2 + foreach x $l { + lappend l2 $x + } + testlutil equal $l $l2 +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} + +# +# lappend +bigtest lappend-bigdata-1 "lappend" {4294967300 4294967300 {1 2 3 4 5 a b c d}} -body { + # Do NOT initialize l in a -setup block. That requires more memory and fails. + # Do not have enough memory for a full compare. + # Just check end + set l [bigList 0x100000000] + list [llength [lappend l a b c d]] [llength $l] [lrange $l end-8 end] +} -cleanup { + bigClean +} + +# +# lassign +bigtestRO lassign-bigdata-1 "lassign" {0 1 2 3 4 5 6 7 8 {9 0 1 2 3 4 5 6 7 8} {6 7 8 9 0 1 2 3 4 5}} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain l2 + set l2 [lassign $l a b c d e f g h i] + list $a $b $c $d $e $f $g $h $i [lrange $l2 0 9] [lrange $l2 end-9 end] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} + +# +# ledit +bigtest ledit-bigdata-1 "ledit - small result" {{0 X Y Z 8} {0 X Y Z 8}} -body { + list [ledit l 1 0x100000001 X Y Z] $l +} -setup { + set l [bigList 0x100000003] +} -cleanup { + bigClean +} + +bigtest ledit-bigdata-2 "ledit - large result" {4294967304 4294967304 {a b c d e f g 7}} -body { + # Do NOT initialize l in a -setup block. That requires more memory and fails. + set l [bigList 0x100000002] + list [llength [ledit l 0x100000000 0x100000000 a b c d e f g]] [llength $l] [lrange $l 0x100000000 end] +} -cleanup { + bigClean +} + +bigtest ledit-bigdata-3 "ledit - small -> large result" {2147483650 2147483650 {a b 0 1 2 3 4 5} {0 1 e f g h i j}} -body { + set l2 {a b c d e f g h i j} + list [llength [ledit l2 2 3 {*}$l]] [llength $l2] [lrange $l2 0 7] [lrange $l2 end-7 end] +} -setup { + # Note total number of arguments has to be less than INT_MAX + set l [bigList 2147483642] +} -cleanup { + bigClean +} -constraints memory-allocation-panic + +# +# lindex +bigtestRO lindex-bigdata-1 "lindex" {6 7 5 {} 5 4 {} 9 {}} -body { + list \ + [lindex $l 0x100000000] \ + [lindex $l 0x100000000+1] \ + [lindex $l 0x100000000-1] \ + [lindex $l 0x10000000a] \ + [lindex $l end] \ + [lindex $l end-1] \ + [lindex $l end+1] \ + [lindex $l end-0x100000000] \ + [lindex $l end-0x10000000a] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} +# TODO nested index + +# +# linsert +# Cannot use bigtestRO here because 16GB memory not enough to have two 4G sized lists +# Have to throw away source list every time. Also means we cannot compare entire lists +# and instead just compare the affected range +bigtest linsert-bigdata-1 "linsert" {4294967330 1} -body { + # Note insert at multiple of 10 to enable comparison against generated string + set ins [split abcdefghij ""] + set pat [split 0123456789 ""] + set insidx 2000000000 + set l [linsert [bigList 4294967320] $insidx {*}$ins] + list \ + [llength $l] \ + [testlutil equal [lrange $l $insidx-10 $insidx+19] [concat $pat $ins $pat]] +} -cleanup { + bigClean +} + +# +# list and {*} +# TODO - compiled and uncompiled behave differently so tested separately +test list-bigdata-1.compiled {list {*}} -body { + set l [bigList 0x100000000] + set l2 [list {*}$l] + unset l + list [llength $l2] [lindex $l2 0] [lindex $l2 end] +} -cleanup { + bigClean +} -constraints { + bigdata +} -result {4294967296 0 5} +test list-bigdata-1.uncompiled {list {*}} -body { + set l [bigList 0x7fffffff] + testevalex {set l2 [list {*}$l]} +} -cleanup { + bigClean +} -constraints { + bigdata +} -result {Number of words in command exceeds limit 2147483647.} -returnCodes error + +# +# llength +bigtestRO llength-bigdata-1 {llength} 4294967296 -body { + llength $l +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} + +# +# lmap +bigtestRO lmap-bigdata-1 "lmap" 4294967296 -body { + set n 0 + if {0} { + # TODO - This is the right test but runs out of memory + testlutil equal $l [lmap e $l {set e}] + } else { + lmap e $l {incr n; continue} + } + set n +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean + puts "" +} + +# +# lrange +bigtestRO lrange-bigdata-1 "lrange" {6 {6 7} 7 5 {} 5 4 {} 9 {8 9} {}} -body { + list \ + [lrange $l 0x100000000 0x100000000] \ + [lrange $l 0x100000000 0x100000001] \ + [lrange $l 0x100000000+1 0x100000000+1] \ + [lrange $l 0x100000000-1 0x100000000-1] \ + [lrange $l 0x10000000a 0x10000000a] \ + [lrange $l end end] \ + [lrange $l end-1 end-1] \ + [lrange $l end+1 end+1] \ + [lrange $l end-0x100000000 end-0x100000000] \ + [lrange $l end-0x100000001 end-0x100000000] \ + [lrange $l end-0x10000000a end-0x10000000a] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} +# TODO - add tests for large result range + +# +# lrepeat - use bigtest, not bigtestRO !! +bigtest lrepeat-bigdata-1 "lrepeat single element length > UINT_MAX" 4294967296 -body { + # Just to test long lengths are accepted as arguments + llength [lrepeat 0x100000000 x] +} + +bigtest lrepeat-bigdata-2 "string repeat multiple char" {4294967400 {0 1 2 3 4 5 6 7}} -body { + set len [expr 4294967400/8] + set l [lrepeat $len 0 1 2 3 4 5 6 7] + list [llength $l] [lrange $l end-7 end] +} -cleanup { + bigClean +} + +# +# lreplace +bigtestRO lreplace-bigdata-1 "lreplace - small result" [list \ + [split 789012345 ""] \ + [split 012345678 ""] \ + [split XYZ789012345 ""] \ + [split 012345678XYZ ""] \ + ] -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain result + lappend result [lreplace $l 0 0x100000000] + lappend result [lreplace $l end-0x100000000 end] + lappend result [lreplace $l 0 0x100000000 X Y Z] + lappend result [lreplace $l end-0x100000000 end X Y Z] +} -setup { + set l [bigList 0x10000000a] +} -cleanup { + bigClean +} + +bigtest lreplace-bigdata-2 "lreplace - large result" {4294967301 {a b c d e 0 1 2 3 4 5 6}} -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain l2 + set l2 [lreplace [bigList 4294967296] 4294967290 0 a b c d e] + lrange $l2 4294967290 end +} -setup { + #set l [bigList 4294967296] +} -cleanup { + bigClean +} -constraints bug-outofmemorypanic + +# +# lsearch +bigtestRO lsearch-bigdata-1 "lsearch" {4294967300 4294967310 -1} -body { + list \ + [lsearch -exact $l X] \ + [lsearch -exact -start 4294967291 $l 0] \ + [lsearch -exact $l Y] +} -setup { + set l [bigList 0x100000010 4294967300] +} -cleanup { + bigClean +} +# TODO - stride, inline, all + +# +# lseq +bigtest lseq-bigdata-1 "lseq" {4294967297 4294967296} -body { + list [llength $l] [lindex $l 0x100000000] +} -setup { + set l [lseq 0x100000001] +} -cleanup { + bigClean +} +bigtest lseq-bigdata-2 "lseq" {9223372036854775807 9223372036854775799} -body { + list [llength $l] [lindex $l 9223372036854775800] +} -setup { + set l [lseq 0x7fffffffffffffff]; llength $l +} -cleanup { + bigClean +} -constraints bug-fa00fbbbab + +# +# lset +bigtest lset-bigdata-1 "lset" {4294967297 4294967297 {1 2 3 4 5 X}} -body { + # Do NOT initialize l in a -setup block. That requires more memory and fails. + set l [bigList 0x100000001] + list [llength [lset l 0x100000000 X]] [llength $l] [lrange $l end-5 end] +} -cleanup { + bigClean +} + +# +# lsort +bigtestRO lsort-bigdata-1 "lsort" [list 4294967296 [lrepeat 10 0] [lrepeat 10 9]] -body { + # Unset explicitly before setting to save memory as bigtestRO runs the + # script below twice. + unset -nocomplain l2 + set l2 [lsort $l] + list [llength $l2] [lrange $l2 0 9] [lrange $l2 end-9 end] +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} -constraints notenoughmemoryexception + +# +# join +bigtestRO join-bigdata-1 "join" [list 0123456789 6789012345] -body { + set s [join $l ""] + list [string range $s 0 9] [string range $s end-9 end] +} -setup { + set l [bigList 0x100000000] +} -cleanup { + bigClean +} + +bigtest split-bigdata-1 "split" {4294967296 {0 1 2 3 4} {1 2 3 4 5}} -body { + # Fill list compare needs too much memory + set l [split $s ""] + list [llength $l] [lrange 0 4] [lrange end-4 end] +} -setup { + set s [bigString 0x100000000] +} -cleanup { + bigClean +} -constraints bug-takesTooLong + +bigtestRO concat-bigdata-1 "concat" {4294967296 {0 1 2 3 4} {6 7 0 1 2} {3 4 5 6 7}} -body { + unset -nocomplain l2 + set l2 [concat $l $l] + list [llength $l2] [lrange $l2 0 4] [lrange $l2 0x80000000-2 0x80000000+2] [lrange $l2 end-4 end] +} -setup { + set l [bigList 0x80000000] +} + +test puts-bigdata-1 "puts" -setup { + set fpath [makeFile {} bug-0306a5563.data] +} -constraints { + bigdata +} -body { + set fd [open $fpath w] + puts -nonewline $fd [testbigdata string 0x80000001] + close $fd + set fd [open $fpath] + seek $fd 0x7FFFFFFA + set written [read $fd] + close $fd + set written +} -result {2345678} + +test puts-bigdata-2 "puts" -setup { + set fpath [tcltest::makeFile {} bug-0306a5563.data] +} -constraints { + bigdata +} -body { + set fd [open $fpath w] + set s [testbigdata string 0x7FFFFFFE] + # The character to append in the next line is —, EM DASH, + # code point 0x2014 (decimal 8212, UTF-8 #xE2 #x80 #x94) + append s \u2014 + puts -nonewline $fd $s + close $fd + set fd [open $fpath] + seek $fd 0x7FFFFFFA + set written [read $fd] + close $fd + set written +} -result {2345—} + +test source-bigdata-1 "source" -setup { + # This test crashes because the frame linenumber tracking + # wraps around at INT_MAX + set fpath [tcltest::makeFile {} source-bigdata-1.tcl] + set fd [open $fpath w] + fconfigure $fd -translation lf + puts -nonewline $fd [string repeat \n 4294967296] + puts $fd {dict get [info frame 0] line} + close $fd +} -constraints { + bigdata knownBug +} -body { + set line [source $fpath] +} -result 4294967297 + +# +# TODO +# lremove +# lreverse +# encoding convertfrom +# encoding convertto +# dict * + + + +# cleanup +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/tests/binary.test b/tests/binary.test index 03ef846..299e1e0 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -15,11 +15,14 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands +source [file join [file dirname [info script]] tcltests.tcl] + catch [list package require -exact tcl::test [info patchlevel]] testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -3008,7 +3011,7 @@ test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678 binary encode hex \U0001f415 binary scan \U0001f415 a* v; set v set str {} -} -result {} +} -result * -match glob -returnCodes error testConstraint testsetbytearraylength \ @@ -3017,9 +3020,21 @@ testConstraint testsetbytearraylength \ test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength { testsetbytearraylength [string cat A B C] 1 } A -test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength { +test binary-79.2 {Tcl_SetByteArrayLength} -body { testsetbytearraylength [string cat Ł B C] 1 +} -constraints testsetbytearraylength -returnCodes error -match glob -result * +test binary-79.3 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 0 +} {} +test binary-79.4 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 1 } A +test binary-79.5 {Tcl_SetByteArrayLength} testsetbytearraylength { + testsetbytearraylength [string cat A B \u0141] 2 +} AB +test binary-79.6 {Tcl_SetByteArrayLength} -body { + testsetbytearraylength [string cat A B \u0141] 3 +} -constraints testsetbytearraylength -returnCodes error -match glob -result * test binary-80.1 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring "乎" @@ -3033,6 +3048,9 @@ test binary-80.3 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes test binary-80.4 {Tcl_GetBytesFromObj} -constraints testbytestring -returnCodes 1 -body { testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"] } -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)" +test binary-80.5 {Tcl_GetBytesFromObj} -constraints {testbytestring pointerIs64bit deprecated} -body { + testbytestring [string repeat A [expr 2**31]] +} -returnCodes 1 -result "byte sequence length exceeds INT_MAX" # ---------------------------------------------------------------------- # cleanup diff --git a/tests/case.test b/tests/case.test deleted file mode 100644 index 1c12e3a..0000000 --- a/tests/case.test +++ /dev/null @@ -1,94 +0,0 @@ -# Commands covered: case -# -# This file contains a collection of tests for one or more of the Tcl -# built-in commands. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright © 1991-1993 The Regents of the University of California. -# Copyright © 1994 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -if {![llength [info commands case]]} { - # No "case" command? So no need to test - return -} - -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* -} - -test case-1.1 {simple pattern} { - case a in a {format 1} b {format 2} c {format 3} default {format 4} -} 1 -test case-1.2 {simple pattern} { - case b a {format 1} b {format 2} c {format 3} default {format 4} -} 2 -test case-1.3 {simple pattern} { - case x in a {format 1} b {format 2} c {format 3} default {format 4} -} 4 -test case-1.4 {simple pattern} { - case x a {format 1} b {format 2} c {format 3} -} {} -test case-1.5 {simple pattern matches many times} { - case b a {format 1} b {format 2} b {format 3} b {format 4} -} 2 -test case-1.6 {fancier pattern} { - case cx a {format 1} *c {format 2} *x {format 3} default {format 4} -} 3 -test case-1.7 {list of patterns} { - case abc in {a b c} {format 1} {def abc ghi} {format 2} -} 2 - -test case-2.1 {error in executed command} { - list [catch {case a in a {error "Just a test"} default {format 1}} msg] \ - $msg $::errorInfo -} {1 {Just a test} {Just a test - while executing -"error "Just a test"" - ("a" arm line 1) - invoked from within -"case a in a {error "Just a test"} default {format 1}"}} -test case-2.2 {error: not enough args} { - list [catch {case} msg] $msg -} {1 {wrong # args: should be "case string ?in? ?pattern body ...? ?default body?"}} -test case-2.3 {error: pattern with no body} { - list [catch {case a b} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.4 {error: pattern with no body} { - list [catch {case a in b {format 1} c} msg] $msg -} {1 {extra case pattern with no body}} -test case-2.5 {error in default command} { - list [catch {case foo in a {error case1} default {error case2} \ - b {error case 3}} msg] $msg $::errorInfo -} {1 case2 {case2 - while executing -"error case2" - ("default" arm line 1) - invoked from within -"case foo in a {error case1} default {error case2} b {error case 3}"}} - -test case-3.1 {single-argument form for pattern/command pairs} { - case b in { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.2 {single-argument form for pattern/command pairs} { - case b { - a {format 1} - b {format 2} - default {format 6} - } -} {2} -test case-3.3 {single-argument form for pattern/command pairs} { - list [catch {case z in {a 2 b}} msg] $msg -} {1 {extra case pattern with no body}} - -# cleanup -::tcltest::cleanupTests -return diff --git a/tests/chan.test b/tests/chan.test index 4155c36..87d642c 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -11,6 +11,9 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] + +package require tcltests # # Note: The tests for the chan methods "create" and "postevent" @@ -49,19 +52,19 @@ test chan-4.1 {chan command: configure subcommand} -body { } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\"" test chan-4.2 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar Ā -} -returnCodes error -match glob -result {bad value*} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.3 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar \x00 -} -returnCodes error -match glob -result {bad value*} -test chan-4.4 {chan command: check valid inValue, no outValue} -body { +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} +test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body { chan configure stdout -eofchar [list \x27 {}] } -result {} test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { chan configure stdout -eofchar [list \x27 \x80] -} -returnCodes error -match glob -result {bad value for -eofchar:*} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} -cleanup {chan configure stdout -eofchar {}} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/chanio.test b/tests/chanio.test index 821e8be..6173d0d 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -63,7 +63,7 @@ namespace eval ::tcl::test::io { set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] - testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] + testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}] # set up a long data file for some of the following tests @@ -82,7 +82,7 @@ namespace eval ::tcl::test::io { if {$argv != ""} { set f [open [lindex $argv 0]] } - chan configure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A" + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A chan configure stdout -encoding binary -translation lf -buffering none chan event $f readable "foo $f" proc foo {f} { @@ -483,7 +483,7 @@ test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdef\x1Aghijk\nwombat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar "\x1A \x1A" + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -493,7 +493,7 @@ test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdefghijk\nwom\x1Abat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar "\x1A \x1A" + chan configure $f -eofchar \x1A list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -1001,7 +1001,7 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b chan puts -nonewline $f "123456\x1Ak9012345\r" chan close $f set f [open $path(test1)] - chan configure $f -eofchar "\x1A \x1A" + chan configure $f -eofchar \x1A list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] } -cleanup { chan close $f @@ -1891,13 +1891,13 @@ test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result [list [list \x1A ""] {auto crlf}] +} -result {{} {auto crlf}} test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result {{{} {}} {auto lf}} +} -result {{} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] } -constraints {stdio notWinCI} -body { @@ -3107,7 +3107,7 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3120,11 +3120,11 @@ test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) } -constraints {win} -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan read $f } -cleanup { chan close $f @@ -3142,7 +3142,7 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3163,7 +3163,7 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3241,7 +3241,7 @@ test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f [format abc\ndef\n%cqrs\ntuv 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3255,7 +3255,7 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3269,7 +3269,7 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3283,7 +3283,7 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3297,7 +3297,7 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3311,7 +3311,7 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3662,7 +3662,7 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3678,11 +3678,11 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { set l "" } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3702,7 +3702,7 @@ test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3720,7 +3720,7 @@ test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3804,7 +3804,7 @@ test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3822,7 +3822,7 @@ test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3840,7 +3840,7 @@ test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3858,7 +3858,7 @@ test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3876,7 +3876,7 @@ test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3894,7 +3894,7 @@ test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -4650,86 +4650,86 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {11 8 1} +} -result {10 8 1} test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {11 8 1} +} -result {10 8 1} test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { file delete $path(test1) } -body { @@ -4739,7 +4739,7 @@ test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4753,7 +4753,7 @@ test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4767,7 +4767,7 @@ test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4781,7 +4781,7 @@ test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4795,7 +4795,7 @@ test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4809,7 +4809,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -5287,29 +5287,29 @@ test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l "" -} -constraints {unix} -body { +} -constraints {unix deprecated} -body { set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {ON GO} + chan configure $f1 -eofchar {O {}} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {D D} + chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] } -cleanup { chan close $f1 -} -result {{{} {}} {O G} {D D}} -test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { +} -result {{} O D} +test chan-io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -setup { file delete $path(test1) set l [list] } -body { set f1 [open $path(test1) w+] - chan configure $f1 -eofchar {ON GO} + chan configure $f1 -eofchar {O {}} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {D D} + chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] } -cleanup { chan close $f1 -} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test chan-io-39.23 { Tcl_GetChannelOption, server socket is not readable or writable, but should still have valid -eofchar and -translation options. @@ -5321,7 +5321,7 @@ test chan-io-39.23 { [chan configure $sock -translation] } -cleanup { chan close $sock -} -result {{{}} auto} +} -result {{} auto} test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ writable so we can't change -eofchar or -translation} -setup { set l [list] @@ -5332,7 +5332,7 @@ test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ [chan configure $sock -translation] } -cleanup { chan close $sock -} -result {{{}} auto} +} -result {{} auto} test chan-io-40.1 {POSIX open access modes: RDWR} -setup { file delete $path(test3) @@ -5492,21 +5492,16 @@ test chan-io-40.15 {POSIX open access modes: RDWR} { chan close $f lappend x [viewFile test3] } {zzy abzzy} -test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { - makeFile {Some text} _test_ ~ +test chan-io-40.16 {verify no tilde substitution in open} -setup { + set curdir [pwd] + cd [temporaryDirectory] } -body { - file exists [file join $::env(HOME) _test_] + close [open ~ w] + list [file isfile ~] } -cleanup { - removeFile _test_ ~ + file delete ./~ ;# ./ because don't want to delete home in case of bugs! + cd $curdir } -result 1 -test chan-io-40.17 {tilde substitution in open} -setup { - set home $::env(HOME) -} -body { - unset ::env(HOME) - open ~/foo -} -returnCodes error -cleanup { - set ::env(HOME) $home -} -result {couldn't find HOME environment variable to expand path} test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event foo @@ -6051,7 +6046,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6075,7 +6070,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6099,7 +6094,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6123,7 +6118,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6147,7 +6142,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6171,7 +6166,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar "\x1A \x1A" + chan configure $f -translation auto -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6195,7 +6190,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6219,7 +6214,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar "\x1A \x1A" + chan configure $f -translation lf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6243,7 +6238,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6267,7 +6262,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar "\x1A \x1A" + chan configure $f -translation cr -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6291,7 +6286,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6315,7 +6310,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar "\x1A \x1A" + chan configure $f -translation crlf -eofchar \x1A chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6875,8 +6870,7 @@ test chan-io-52.9 {TclCopyChannel & encodings} {fcopy} { [file size $path(utf8-fcopy.txt)] \ [file size $path(utf8-rp.txt)] } {3 5 5} -test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { - # encoding to binary (=> implies that the internal utf-8 is written) +test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy} -body { set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] chan configure $in -encoding koi8-r -translation lf @@ -6888,25 +6882,31 @@ test chan-io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -b chan close $in chan close $out unset in out -} -result 5 +} -returnCodes 1 -match glob -result {error writing "*":\ + invalid or incomplete multibyte or wide character} test chan-io-52.11 {TclCopyChannel & encodings} -setup { set f [open $path(utf8-fcopy.txt) w] fconfigure $f -encoding utf-8 -translation lf puts $f АА close $f } -constraints {fcopy} -body { - # binary to encoding => the input has to be in utf-8 to make sense to the - # encoder set in [open $path(utf8-fcopy.txt) r] set out [open $path(kyrillic.txt) w] # -translation binary is also -encoding binary chan configure $in -translation binary - chan configure $out -encoding koi8-r -translation lf - chan copy $in $out - chan close $in - chan close $out - file size $path(kyrillic.txt) -} -result 3 + chan configure $out -encoding koi8-r -translation lf -profile strict + catch {chan copy $in $out} cres copts + return $cres +} -cleanup { + if {$in in [chan names]} { + close $in + } + if {$out in [chan names]} { + close $out + } + catch {unset cres} +} -match glob -result {error writing "*": invalid or incomplete\ + multibyte or wide character} test chan-io-53.1 {CopyData} -setup { file delete $path(test1) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 7cae5c8..ad5a67d 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -22,10 +22,6 @@ testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testbytestring [llength [info commands testbytestring]] -testConstraint time64bit [expr { - $::tcl_platform(pointerSize) >= 8 || - [llength [info command testsize]] && [testsize st_mtime] >= 8 -}] testConstraint linkDirectory [expr { ![testConstraint win] || ($::tcl_platform(osVersion) >= 5.0 @@ -67,8 +63,6 @@ test cmdAH-0.2 {Tcl_BreakObjCmd, success} { list [catch {break} msg] $msg } {3 {}} -# Tcl_CaseObjCmd is tested in case.test - test cmdAH-1.1 {Tcl_CatchObjCmd, errors} -returnCodes error -body { catch } -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} @@ -109,7 +103,7 @@ test cmdAH-2.3 {Tcl_CdObjCmd} -setup { set env(HOME) $oldpwd file mkdir $foodir cd $foodir - cd ~ + cd [file home] string equal [pwd] $oldpwd } -cleanup { cd $oldpwd @@ -133,8 +127,21 @@ test cmdAH-2.4 {Tcl_CdObjCmd} -setup { set env(HOME) $temp } -result 1 test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body { - cd ~~ -} -result {user "~" doesn't exist} + cd ~ +} -result {couldn't change working directory to "~": no such file or directory} +test cmdAH-2.5.1 {Tcl_CdObjCmd} -setup { + set oldpwd [pwd] + cd [temporaryDirectory] + file delete ./~ + file mkdir ~ +} -body { + cd ~ + pwd +} -cleanup { + cd [temporaryDirectory] + file delete ./~ + cd $oldpwd +} -result [file join [temporaryDirectory] ~] test cmdAH-2.6 {Tcl_CdObjCmd} -returnCodes error -body { cd _foobar } -result {couldn't change working directory to "_foobar": no such file or directory} @@ -815,7 +822,7 @@ test cmdAH-8.43 {Tcl_FileObjCmd: dirname} -setup { } -constraints testsetplatform -body { set env(HOME) "/homewontexist/test" testsetplatform unix - file dirname ~ + file dirname [file home] } -cleanup { set env(HOME) $temp } -result /homewontexist @@ -825,19 +832,13 @@ test cmdAH-8.44 {Tcl_FileObjCmd: dirname} -setup { } -constraints testsetplatform -body { set env(HOME) "~" testsetplatform unix - file dirname ~ + file dirname [file home] } -cleanup { set env(HOME) $temp -} -result ~ -test cmdAH-8.45 {Tcl_FileObjCmd: dirname} -setup { - set temp $::env(HOME) -} -constraints {win testsetplatform} -match regexp -body { - set ::env(HOME) "/homewontexist/test" - testsetplatform windows +} -result . +test cmdAH-8.45 {Tcl_FileObjCmd: dirname ~} -body { file dirname ~ -} -cleanup { - set ::env(HOME) $temp -} -result {([a-zA-Z]:?)/homewontexist} +} -result . test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { set f [file normalize [info nameof]] file exists $f @@ -945,36 +946,19 @@ test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) "/home/test" - testsetplatform unix +test cmdAH-9.42 {Tcl_FileObjCmd: tail ~} -body { file tail ~ -} -cleanup { - set env(HOME) $temp -} -result test +} -result ~ test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) } -body { set env(HOME) "~" testsetplatform unix - file tail ~ + file tail [file home] } -cleanup { set env(HOME) $temp -} -result {} -test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) "/home/test" - testsetplatform windows - file tail ~ -} -cleanup { - set env(HOME) $temp -} -result test +} -result ~ test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} @@ -1005,7 +989,7 @@ test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} { [file tail {~/test/~foo}] \ [file tail [file normalize {~/~foo}]] \ [file tail [file normalize {~/test/~foo}]] -} [lrepeat 4 ./~foo] +} [lrepeat 4 ~foo] # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body { @@ -1259,7 +1243,7 @@ test cmdAH-14.3 {Tcl_FileObjCmd: join} testsetplatform { test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { testsetplatform unix file atime ~_bad_user -} -returnCodes error -result {user "_bad_user" doesn't exist} +} -returnCodes error -result {could not read "~_bad_user": no such file or directory} catch {testsetplatform $platform} @@ -1382,9 +1366,8 @@ test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { - # should probably be a non-error in fact... file nativename ~nOsUcHuSeR -} -returnCodes error -match glob -result * +} -result ~nOsUcHuSeR # The test below has to be done in /tmp rather than the current directory in # order to guarantee (?) a local file system: some NFS file systems won't do # the stuff below correctly. @@ -1724,16 +1707,20 @@ test cmdAH-24.14.1 { } -match regexp -result {could not (?:get modification time|read)} -returnCodes error # 3155760000 is 64-bit Unix time, Wed Jan 01 00:00:00 GMT 2070: -test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { +test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -setup { set filename [makeFile "" foo.text] } -body { + # This test may fail if your system does not have a 64-bit time_t. + # That is to be expected and is not a problem with Tcl. list [file atime $filename 3155760000] [file atime $filename] } -cleanup { removeFile $filename } -result {3155760000 3155760000} -test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup { +test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -setup { set filename [makeFile "" foo.text] } -body { + # This test may fail if your system does not have a 64-bit time_t. + # That is to be expected and is not a problem with Tcl. list [file mtime $filename 3155760000] [file mtime $filename] } -cleanup { file delete -force $filename @@ -2028,9 +2015,6 @@ test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x } -match glob -result {unknown or ambiguous subcommand "t": must be *} -test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { - file dirname ~woohgy -} -result {user "woohgy" doesn't exist} # channels # In testing 'file channels', we need to make sure that a channel created in diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 316a945..c8f5e0e 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -19,6 +19,18 @@ catch [list package require -exact tcl::test [info patchlevel]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +proc memusage {} { + set fd [open /proc/[pid]/statm] + set line [gets $fd] + if {[llength $line] != 7} { + error "Unexpected /proc/pid/statm format" + } + set result [lindex $line 5] + close $fd + return $result +} +testConstraint hasMemUsage [expr {![catch {memusage}]}] + testConstraint testobj [llength [info commands testobj]] source [file join [file dirname [info script]] internals.tcl] namespace import -force ::tcltest::internals::* @@ -137,7 +149,7 @@ test cmdIL-1.32 {lsort -stride errors} -returnCodes error -body { } -result {expected integer but got "foo"} test cmdIL-1.33 {lsort -stride errors} -returnCodes error -body { lsort -stride 1 bar -} -match glob -result {stride length must be between 2 and *} +} -result {stride length must be at least 2} test cmdIL-1.34 {lsort -stride errors} -returnCodes error -body { lsort -stride 2 {a b c} } -result {list size must be a multiple of the stride length} @@ -170,7 +182,7 @@ test cmdIL-1.42 {lsort -stride and-index} -body { } -returnCodes error -result {index "-1-1" out of range} test cmdIL-1.43 {lsort -stride errors} -returnCodes error -body { lsort -stride 4294967296 bar -} -match glob -result {stride length must be between 2 and *} +} -result {list size must be a multiple of the stride length} # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -743,19 +755,31 @@ test cmdIL-6.24 {lassign command - memory leak testing} -setup { rename stress {} } # Assorted shimmering problems -test cmdIL-6.25 {lassign command - shimmering protection} -body { +test cmdIL-6.25 {lassign command (compiled) - shimmering protection} -body { apply {{} { set x {a b c} list [lassign $x $x y] $x [set $x] $y }} } -result {c {a b c} a b} -test cmdIL-6.26 {lassign command - shimmering protection} -body { +test cmdIL-6.26 {lassign command (uncompiled) - shimmering protection} -body { apply {{} { set x {a b c} set lassign lassign list [$lassign $x $x y] $x [set $x] $y }} } -result {c {a b c} a b} +test cmdIL-6.27 {bug-f5e36eb588 - uncompiled lassign on lseq does not bloat memory} -constraints { + hasMemUsage +} -body { + set l [lseq 1000000] + lassign $l x + set premem [memusage] + set lassign lassign + $lassign $l x + set postmem [memusage] + expr {($postmem-$premem) < 100} +} -result 1 + test cmdIL-7.1 {lreverse command} -body { lreverse diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 40dea76..ec7eda1 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -19,7 +19,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Big test for correct ordering of data in [expr] @@ -79,9 +78,6 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] - # procedures used below proc put_hello_char {c} { diff --git a/tests/compExpr.test b/tests/compExpr.test index eaef772..84c53de 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -14,7 +14,6 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] diff --git a/tests/compile.test b/tests/compile.test index 36b4f3a..cf552e2 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -326,7 +326,7 @@ test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; string index a 0o9 }} -} -returnCodes error -match glob -result {*invalid octal number*} +} -returnCodes error -match glob -result {*} test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { apply {{} { set r [list foobar] ; array set var {one two many} }} } -returnCodes error -result {list must have an even number of elements} diff --git a/tests/dict.test b/tests/dict.test index 1515675..59b600e 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -14,6 +14,13 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +catch { + ::tcltest::loadTestedCommands + package require -exact tcl::test [info patchlevel] +} + +testConstraint testobj [llength [info commands testobj]] + # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { @@ -27,6 +34,7 @@ if {[testConstraint memory]} { expr {$end - $tmp} } } + test dict-1.1 {dict command basic syntax} -returnCodes error -body { dict @@ -138,8 +146,16 @@ test dict-3.15 {compiled dict get error cleanliness - Bug 2431847} -body { dict get $a(z) d }} } -returnCodes error -result {key "d" not known in dictionary} -test dict-3.16 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;set l} {p 1 p 2 q 3} -test dict-3.17 {dict/list shimmering - Bug 3004007} {set l [list p 1 p 2 q 3];dict get $l q;llength $l} 6 +test dict-3.16 {dict/list shimmering - Bug 3004007} testobj { + set l [list p 1 p 2 q 3] + dict get $l q + list $l [testobj objtype $l] +} {{p 1 p 2 q 3} dict} +test dict-3.17 {dict/list shimmering - Bug 3004007} testobj { + set l [list p 1 p 2 q 3] + dict get $l q + list [llength $l] [testobj objtype $l] +} {6 dict} test dict-4.1 {dict replace command} { dict replace {a b c d} @@ -657,20 +673,20 @@ test dict-14.13 {dict for command: script results} { error "return didn't go far enough" }} } ok,a,b -test dict-14.14 {dict for command: handle representation loss} -body { +test dict-14.14 {dict for command: handle representation loss} -constraints testobj -body { set dictVar {a b c d e f g h} set keys {} set values {} dict for {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v } } - list [lsort $keys] [lsort $values] + list [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v -} -result {{a c e g} {b d f h}} +} -result {{a c e g} {b d f h} string} test dict-14.15 {dict for command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} @@ -1802,33 +1818,33 @@ test dict-24.13 {dict map command: script results} { error "return didn't go far enough" }} } ok,a,b -test dict-24.14 {dict map command: handle representation loss} -setup { +test dict-24.14 {dict map command: handle representation loss} -constraints testobj -setup { set keys {} set values {} } -body { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } - }]] [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] } -cleanup { unset dictVar keys values k v -} -result {4 {a c e g} {b d f h}} -test dict-24.14a {dict map command: handle representation loss} -body { +} -result {4 {a c e g} {b d f h} string} +test dict-24.14a {dict map command: handle representation loss} -constraints testobj -body { apply {{} { set dictVar {a b c d e f g h} list [dict size [dict map {k v} $dictVar { - if {[llength $dictVar]} { + if {[string length $dictVar]} { lappend keys $k lappend values $v return -level 0 $k } - }]] [lsort $keys] [lsort $values] + }]] [lsort $keys] [lsort $values] [testobj objtype $dictVar] }} -} -result {4 {a c e g} {b d f h}} +} -result {4 {a c e g} {b d f h} string} test dict-24.15 {dict map command: keys are unique and iterated over once only} -setup { unset -nocomplain accum array set accum {} diff --git a/tests/encoding.test b/tests/encoding.test index 70aa99e..c27fcd3 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -22,8 +22,6 @@ catch { package require -exact tcl::test [info patchlevel] } -source [file join [file dirname [info script]] tcltests.tcl] - proc toutf {args} { variable x lappend x "toutf $args" @@ -335,7 +333,7 @@ test encoding-15.4 {UtfToUtfProc emoji character input} -body { set x \xED\xA0\xBD\xED\xB8\x82 set y [encoding convertfrom -profile tcl8 utf-8 \xED\xA0\xBD\xED\xB8\x82] list [string length $x] $y -} -result "6 😂" +} -result "6 \uD83D\uDE02" test encoding-15.5 {UtfToUtfProc emoji character input} { set x \xF0\x9F\x98\x82 set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82] @@ -346,7 +344,7 @@ test encoding-15.6 {UtfToUtfProc emoji character output} { set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z -} {10 edb882f09f9882eda0bd} +} {12 edb882eda0bdedb882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uD83D] @@ -521,7 +519,7 @@ test encoding-16.14 {Utf16ToUtfProc} -body { } -result \uDC00 test encoding-16.15 {Utf16ToUtfProc} -body { encoding convertfrom utf-16le \x00\xD8\x00\xDC -} -result \uD800\uDC00 +} -result \U010000 test encoding-16.16 {Utf16ToUtfProc} -body { encoding convertfrom -profile tcl8 utf-16le \x00\xDC\x00\xD8 } -result \uDC00\uD800 @@ -585,9 +583,9 @@ test encoding-16.25.tcl8 {Utf32ToUtfProc} -body { test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -test encoding-17.2 {UtfToUcs2Proc, invalid testcase, see [5607d6482c]} -constraints deprecated -body { - encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] -} -result "\uFFFD" +test encoding-17.2 {UtfToUcs2Proc} -body { + encoding convertfrom utf-16 \xD8\xD8\xDC\xDC +} -result "\U460DC" test encoding-17.3 {UtfToUtf16Proc} -body { encoding convertto -profile tcl8 utf-16be "\uDCDC" } -result "\xDC\xDC" @@ -883,8 +881,8 @@ test encoding-24.37 {Parse invalid utf-8 with -profile tcl8} -body { test encoding-24.38.1 {Try to generate invalid utf-8} -body { encoding convertto -profile tcl8 utf-8 \uD800 } -result \xED\xA0\x80 -test encoding-24.38.2 {Try to generate invalid utf-8} -body { - encoding convertto -profile strict utf-8 \uD800 +test encoding-24.38.2 {Try to generate invalid utf-8 - default profile} -body { + encoding convertto utf-8 \uD800 } -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'} test encoding-24.39 {Try to generate invalid utf-8 with -profile strict} -body { encoding convertto -profile strict utf-8 \uD800 @@ -1120,6 +1118,32 @@ test encoding-29.0 {get encoding nul terminator lengths} -constraints { [testencoding nullength ksc5601] } -result {1 2 4 2 2} +test encoding-30.0 {encoding convertto large strings UINT_MAX} -constraints { + perf +} -body { + # Test to ensure not misinterpreted as -1 + list [string length [set s [string repeat A 0xFFFFFFFF]]] [string equal $s [encoding convertto ascii $s]] +} -result {4294967295 1} + +test encoding-30.1 {encoding convertto large strings > 4GB} -constraints { + perf +} -body { + list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertto ascii $s]] +} -result {4294967296 1} + +test encoding-30.2 {encoding convertfrom large strings UINT_MAX} -constraints { + perf +} -body { + # Test to ensure not misinterpreted as -1 + list [string length [set s [string repeat A 0xFFFFFFFF]]] [string equal $s [encoding convertfrom ascii $s]] +} -result {4294967295 1} + +test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints { + perf +} -body { + list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]] +} -result {4294967296 1} + test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body { encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby } -result x\uFFFDy @@ -1152,6 +1176,8 @@ test encoding-bug-66ffafd309-2-replace {Bug [66ffafd309] - invalid DBCS} -body { encoding convertfrom -profile replace jis0208 \x78\x79 } -result \uFFFD\uFFFD + + # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests diff --git a/tests/encodingVectors.tcl b/tests/encodingVectors.tcl index 9b62f84..c73b7f7 100644 --- a/tests/encodingVectors.tcl +++ b/tests/encodingVectors.tcl @@ -10,7 +10,7 @@ # List of defined encoding profiles set encProfiles {tcl8 strict replace} -set encDefaultProfile tcl8; # Should reflect the default from implementation +set encDefaultProfile strict; # Should reflect the default from implementation # encValidStrings - Table of valid strings. # @@ -343,10 +343,10 @@ lappend encInvalidBytes {*}{ utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} utf-8 EDBFBF strict {} 0 {} {Low surrogate} - utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 tcl8 \uD800\uDC00 -1 {} {High low surrogate pair} utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF tcl8 \uDBFF\uDFFF -1 {} {High low surrogate pair} utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} diff --git a/tests/env.test b/tests/env.test index 5317897..345567b 100644 --- a/tests/env.test +++ b/tests/env.test @@ -18,6 +18,11 @@ if {"::tcltest" ni [namespace children]} { source [file join [file dirname [info script]] tcltests.tcl] +testConstraint utf8system [string equal [encoding system] utf-8] +if {[llength [auto_execok bash]]} { + testConstraint haveBash 1 +} + # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { @@ -411,6 +416,56 @@ test env-7.3 { }} } -cleanup cleanup1 -result 1 +test env-7.4 { + get env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_4) origvalue + upvar #0 env(test7_4) var + return $var + }} +} -cleanup cleanup1 -result origvalue + +test env-7.5 { + set env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_5) origvalue + upvar #0 env(test7_5) var + set var newvalue + return $::env(test7_5) + }} +} -cleanup cleanup1 -result newvalue + +test env-7.6 { + unset env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_6) origvalue + upvar #0 env(test7_6) var + unset var + return [array get env test7_6] + }} +} -cleanup cleanup1 -result {} + +test env-7.7 { + create new (unset) env variable through upvar +} -setup setup1 -body { + apply {{} { + unset -nocomplain ::env(test7_7) + upvar #0 env(test7_7) var + interp create interp1 + set var newvalue + set result [interp1 eval {info exists ::env(test7_7)}] + if {$result} { + lappend result [interp1 eval {set ::env(test7_7)}] + } + interp delete interp1 + return $result + }} +} -cleanup cleanup1 -result {1 newvalue} + + test env-8.0 { memory usage - valgrind does not report reachable memory } -body { @@ -458,6 +513,22 @@ test env-9.1 { } } -result {} +test env-10.0 { + Unequal environment strings test should test unequal +} -constraints {unix haveBash utf8system knownBug} -setup { + set tclScript [makeFile { + puts [string equal $env(XX) $env(YY)] + } tclScript] + set shellCode { + export XX=$'\351' + export YY=$'\303\251' + } + append shellCode "[info nameofexecutable] $tclScript\n" + set shScript [makeFile $shellCode shScript] +} -body { + exec {*}[auto_execok bash] $shScript +} -result 0 + # cleanup diff --git a/tests/exec.test b/tests/exec.test index 4058ae9..4f7a1a8 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -434,15 +434,21 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body { exec cat >@ $f } -returnCodes error -result "channel \"$f\" wasn't opened for writing" close $f -test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body { +test exec-10.20.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { exec ~non_existent_user/foo/bar -} -returnCodes error -result {user "non_existent_user" doesn't exist} -test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body { +} -returnCodes error -result {couldn't execute "~non_existent_user/foo/bar": no such file or directory} +test exec-10.20.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { + exec ~non_existent_user/foo/bar +} -returnCodes error -result {couldn't execute "~non_existent_user\foo\bar": no such file or directory} +test exec-10.21.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { + exec [interpreter] true | ~xyzzy_bad_user/x | false +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user/x": no such file or directory} +test exec-10.21.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { exec [interpreter] true | ~xyzzy_bad_user/x | false -} -returnCodes error -result {user "xyzzy_bad_user" doesn't exist} +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user\x": no such file or directory} test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { exec echo test > ~non_existent_user/foo/bar -} -returnCodes error -result {user "non_existent_user" doesn't exist} +} -returnCodes error -result {couldn't write file "~non_existent_user/foo/bar": no such file or directory} # Commands in background. test exec-11.1 {commands in background} {exec} { @@ -706,6 +712,35 @@ test exec-20.1 {exec .CMD file} -constraints {win} -body { exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" viewFile $log } -result "\"Testing exec-20.1\"" + +# Test with encoding mismatches (Bug 0f1ddc0df7fb7) +test exec-21.1 {exec encoding mismatch on stdout} -setup { + set path(script) [makeFile { + fconfigure stdout -translation binary + puts a\xe9b + } script] + set enc [encoding system] + encoding system utf-8 +} -cleanup { + removeFile $path(script) + encoding system $enc +} -body { + exec [info nameofexecutable] $path(script) +} -result a\uFFFDb +test exec-21.2 {exec encoding mismatch on stderr} -setup { + set path(script) [makeFile { + fconfigure stderr -translation binary + puts stderr a\xe9b + } script] + set enc [encoding system] + encoding system utf-8 +} -cleanup { + removeFile $path(script) + encoding system $enc +} -body { + list [catch {exec [info nameofexecutable] $path(script)} r] $r +} -result [list 1 a\uFFFDb] + # ---------------------------------------------------------------------- # cleanup diff --git a/tests/execute.test b/tests/execute.test index 8702de6..90af21c 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -34,7 +34,6 @@ testConstraint testobj [expr { && [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] @@ -464,10 +463,6 @@ test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { list [catch {expr {! $x}} msg] $msg } {1 {can't use non-numeric string "foo" as operand of "!"}} -# INST_BITNOT not tested -# INST_CALL_BUILTIN_FUNC1 not tested -# INST_CALL_FUNC1 not tested - # INST_TRY_CVT_TO_NUMERIC is partially tested: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { set x [testintobj set 1 1] @@ -1066,7 +1061,7 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} { } SUCCESS test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} { - apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} İ + apply {s {binary scan [binary format a $s] c x; list $x [scan $s$s %c%c]}} İ } {48 {304 304}} test execute-10.2 {Bug 2802881} -setup { interp create child diff --git a/tests/expr-old.test b/tests/expr-old.test index 2401bd4..7274851 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -25,7 +25,6 @@ testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] @@ -950,7 +949,7 @@ test expr-old-36.1 {ExprLooksLikeInt procedure} -body { test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number "0o289" as operand of "+"}} +} {1 {can't use non-numeric string "0o289" as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -1002,7 +1001,7 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} { test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number "0o99 " as operand of "+"}} +} {1 {can't use non-numeric string "0o99 " as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} diff --git a/tests/expr.test b/tests/expr.test index 2c1dc21..f2c7ae6 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -16,13 +16,11 @@ if {"::tcltest" ni [namespace children]} { } ::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] -testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] # Big test for correct ordering of data in [expr] @@ -853,7 +851,7 @@ test expr-21.21 {non-numeric boolean variables} { test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use empty string "" as operand of "!"}} +} {1 {can't use non-numeric string "" as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { @@ -7454,43 +7452,45 @@ test expr-62.10 {TIP 582: comments can go inside function calls} { (1,2)} } 2 -# Bug e3dcab1d14 -proc do-one-test-expr-63 {e p float athreshold} { - # e - power of 2 to test - # p - tcl_precision to test with - # float - floating point value 2**-$p - # athreshold - tolerable absolute error (1/2 decimal digit in - # least significant place plus 1/2 least significant bit) - set trouble {} - set ::tcl_precision $p - set xfmt x[expr $float] - set ::tcl_precision 0 - set fmt [string range $xfmt 1 end] - set aerror [expr {abs($fmt - $float)}] - if {$aerror > $athreshold} { - return "Result $fmt is more than $athreshold away from $float" - } else { - return {} - } -} - -proc run-test-expr-63 {} { - for {set e 0} {$e <= 1023} {incr e} { - set pt [expr {floor($e*log(2)/log(10))}] - for {set p 6} {$p <= 17} {incr p} { - set athreshold [expr {0.5*10.0**-($pt+$p) + 2.0**-($e+53)}] - set numer [expr {5**$e}] - set xfloat x[expr {2.**-$e}] - set float [string range $xfloat 1 end] - test expr-63.$p.$e "convert 2**-$e to decimal at precision $p" { - do-one-test-expr-63 $e $p $float $athreshold - } {} - } - } - rename do-one-test-expr-63 {} - rename run-test-expr-63 {} -} -run-test-expr-63 +# Bug e3dcab1d14 TODO: Need to work out a test case that fails +# without tcl_precision, which has been eliminated in 9.0 + +# proc do-one-test-expr-63 {e p float athreshold} { +# # e - power of 2 to test +# # p - tcl_precision to test wuth +# # float - floating point value 2**-$p +# # athreshold - tolerable absolute error (1/2 decimal digit in +# # least significant place plus 1/2 least significant bit) +# set trouble {} +# set ::tcl_precision $p +# set xfmt x[expr $float] +# set ::tcl_precision 0 +# set fmt [string range $xfmt 1 end] +# set aerror [expr {abs($fmt - $float)}] +# if {$aerror > $athreshold} { +# return "Result $fmt is more than $athreshold away from $float" +# } else { +# return {} +# } +# } + +# proc run-test-expr-63 {} { +# for {set e 0} {$e <= 1023} {incr e} { +# set pt [expr {floor($e*log(2)/log(10))}] +# for {set p 6} {$p <= 17} {incr p} { +# set athreshold [expr {0.5*10.0**-($pt+$p) + 2.0**-($e+53)}] +# set numer [expr {5**$e}] +# set xfloat x[expr {2.**-$e}] +# set float [string range $xfloat 1 end] +# test expr-63.$p.$e "convert 2**-$e to decimal at precision $p" { +# do-one-test-expr-63 $e $p $float $athreshold +# } {} +# } +# } +# rename do-one-test-expr-63 {} +# rename run-test-expr-63 {} +# } +# run-test-expr-63 # cleanup unset -nocomplain a diff --git a/tests/fCmd.test b/tests/fCmd.test index 2469762..9940192 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -102,6 +102,14 @@ if {[testConstraint unix]} { set user "root" } } +if {[testConstraint win]} { + catch { + set user $::env(USERNAME) + } + if {$user eq ""} { + set user Administrator + } +} # Try getting a lower case glob pattern that will match the home directory of # a given user to test ~user and [file tildeexpand ~user]. Note this may not @@ -167,6 +175,10 @@ proc checkcontent {file matchString} { } proc openup {path} { + # Double check for inadvertent ~ -> home directory mapping + if {[string match ~* $path]} { + set file ./$path + } testchmod 0o777 $path if {[file isdirectory $path]} { catch { @@ -182,9 +194,13 @@ proc cleanup {args} { foreach p [concat $wd $args] { set x "" catch { - set x [glob -directory $p tf* td*] + set x [glob -directory $p tf* td* ~*] } foreach file $x { + # Double check for inadvertent ~ -> home directory mapping + if {[string match ~* $file]} { + set file ./$file + } if { [catch {file delete -force -- $file}] && [testConstraint testchmod] @@ -224,6 +240,43 @@ test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { file rename tf1 tf2 glob tf* } -result {tf2} +test fCmd-1.2 {TclFileRenameCmd when target is ~} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~ +} -body { + file rename tf1 ~ + file isfile ~ +} -result 1 +test fCmd-1.3 {TclFileRenameCmd when target is ~user} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~$user +} -body { + file rename tf1 ~$user + file isfile ~$user +} -result 1 +test fCmd-1.4 {TclFileRenameCmd when source is ~} -setup { + cleanup + createfile ./~ +} -cleanup { + file delete ./~ +} -body { + file rename ~ tf1 + list [file exists ~] [file exists tf1] +} -result {0 1} +test fCmd-1.5 {TclFileRenameCmd when source is ~user} -setup { + cleanup + createfile ./~$user +} -cleanup { + file delete ./~$user +} -body { + file rename ~$user tf1 + list [file exists ~$user] [file exists tf1] +} -result {0 1} + test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { cleanup @@ -232,6 +285,42 @@ test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { file copy tf1 tf2 lsort [glob tf*] } -result {tf1 tf2} +test fCmd-2.2 {TclFileCopyCmd when target is ~} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~ +} -body { + file copy tf1 ~ + list [file exists tf1] [file exists ~] +} -result {1 1} +test fCmd-2.3 {TclFileCopyCmd when target is ~user} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~$user +} -body { + file copy tf1 ~$user + list [file exists tf1] [file exists ~$user] +} -result {1 1} +test fCmd-2.4 {TclFileCopyCmd when source is ~} -setup { + cleanup + createfile ./~ +} -cleanup { + file delete ./~ +} -body { + file copy ~ tf1 + list [file exists ~] [file exists tf1] +} -result {1 1} +test fCmd-2.5 {TclFileCopyCmd when source is ~user} -setup { + cleanup + createfile ./~$user +} -cleanup { + file delete ./~$user +} -body { + file copy ~$user tf1 + list [file exists ~$user] [file exists tf1] +} -result {1 1} test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body { file rename -xyz @@ -241,7 +330,7 @@ test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body { } -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"} test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} -constraints {notRoot} -body { file rename xyz ~_totally_bogus_user -} -returnCodes error -result {user "_totally_bogus_user" doesn't exist} +} -returnCodes error -result {error renaming "xyz": no such file or directory} test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -315,7 +404,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup { } -constraints {notRoot} -returnCodes error -body { file mkdir td1 file rename ~_totally_bogus_user td1 -} -result {user "_totally_bogus_user" doesn't exist} +} -result {error renaming "~_totally_bogus_user": no such file or directory} test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup { cleanup } -constraints {notRoot unixOrWin} -returnCodes error -body { @@ -353,11 +442,17 @@ test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} -setup { catch {file mkdir td1 td2 tf1 td3 td4} glob td1 td2 tf1 td3 td4 } -result {td1 td2 tf1} -test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} -setup { +test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { + list [file isdir ~] [file mkdir ~] [file isdir ~] +} -result {0 {} 1} +test fCmd-4.4.1 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup { + cleanup +} -constraints {notRoot} -body { file mkdir ~_totally_bogus_user -} -result {user "_totally_bogus_user" doesn't exist} + file isdir ~_totally_bogus_user +} -result 1 test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\x00'} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -465,15 +560,16 @@ test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { catch {file delete tf1 td1 $root tf2} list [file exists tf1] [file exists tf2] [file exists td1] } -cleanup {cleanup} -result {0 1 0} -test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} -constraints {notRoot} -body { +test fCmd-5.6 { + TclFileDeleteCmd: Tcl_TranslateFileName treats ~user as normal char +} -constraints {notRoot} -body { file delete ~_totally_bogus_user -} -returnCodes error -result {user "_totally_bogus_user" doesn't exist} -test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} -setup { - catch {file delete ~/tf1} +} -result {} +test fCmd-5.7 { + TclFileDeleteCmd: Tcl_TranslateFileName treats ~ as normal char } -constraints {notRoot} -body { createfile ~/tf1 - file delete ~/tf1 -} -result {} +} -returnCodes error -result {couldn't open "~/tf1": no such file or directory} test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} -setup { cleanup } -constraints {notRoot} -body { @@ -672,37 +768,37 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { - file mkdir ~/td1/td2 - set td1name [file join [file dirname ~] [file tail ~] td1] + file mkdir [file home]/td1/td2 + set td1name [file join [file dirname [file home]] [file tail [file home]] td1] file attributes $td1name -permissions 0 - file copy ~/td1 td1 + file copy [file home]/td1 td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 - file delete -force ~/td1 -} -result {error copying "~/td1": permission denied} + file delete -force [file home]/td1 +} -result "error copying \"[file home]/td1\": permission denied" test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir td2 - file mkdir ~/td1 - set td1name [file join [file dirname ~] [file tail ~] td1] + file mkdir [file home]/td1 + set td1name [file join [file dirname [file home]] [file tail [file home]] td1] file attributes $td1name -permissions 0 - file copy td2 ~/td1 + file copy td2 [file home]/td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 - file delete -force ~/td1 -} -result {error copying "td2" to "~/td1/td2": permission denied} + file delete -force [file home]/td1 +} -result "error copying \"td2\" to \"[file home]/td1/td2\": permission denied" test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { cleanup } -constraints {unix notRoot} -body { - file mkdir ~/td1/td2 - set td2name [file join [file dirname ~] [file tail ~] td1 td2] + file mkdir [file home]/td1/td2 + set td2name [file join [file dirname [file home]] [file tail [file home]] td1 td2] file attributes $td2name -permissions 0 - file copy ~/td1 td1 + file copy [file home]/td1 td1 } -returnCodes error -cleanup { file attributes $td2name -permissions 0o755 - file delete -force ~/td1 -} -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" + file delete -force [file home]/td1 +} -result "error copying \"[file home]/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {notRoot xdev} -returnCodes error -body { @@ -778,15 +874,15 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { } -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { createfile -- createfile -force file delete -force -force -- -- -force glob -- -- -force -} -result {no files matched glob patterns "-- -force"} +} -result {} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ - -constraints {unix notRoot knownBug} -body { + -constraints {unix notRoot knownBug tildeexpansion} -body { # Labeled knownBug because it is dangerous [Bug: 3881] file mkdir td1 file attr td1 -perm 0o40000 @@ -797,11 +893,11 @@ test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ -constraints {unix notRoot} -body { string equal [file tail ~$user] ~$user -} -result 0 +} -result 1 test fCmd-8.3 {file copy and path translation: ensure correct error} -body { - file copy ~ [file join this file doesnt exist] + file copy [file home] [file join this file doesnt exist] } -returnCodes error -result [subst \ - {error copying "~" to "[file join this file doesnt exist]": no such file or directory}] + {error copying "[file home]" to "[file join this file doesnt exist]": no such file or directory}] test fCmd-9.1 {file rename: comprehensive: EACCES} -setup { cleanup @@ -943,9 +1039,9 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { testchmod 0o444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] - list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ + list [glob tf*] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] -} -result [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +} -result [subst {{} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { cleanup } -constraints {notRoot testchmod} -body { @@ -1553,9 +1649,11 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup { # # Coverage tests for TclMkdirCmd() # + +# ~ is no longer a special char. Need a test case where translation fails. test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup { set temp $::env(HOME) -} -constraints {notRoot} -body { +} -constraints {notRoot TODO} -body { global env unset env(HOME) catch {file mkdir ~/tfa} @@ -1654,9 +1752,10 @@ test fCmd-16.4 {accept zero files (TIP 323)} -body { test fCmd-16.5 {accept zero files (TIP 323)} -body { file delete -- } -result {} +# ~ is no longer a special char. Need a test case where translation fails. test fCmd-16.6 {delete: source filename translation failing} -setup { set temp $::env(HOME) -} -constraints {notRoot} -body { +} -constraints {notRoot TODO} -body { global env unset env(HOME) catch {file delete ~/tfa} @@ -2282,7 +2381,7 @@ test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} -setup { file attributes ~_totally_bogus_user } -returnCodes error -cleanup { testsetplatform $platform -} -result {user "_totally_bogus_user" doesn't exist} +} -result {could not read "~_totally_bogus_user": no such file or directory} test fCmd-27.3 {TclFileAttrsCmd - all attributes} -setup { catch {file delete -force -- foo.tmp} } -body { diff --git a/tests/fileName.test b/tests/fileName.test index b147bd7..46f1c5e 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -72,15 +72,15 @@ test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} { test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~ -} absolute +} relative test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~/foo -} absolute +} relative test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~foo -} absolute +} relative test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ./~foo @@ -137,15 +137,15 @@ test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} { test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~foo -} absolute +} relative test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~ -} absolute +} relative test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~/foo -} absolute +} relative test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ./~foo @@ -214,11 +214,11 @@ test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar -} {~foo ./~bar} +} {~foo ~bar} test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar/~baz -} {~foo ./~bar ./~baz} +} {~foo ~bar ~baz} test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar~/baz @@ -358,11 +358,11 @@ test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} { test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar -} {~foo ./~bar} +} {~foo ~bar} test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar/~baz -} {~foo ./~bar ./~baz} +} {~foo ~bar ~baz} test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo/bar~/baz @@ -370,7 +370,7 @@ test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:~foo -} {c: ./~foo} +} {c: ~foo} test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix @@ -415,7 +415,7 @@ test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~a ~b -} {~b} +} {~a/~b} test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a b @@ -423,11 +423,11 @@ test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ~b -} {~b} +} {./~a/~b} test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ./~b -} {./~a/~b} +} {./~a/./~b} test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . b @@ -435,7 +435,7 @@ test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . ./~b -} {a/./~b} +} {a/././~b} test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b @@ -491,11 +491,11 @@ test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} { test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ ./~foo -} {~/~foo} +} {~/./~foo} test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join / ~foo -} {~foo} +} {/~foo} test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ./a/ b c @@ -601,7 +601,7 @@ test filename-10.6 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {/home/test/foo} +} -result {~/foo} test filename-10.7 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -609,9 +609,9 @@ test filename-10.7 {Tcl_TranslateFileName} -setup { unset env(HOME) testsetplatform unix testtranslatefilename ~/foo -} -returnCodes error -cleanup { +} -cleanup { set env(HOME) $temp -} -result {couldn't find HOME environment variable to expand path} +} -result {~/foo} test filename-10.8 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -621,7 +621,7 @@ test filename-10.8 {Tcl_TranslateFileName} -setup { testtranslatefilename ~ } -cleanup { set env(HOME) $temp -} -result {/home/test} +} -result {~} test filename-10.9 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -631,7 +631,7 @@ test filename-10.9 {Tcl_TranslateFileName} -setup { testtranslatefilename ~ } -cleanup { set env(HOME) $temp -} -result {/home/test} +} -result {~} test filename-10.10 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -641,7 +641,7 @@ test filename-10.10 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {/home/test/foo} +} -result {~/foo} test filename-10.17 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -651,7 +651,7 @@ test filename-10.17 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {\home\foo} +} -result {~\foo} test filename-10.18 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -661,7 +661,7 @@ test filename-10.18 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo\\bar } -cleanup { set env(HOME) $temp -} -result {\home\foo\bar} +} -result {~\foo\bar} test filename-10.19 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -671,11 +671,11 @@ test filename-10.19 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {c:foo} -test filename-10.20 {Tcl_TranslateFileName} -returnCodes error -body { +} -result {~\foo} +test filename-10.20 {Tcl_TranslateFileName} -body { testtranslatefilename ~blorp/foo } -constraints {testtranslatefilename testtranslatefilename} \ - -result {user "blorp" doesn't exist} + -result {~blorp\foo} test filename-10.21 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -685,7 +685,7 @@ test filename-10.21 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {c:\foo} +} -result {~\foo} test filename-10.22 {Tcl_TranslateFileName} -body { testsetplatform windows testtranslatefilename foo//bar @@ -702,9 +702,9 @@ test filename-10.24 {Tcl_TranslateFileName} -body { testtranslatefilename ~ouster/foo } -result {/home/ouster/foo} -constraints {nonPortable testtranslatefilename} -test filename-11.1 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.1 {Tcl_GlobCmd} -body { glob -} -result {no files matched glob patterns ""} +} -result {} test filename-11.2 {Tcl_GlobCmd} -returnCodes error -body { glob -gorp } -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --} @@ -714,45 +714,46 @@ test filename-11.3 {Tcl_GlobCmd} -body { test filename-11.4 {Tcl_GlobCmd} -body { glob -nocomplain } -result {} -test filename-11.5 {Tcl_GlobCmd} -returnCodes error -body { - glob -nocomplain * ~xyqrszzz -} -result {user "xyqrszzz" doesn't exist} -test filename-11.6 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.5 {Tcl_GlobCmd} -body { + # Should not error out because of ~ + catch {glob -nocomplain * ~xyqrszzz} +} -result 0 +test filename-11.6 {Tcl_GlobCmd} -body { glob ~xyqrszzz -} -result {user "xyqrszzz" doesn't exist} -test filename-11.7 {Tcl_GlobCmd} -returnCodes error -body { +} -result {} +test filename-11.7 {Tcl_GlobCmd} -body { glob -- -nocomplain -} -result {no files matched glob pattern "-nocomplain"} +} -result {} test filename-11.8 {Tcl_GlobCmd} -body { glob -nocomplain -- -nocomplain } -result {} test filename-11.9 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~\\xyqrszzz/bar -} -returnCodes error -result {user "\xyqrszzz" doesn't exist} +} -result {} test filename-11.10 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob -nocomplain ~\\xyqrszzz/bar -} -returnCodes error -result {user "\xyqrszzz" doesn't exist} +} -result {} test filename-11.11 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~xyqrszzz\\/\\bar -} -returnCodes error -result {user "xyqrszzz" doesn't exist} +} -result {} test filename-11.12 {Tcl_GlobCmd} -constraints {testsetplatform} -setup { testsetplatform unix set home $env(HOME) } -body { unset env(HOME) glob ~/* -} -returnCodes error -cleanup { +} -cleanup { set env(HOME) $home -} -result {couldn't find HOME environment variable to expand path} +} -result {} if {[testConstraint testsetplatform]} { testsetplatform $platform } -test filename-11.13 {Tcl_GlobCmd} { +test filename-11.13 {Tcl_GlobCmd} -body { file join [lindex [glob ~] 0] -} [file join $env(HOME)] +} -result {} set oldpwd [pwd] set oldhome $env(HOME) catch {cd [makeDirectory tcl[pid]]} @@ -770,12 +771,12 @@ touch globTest/a1/b1/x2.c touch globTest/a1/b2/y2.c touch globTest/.1 touch globTest/x,z1.c -test filename-11.14 {Tcl_GlobCmd} { +test filename-11.14 {Tcl_GlobCmd} -body { glob ~/globTest -} [list [file join $env(HOME) globTest]] -test filename-11.15 {Tcl_GlobCmd} { +} -result {} +test filename-11.15 {Tcl_GlobCmd} -body { glob ~\\/globTest -} [list [file join $env(HOME) globTest]] +} -result {} test filename-11.16 {Tcl_GlobCmd} { glob globTest } {globTest} @@ -1098,42 +1099,42 @@ file delete -force $tildeglobname set globname globTest unset horribleglobname tildeglobname -test filename-12.1 {simple globbing} {unixOrWin} { +test filename-12.1 {simple globbing} -constraints {unixOrWin} -body { glob {} -} {.} +} -result {.} test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body { glob -types f {} -} -returnCodes error -result {no files matched glob pattern ""} -test filename-12.1.2 {simple globbing} {unixOrWin} { +} -result {} +test filename-12.1.2 {simple globbing} -constraints {unixOrWin} -body { glob -types d {} -} {.} -test filename-12.1.3 {simple globbing} {unix} { +} -result {.} +test filename-12.1.3 {simple globbing} -constraints {unix} -body { glob -types hidden {} -} {.} +} -result {.} test filename-12.1.4 {simple globbing} -constraints {win} -body { glob -types hidden {} -} -returnCodes error -result {no files matched glob pattern ""} +} -result {} test filename-12.1.5 {simple globbing} -constraints {win} -body { glob -types hidden c:/ -} -returnCodes error -result {no files matched glob pattern "c:/"} -test filename-12.1.6 {simple globbing} {win} { +} -result {} +test filename-12.1.6 {simple globbing} -constraints {win} -body { glob c:/ -} {c:/} -test filename-12.3 {simple globbing} { +} -result {c:/} +test filename-12.3 {simple globbing} -body { glob -nocomplain \{a1,a2\} -} {} +} -result {} set globPreResult globTest/ set x1 x1.c set y1 y1.c -test filename-12.4 {simple globbing} {unixOrWin} { +test filename-12.4 {simple globbing} -constraints {unixOrWin} -body { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] -} "$globPreResult$x1 $globPreResult$y1" -test filename-12.5 {simple globbing} { +} -result "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} -body { glob globTest\\/x1.c -} "$globPreResult$x1" -test filename-12.6 {simple globbing} { +} -result "$globPreResult$x1" +test filename-12.6 {simple globbing} -body { glob globTest\\/\\x1.c -} "$globPreResult$x1" +} -result "$globPreResult$x1" test filename-12.7 {globbing at filesystem root} -constraints {unix} -body { list [glob -nocomplain /*] [glob -path / *] } -match compareWords -result equal @@ -1253,7 +1254,7 @@ test filename-14.17 {asterisks, question marks, and brackets} -setup { set temp $env(HOME) } -body { set env(HOME) [file join $env(HOME) globTest] - glob ~/z* + glob [file home]/z* } -cleanup { set env(HOME) $temp } -result [list [file join $env(HOME) globTest z1.c]] @@ -1265,10 +1266,10 @@ test filename-14.20 {asterisks, question marks, and brackets} { } {} test filename-14.21 {asterisks, question marks, and brackets} -body { glob globTest/*/gorp -} -returnCodes error -result {no files matched glob pattern "globTest/*/gorp"} +} -result {} test filename-14.22 {asterisks, question marks, and brackets} -body { glob goo/* x*z foo?q -} -returnCodes error -result {no files matched glob patterns "goo/* x*z foo?q"} +} -result {} test filename-14.23 {slash globbing} {unix} { glob / } / @@ -1350,11 +1351,10 @@ test filename-15.4 {unix specific no complain: no errors, good result} \ glob -nocomplain ~ouster ~foo ~welch } {/home/ouster /home/welch} test filename-15.4.1 {no complain: errors, sequencing} { - # test used to fail because if an error occurs, the interp's result is - # reset... But, the sequence means we throw a different error first. + # ~xxx no longer expanded so errors about unknown users should not occur list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \ [catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2 -} {1 {user "wontexist" doesn't exist} 1 {user "blahxyz" doesn't exist}} +} {0 {} 0 {}} test filename-15.4.2 {no complain: errors, sequencing} -body { # test used to fail because if an error occurs, the interp's result is # reset... @@ -1364,20 +1364,12 @@ test filename-15.4.2 {no complain: errors, sequencing} -body { test filename-15.5 {unix specific globbing} {unix nonPortable} { glob ~ouster/.csh* } "/home/ouster/.cshrc" -touch globTest/odd\\\[\]*?\{\}name -test filename-15.6 {unix specific globbing} -constraints {unix} -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name - glob ~ -} -cleanup { - set env(HOME) $temp -} -result [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name] -catch {file delete -force globTest/odd\\\[\]*?\{\}name} -test filename-15.7 {win specific globbing} -constraints {win} -body { +# 15.6 removed. It checked if glob ~ returned valid information if +# home directory contained glob chars. Since ~ expansion is no longer +# supported, the test was meaningless +test filename-15.7 {glob tilde} -body { glob ~ -} -match regexp -result {[^/]$} +} -result {} test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -setup { global env set temp $env(HOME) @@ -1388,7 +1380,7 @@ test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -se } -cleanup { set env(HOME) $temp catch {file delete -force $env(HOME)/globTest/anyname} -} -result [list [lindex [glob ~] 0]/globTest/anyname] +} -result {} # The following tests are only valid for Windows systems. set oldDir [pwd] @@ -1567,7 +1559,7 @@ test fileName-20.5 {Bug 2837800} -setup { test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] - makeFile {} test ~ + makeFile {} test [file home] set dd [makeDirectory isolate] set d [makeDirectory ./~ $dd] set savewd [pwd] @@ -1578,7 +1570,7 @@ test fileName-20.6 {Bug 2837800} -setup { cd $savewd removeDirectory ./~ $dd removeDirectory isolate - removeFile test ~ + removeFile test [file home] } -result {} test fileName-20.7 {Bug 2806250} -setup { set savewd [pwd] @@ -1603,34 +1595,42 @@ test fileName-20.8 {Bug 2806250} -setup { removeFile ./~test $d removeDirectory isolate cd $savewd -} -result ./~test -test fileName-20.9 {globbing for special chars} -setup { - makeFile {} test ~ - set d [makeDirectory isolate] - set savewd [pwd] - cd $d -} -body { - glob -nocomplain -directory ~ test -} -cleanup { - cd $savewd - removeDirectory isolate - removeFile test ~ -} -result ~/test +} -result ~test test fileName-20.10 {globbing for special chars} -setup { - set s [makeDirectory sub ~] + set s [makeDirectory sub [file home]] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] set savewd [pwd] cd $d } -body { - glob -nocomplain -directory ~ -join * fileName-20.10 + glob -nocomplain -directory [file home] -join * fileName-20.10 } -cleanup { cd $savewd removeDirectory isolate removeFile fileName-20.10 $s - removeDirectory sub ~ -} -result ~/sub/fileName-20.10 - + removeDirectory sub [file home] +} -result [file home]/sub/fileName-20.10 +test fileName-20.11 {glob dir with undecodable file names} -setup { + # Specifically use /tmp as on WSL [temporaryDirectory] + # on NTFS prevents creation of arbitrary byte sequences in names. + set prevDir [pwd] + set testDir /tmp/tcltest/fileName-20.11 + file delete -force $testDir; # Clear it + file mkdir $testDir + cd $testDir + set prevEnc [encoding system] + # Create a file name that is invalid if interpreted as utf-8 + encoding system iso8859-1 + close [open \xe9 w] +} -cleanup { + encoding system $prevEnc + cd $prevDir + file delete -force $testDir +} -constraints {unix knownBug} -body { + set result [file exists [lindex [glob *] 0]] + encoding system utf-8 + lappend result [file exists [lindex [glob *] 0]] +} -result {1 1} apply [list {} { test fileName-6d4e9d1af5bf5b7d { diff --git a/tests/fileSystem.test b/tests/fileSystem.test index e62f8d9..a6238c2 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -268,24 +268,23 @@ file delete -force [file join dir.dir dirinside.link] removeFile [file join dir.dir inside.file] removeDirectory [file join dir.dir dirinside.dir] removeDirectory dir.dir -test filesystem-1.30 {normalisation of nonexistent user} -body { +test filesystem-1.30 { + normalisation of nonexistent user - verify no tilde expansion +} -body { file normalize ~noonewiththisname -} -returnCodes error -result {user "noonewiththisname" doesn't exist} +} -result [file join [pwd] ~noonewiththisname] test filesystem-1.30.1 {normalisation of existing user} -body { - catch {file normalize ~$::tcl_platform(user)} -} -result {0} -test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { - file normalize ~nonexistentuser@nonexistentdomain -} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} + file normalize ~$::tcl_platform(user) +} -result [file join [pwd] ~$::tcl_platform(user)] test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup { set oldhome $::env(HOME) - set olduserhome [file normalize ~$::tcl_platform(user)] + set olduserhome [file home $::tcl_platform(user)] set ::env(HOME) [file join $oldhome temp] } -cleanup { set ::env(HOME) $oldhome } -body { - list [string equal [file normalize ~] $::env(HOME)] \ - [string equal $olduserhome [file normalize ~$::tcl_platform(user)]] + list [string equal [file home] $::env(HOME)] \ + [string equal $olduserhome [file home $::tcl_platform(user)]] } -result {1 1} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix @@ -484,7 +483,10 @@ test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { return $filesystemReport } -match glob -result {*{matchindirectory *}*} -test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { +# This test is meaningless if there is no tilde expansion +test filesystem-5.1 {cache and ~} -constraints { + testfilesystem tildeexpansion +} -setup { set orig $::env(HOME) } -body { set ::env(HOME) /foo/bar/blah @@ -964,7 +966,7 @@ test filesystem-9.7 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +} -result {1 0 ~testNotExist ~testNotExist 1 0 ~testNotExist 0 ~testNotExist} test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] @@ -982,7 +984,7 @@ test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +} -result {~testNotExist ~testNotExist 0 ~testNotExist 0 ~testNotExist} test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] @@ -1000,7 +1002,7 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {0 0 0 0 1} +} -result {0 1 0 1 1} # ---------------------------------------------------------------------- diff --git a/tests/get.test b/tests/get.test index 0281760..eff4fa0 100644 --- a/tests/get.test +++ b/tests/get.test @@ -99,25 +99,18 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 51 52 46} +} {44 44 44 44 54 54 52 46} -test get-3.4 {Tcl_GetDouble with iffy numbers} {testdoubleobj} { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "- 0" "-0" "0o12" "0b10" "2_0.3_4e+1_5" _1.0e+2 1_.0e+2 1._0e+2 1.0_e+2 1.0e_+2 1.0e+_2 1.0e+2_ 1_1.0e+0_2 2__2.0e+2__2 54321________} { +test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10" "2_0.3_4e+1_5" _1.0e+2 1_.0e+2 1._0e+2 1.0_e+2 1.0e_+2 1.0e+_2 1.0e+2_ 1_1.0e+0_2 2__2.0e+2__2 54321________} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}} - -test get-3.4.1 {Tcl_GetDouble with iffy numbers} {testdoubleobj deprecated} { - lmap x {"09"} { - catch {testdoubleobj set 1 $x} x - set x - } -} {{expected floating-point number but got "09" (looks like invalid octal number)}} +} {0.0 0.0 0.0 0.0 0.0 9.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0 20340000000000000.0 {expected floating-point number but got "_1.0e+2"} {expected floating-point number but got "1_.0e+2"} {expected floating-point number but got "1._0e+2"} {expected floating-point number but got "1.0_e+2"} {expected floating-point number but got "1.0e_+2"} {expected floating-point number but got "1.0e+_2"} {expected floating-point number but got "1.0e+2_"} 1100.0 2.2e+23 {expected floating-point number but got "54321________"}} test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint { lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x0_a " 0b1111_1111 " 0_07 " " 0o1_0 " " 0b_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 0x_b 0o_2_0 0o2__3_4} { diff --git a/tests/http.test b/tests/http.test index c77dceb..f7bb723 100644 --- a/tests/http.test +++ b/tests/http.test @@ -15,7 +15,6 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } -source [file join [file dirname [info script]] tcltests.tcl] package require http 2.10 #http::register http 80 ::socket @@ -739,8 +738,10 @@ test http-7.3.$ThreadLevel {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result {unknown encoding ""} -test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup { +test http-7.4.$ThreadLevel {http::formatQuery} -setup { set enc [http::config -urlencoding] +} -constraints { + knownProfileBug } -body { # this would be reverting to http <=2.4 behavior w/o errors # with Tcl 8.x (unknown chars become '?'), generating a @@ -749,7 +750,7 @@ test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup { http::mapReply "∈" } -cleanup { http::config -urlencoding $enc -} -result {%3F} +} -errorCode {TCL ENCODING ILLEGALSEQUENCE 0} -result {unexpected character at index 0: 'U+002208'} package require tcl::idna 1.0 diff --git a/tests/indexObj.test b/tests/indexObj.test index 1cf782a..f157637 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -19,6 +19,8 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testindexobj [llength [info commands testindexobj]] testConstraint testgetintforindex [llength [info commands testgetintforindex]] testConstraint testparseargs [llength [info commands testparseargs]] +testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] +testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] test indexObj-1.1 {exact match} testindexobj { testindexobj 1 1 xyz abc def xyz alm @@ -184,7 +186,7 @@ test indexObj-8.4 {Tcl_GetIntForIndex INT_MAX} testgetintforindex { } 2147483647 test indexObj-8.5 {Tcl_GetIntForIndex INT_MAX+1} testgetintforindex { testgetintforindex 2147483648 0 -} 2147483647 +} [expr {[testConstraint has64BitLengths] ? 2147483648 : 2147483647}] test indexObj-8.6 {Tcl_GetIntForIndex end-1} testgetintforindex { testgetintforindex end-1 2147483646 } 2147483645 @@ -209,18 +211,19 @@ test indexObj-8.12 {Tcl_GetIntForIndex end} testgetintforindex { test indexObj-8.13 {Tcl_GetIntForIndex end} testgetintforindex { testgetintforindex end -2 } -2 -test indexObj-8.14 {Tcl_GetIntForIndex end+1} testgetintforindex { +test indexObj-8.14 {Tcl_GetIntForIndex end+1} -constraints { + testgetintforindex has64BitLengths +} -body { testgetintforindex end+1 -1 -} 2147483647 +} -result 9223372036854775807 +test indexObj-8.14.32bits {Tcl_GetIntForIndex end+1} -constraints { + testgetintforindex has32BitLengths +} -body { + testgetintforindex end+1 -1 +} -result 2147483647 test indexObj-8.15 {Tcl_GetIntForIndex end+1} testgetintforindex { testgetintforindex end+1 -2 } -1 -test indexObj-8.16 {Tcl_GetIntForIndex integer} testgetintforindex { - testgetintforindex -1 -1 -} -2147483648 -test indexObj-8.17 {Tcl_GetIntForIndex integer} testgetintforindex { - testgetintforindex -2 -1 -} -2147483648 # cleanup ::tcltest::cleanupTests diff --git a/tests/info.test b/tests/info.test index ef41bdf..6c49b2d 100644 --- a/tests/info.test +++ b/tests/info.test @@ -20,9 +20,9 @@ if {{::tcltest} ni [namespace children]} { namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands -source [file join [file dirname [info script]] tcltests.tcl] catch [list package require -exact tcl::test [info patchlevel]] testConstraint zlib [llength [info commands zlib]] + # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -101,10 +101,10 @@ test info-2.5 {info body option, returning bytecompiled bodies} -body { # Fix for problem tested for in info-2.5 caused problems when # procedure body had no string rep (i.e. was not yet bytecode) # causing an empty string to be returned [Bug #545644] -test info-2.6 {info body option, returning list bodies} deprecated { +test info-2.6 {info body option, returning list bodies} { proc foo args [list subst bar] - list [string bytelength [info body foo]] \ - [foo; string bytelength [info body foo]] + list [string length [info body foo]] \ + [foo; string length [info body foo]] } {9 9} proc testinfocmdcount {} { @@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, constant, consts, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### diff --git a/tests/interp.test b/tests/interp.test index fa263e2..30570bb 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -2414,21 +2414,21 @@ test interp-29.1.4 {interp recursionlimit argument checking} { interp delete moo list $result $msg } {1 {expected integer but got "bar"}} -test interp-29.1.5 {interp recursionlimit argument checking} { +test interp-29.1.5 {interp recursionlimit argument checking} -body { interp create moo set result [catch {interp recursionlimit moo 0} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} -test interp-29.1.6 {interp recursionlimit argument checking} { +} -match glob -result {1 {recursion limit must be > 0}} +test interp-29.1.6 {interp recursionlimit argument checking} -body { interp create moo set result [catch {interp recursionlimit moo -1} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} +} -match glob -result {1 {recursion limit must be > 0}} test interp-29.1.7 {interp recursionlimit argument checking} { interp create moo - set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg] + set result [catch {interp recursionlimit moo [expr {wide(1)<<64}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} @@ -2444,21 +2444,21 @@ test interp-29.1.9 {child recursionlimit argument checking} { interp delete moo list $result $msg } {1 {expected integer but got "foo"}} -test interp-29.1.10 {child recursionlimit argument checking} { +test interp-29.1.10 {child recursionlimit argument checking} -body { interp create moo set result [catch {moo recursionlimit 0} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} -test interp-29.1.11 {child recursionlimit argument checking} { +} -match glob -result {1 {recursion limit must be > 0}} +test interp-29.1.11 {child recursionlimit argument checking} -body { interp create moo set result [catch {moo recursionlimit -1} msg] interp delete moo list $result $msg -} {1 {recursion limit must be > 0}} +} -match glob -result {1 {recursion limit must be > 0}} test interp-29.1.12 {child recursionlimit argument checking} { interp create moo - set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] + set result [catch {moo recursionlimit [expr {wide(1)<<64}]} msg] interp delete moo list $result [string range $msg 0 35] } {1 {integer value too large to represent}} @@ -3339,7 +3339,7 @@ test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { interp delete $i lappend result $msg } -result {1 {time limit exceeded}} -test interp-34.11 {time limit extension in callbacks} -setup { +test interp-34.11 {time limit extension in callbacks} -constraints knownBug -setup { proc cb1 {i t} { global result lappend result cb1 @@ -3524,7 +3524,7 @@ test interp-35.19 {interp limit syntax} -body { interp limit $i time -seconds -1 } -cleanup { interp delete $i -} -match glob -returnCodes error -result {seconds must be between 0 and *} +} -returnCodes error -result {seconds must be non-negative} test interp-35.20 {interp limit syntax} -body { set i [interp create] interp limit $i time -millis foobar @@ -3536,7 +3536,7 @@ test interp-35.21 {interp limit syntax} -body { interp limit $i time -millis -1 } -cleanup { interp delete $i -} -match glob -returnCodes error -result {milliseconds must be between 0 and *} +} -returnCodes error -result {milliseconds must be non-negative} test interp-35.22 {interp time limits normalize milliseconds} -body { set i [interp create] interp limit $i time -seconds 1 -millis 1500 diff --git a/tests/io.test b/tests/io.test index c4e47ac..5c0e5aa 100644 --- a/tests/io.test +++ b/tests/io.test @@ -36,6 +36,7 @@ namespace eval ::tcl::test::io { } source [file join [file dirname [info script]] tcltests.tcl] +testConstraint pointerIs64bit [expr {$::tcl_platform(pointerSize) >= 8}] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] testConstraint testfevent [llength [info commands testfevent]] @@ -79,7 +80,7 @@ set path(cat) [makeFile { if {$argv != ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A" + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A fconfigure stdout -encoding binary -translation lf -buffering none fileevent $f readable "foo $f" proc foo {f} { @@ -196,6 +197,51 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { set sizes } {19 19 19 19 19} +proc testreadwrite {size {mode ""} args} { + set tmpfile [file join [temporaryDirectory] io-1.10.tmp] + set w [string repeat A $size] + try { + set fd [open $tmpfile w$mode] + try { + if {[llength $args]} { + fconfigure $fd {*}$args + } + puts -nonewline $fd $w + } finally { + close $fd + } + set fd [open $tmpfile r$mode] + try { + if {[llength $args]} { + fconfigure $fd {*}$args + } + set r [read $fd] + } finally { + close $fd + } + } finally { + file delete $tmpfile + } + string equal $w $r +} + +test io-1.10 {WriteChars: large file (> INT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + testreadwrite 0x80000000 +} -result 1 +test io-1.11 {WriteChars: large file (> UINT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + testreadwrite 0x100000000 "" -buffersize 1000000 +} -result 1 +test io-1.12 {WriteChars: large file (== UINT_MAX). Bug 90ff9b7f73} -constraints { + pointerIs64bit perf +} -body { + # *Exactly* UINT_MAX - separate bug from the general large file tests + testreadwrite 0xffffffff +} -result 1 + test io-2.1 {WriteBytes} { # loop until all bytes are written @@ -237,6 +283,25 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} { close $f lappend x [contents $path(test1)] } [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"] +test io-2.5 {WriteBytes: large file (> INT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + # Binary mode + testreadwrite 0x80000000 b +} -result 1 +test io-2.6 {WriteBytes: large file (> UINT_MAX). Bug 3d01d51bc4} -constraints { + pointerIs64bit perf +} -body { + # Binary mode + testreadwrite 0x100000000 b -buffersize 1000000 +} -result 1 +test io-2.7 {WriteBytes: large file (== UINT_MAX). Bug 90ff9b7f73} -constraints { + pointerIs64bit perf +} -body { + # *Exactly* UINT_MAX - separate bug from the general large file tests + testreadwrite 0xffffffff b +} -result 1 + test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written @@ -519,7 +584,7 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdef\x1Aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar "\x1A \x1A" + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -529,7 +594,7 @@ test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdefghijk\nwom\x1Abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar "\x1A \x1A" + fconfigure $f -eofchar \x1A set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -1038,7 +1103,7 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { puts -nonewline $f "123456\x1Ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar "\x1A \x1A" + fconfigure $f -eofchar \x1A set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1582,7 +1647,7 @@ test io-12.11 {ReadChars: multibyte chars split} -body { puts -nonewline $f [string repeat a 9]\xC2 close $f set f [open $path(test1)] - fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 11 + fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10 set in [read $f] close $f scan [string index $in end] %c @@ -2109,13 +2174,13 @@ test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} [list [list \x1A ""] {auto crlf}] +} {{} {auto crlf}} test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} {{{} {}} {auto lf}} +} {{} {auto lf}} set path(stdout) [makeFile {} stdout] test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] @@ -3398,7 +3463,7 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3410,11 +3475,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [read $f] close $f set c @@ -3431,7 +3496,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3451,7 +3516,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3529,7 +3594,7 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3543,7 +3608,7 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3557,7 +3622,7 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3571,7 +3636,7 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3585,7 +3650,7 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3599,7 +3664,7 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set c [string length [read $f]] set e [eof $f] close $f @@ -3932,7 +3997,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3947,11 +4012,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3971,7 +4036,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -3989,7 +4054,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4073,7 +4138,7 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4091,7 +4156,7 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4109,7 +4174,7 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4127,7 +4192,7 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4145,7 +4210,7 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -4163,7 +4228,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l "" lappend l [gets $f] lappend l [gets $f] @@ -5044,87 +5109,87 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {11 8 1} +} {10 8 1} test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f list $s $l $e -} {11 8 1} +} {10 8 1} test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] @@ -5134,7 +5199,7 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5149,7 +5214,7 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5164,7 +5229,7 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5179,7 +5244,7 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5194,7 +5259,7 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5209,7 +5274,7 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [read $f]] set e [eof $f] close $f @@ -5232,31 +5297,31 @@ test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} -result {9 8 1 13} +} -result {8 8 1 13} test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A puts $f {} close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} -result {2 1 1 13} +} -result {1 1 1 13} test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] @@ -5280,7 +5345,7 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5295,7 +5360,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5779,30 +5844,30 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix} -body { +test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix deprecated} -body { file delete $path(test1) set f1 [open $path(test1) w+] set l "" lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {ON GO} + fconfigure $f1 -eofchar {O {}} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {D D} + fconfigure $f1 -eofchar D lappend l [fconfigure $f1 -eofchar] close $f1 set l -} -result {{{} {}} {O G} {D D}} -test io-39.22a {Tcl_SetChannelOption, invariance} -body { +} -result {{} O D} +test io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -body { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] - fconfigure $f1 -eofchar {ON GO} + fconfigure $f1 -eofchar {O {}} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {D D} + fconfigure $f1 -eofchar D lappend l [fconfigure $f1 -eofchar] lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l -} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or writable, it should still have valid -eofchar and -translation options } { set l [list] @@ -5810,7 +5875,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] close $sock set l -} {{{}} auto} +} {{} auto} test io-39.24 {Tcl_SetChannelOption, server socket is not readable or writable so we can't change -eofchar or -translation } { set l [list] @@ -5819,7 +5884,7 @@ test io-39.24 {Tcl_SetChannelOption, server socket is not readable or lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] close $sock set l -} {{{}} auto} +} {{} auto} test io-40.1 {POSIX open access modes: RDWR} { file delete $path(test3) @@ -5988,7 +6053,7 @@ test io-40.17 {tilde substitution in open} { set x [list [catch {open ~/foo} msg] $msg] set ::env(HOME) $home set x -} {1 {couldn't find HOME environment variable to expand path}} +} {1 {couldn't open "~/foo": no such file or directory}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent foo} msg] $msg @@ -6562,7 +6627,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6590,7 +6655,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6618,7 +6683,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6646,7 +6711,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6674,7 +6739,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6702,7 +6767,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar "\x1A \x1A" + fconfigure $f -translation auto -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6730,7 +6795,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6758,7 +6823,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar "\x1A \x1A" + fconfigure $f -translation lf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6786,7 +6851,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6814,7 +6879,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar "\x1A \x1A" + fconfigure $f -translation cr -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6842,7 +6907,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6870,7 +6935,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar "\x1A \x1A" + fconfigure $f -translation crlf -eofchar \x1A fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -7449,10 +7514,7 @@ test io-52.9 {TclCopyChannel & encodings} {fcopy} { [file size $path(utf8-fcopy.txt)] \ [file size $path(utf8-rp.txt)] } {3 5 5} -test io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { - # encoding to binary (=> implies that the - # internal utf-8 is written) - +test io-52.10 {TclCopyChannel & encodings} -constraints fcopy -body { set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] @@ -7466,29 +7528,31 @@ test io-52.10 {TclCopyChannel & encodings} -constraints {fcopy notWinCI} -body { } -cleanup { close $in close $out -} -result 5 +} -returnCodes 1 -match glob -result {error writing "*":\ + invalid or incomplete multibyte or wide character} test io-52.11 {TclCopyChannel & encodings} -setup { set out [open $path(utf8-fcopy.txt) w] - fconfigure $out -encoding utf-8 -translation lf - puts $out "АА" + fconfigure $out -encoding utf-8 -translation lf -profile strict + puts $out АА close $out } -constraints {fcopy} -body { - # binary to encoding => the input has to be - # in utf-8 to make sense to the encoder - set in [open $path(utf8-fcopy.txt) r] set out [open $path(kyrillic.txt) w] - # -translation binary is also -encoding binary fconfigure $in -translation binary - fconfigure $out -encoding koi8-r -translation lf - - fcopy $in $out - close $in - close $out - - file size $path(kyrillic.txt) -} -result 3 + fconfigure $out -encoding koi8-r -translation lf -profile strict + catch {fcopy $in $out} cres copts + return $cres +} -cleanup { + if {$in in [chan names]} { + close $in + } + if {$out in [chan names]} { + close $out + } + catch {unset cres} +} -match glob -result {error writing "*": invalid or incomplete\ + multibyte or wide character} test io-52.12 {coverage of -translation auto} { file delete $path(test1) $path(test2) @@ -7783,6 +7847,29 @@ test io-52.23 {TclCopyChannel & encodings} -setup { unset ::s0 } -match glob -result {0 {error writing "file*": invalid or incomplete multibyte or wide character}} +test io-52.24 {fcopy -size should always be characters} -setup { + set out [open utf8-fcopy-52.24.txt w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + set in [open utf8-fcopy-52.24.txt r] + set out [open utf8-fcopy-52.24.out.txt w+] + + fconfigure $in -encoding utf-8 -profile tcl8 + fconfigure $out -encoding utf-8 -profile tcl8 + fcopy $in $out -size 1 + seek $out 0 + # a result of \xc3 means that only the first byte of the utf-8 encoding of + # Á made it into to the output file. + read $out +} -cleanup { + close $in + close $out + catch {file delete utf8-fcopy-52.24.txt} + catch {file delete utf8-fcopy-52.24.out.txt} +} -result Á + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] @@ -9445,10 +9532,11 @@ test io-75.9 {unrepresentable character write throws error in strict profile} -s } -match glob -result [list {A} {error writing "*":\ invalid or incomplete multibyte or wide character}] -# Incomplete sequence test. -# This error may IMHO only be detected with the close. -# But the read already returns the incomplete sequence. -test io-75.10 {incomplete multibyte encoding read is ignored} -setup { +test io-75.10 { + incomplete multibyte encoding read is not ignored because "binary" sets + profile to strict +} -setup { + set res {} set fn [makeFile {} io-75.10] set f [open $fn w+] fconfigure $f -encoding binary @@ -9457,14 +9545,21 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { seek $f 0 fconfigure $f -encoding utf-8 -buffering none } -body { + catch {read $f} errmsg + lappend res $errmsg + seek $f 0 + chan configure $f -profile tcl8 set d [read $f] binary scan $d H* hd - set hd + lappend res $hd + return $res } -cleanup { close $f removeFile io-75.10 - unset d hd -} -result 41c0 + unset result +} -match glob -result {{error reading "file*":\ + invalid or incomplete multibyte or wide character} 41c0} + # The current result returns the orphan byte as byte. # This may be expected due to special utf-8 handling. @@ -9492,7 +9587,11 @@ test io-75.11 {shiftjis encoding error read results in error (strict profile)} - } -match glob -result {41 1 {error reading "file*":\ invalid or incomplete multibyte or wide character} 0} -test io-75.12 {invalid utf-8 encoding read is ignored} -setup { +test io-75.12 { + invalid utf-8 encoding read is not ignored because setting the encoding to + "binary" also set the profile to strict +} -setup { + set res {} set fn [makeFile {} io-75.12] set f [open $fn w+] fconfigure $f -encoding binary @@ -9501,13 +9600,20 @@ test io-75.12 {invalid utf-8 encoding read is ignored} -setup { seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf } -body { + catch {read $f} errmsg + lappend res $errmsg + chan configure $f -profile tcl8 + seek $f 0 set d [read $f] binary scan $d H* hd - set hd + lappend res $hd + return $res } -cleanup { close $f removeFile io-75.12 -} -result 4181 + unset res +} -match glob -result {{error reading "file*":\ + invalid or incomplete multibyte or wide character} 4181} test io-75.13 { In nonblocking mode when there is an encoding error the data that has been successfully read so far is returned first and then the error is returned @@ -9718,8 +9824,41 @@ test io-76.10 {channel mode dropping} -setup { } -match glob -result {Tcl_RemoveChannelMode error:\ Bad mode, would make channel inacessible. Channel: "*"} +# Encoding errors on pipeline +# Ensures fix for exec bug [0f1ddc0df7] does not affect open +# It should still fail unless -profile is explicitly set to replace +test io-77.1 {open pipe encoding mismatch} -setup { + set scriptFile [makeFile { + fconfigure stdout -translation binary + puts -nonewline a\xe9b + flush stdout + } script] +} -cleanup { + close $fd + removeFile $scriptFile +} -body { + set fd [open |[list [info nameofexecutable] $scriptFile r+]] + fconfigure $fd -encoding utf-8 + list [catch {read $fd} result opts] [string match {error reading "*": invalid or incomplete multibyte or wide character} $result] [dict get $opts -errorcode] +} -result [list 1 1 {POSIX EILSEQ {invalid or incomplete multibyte or wide character}}] +test io-77.2 {open pipe encoding mismatch - use replace profile} -setup { + set scriptFile [makeFile { + fconfigure stdout -translation binary + puts -nonewline a\xe9b + flush stdout + } script] +} -cleanup { + close $fd + removeFile $scriptFile +} -body { + set fd [open |[list [info nameofexecutable] $scriptFile r+]] + fconfigure $fd -encoding utf-8 -profile replace + read $fd +} -result a\uFFFDb + + # cleanup -foreach file [list fooBar longfile script script2 output test1 pipe my_script \ +foreach file [list fooBar longfile script2 output test1 pipe my_script \ test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { removeFile $file } diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 2b9aed6..94129a2 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -241,11 +241,11 @@ test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) } -body { set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -profile tcl8 + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile tcl8 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -profile strict -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -263,11 +263,11 @@ test iocmd-8.9 {fconfigure command} -setup { } -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} -encoding binary -profile tcl8 + -eofchar {} -encoding binary fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -profile tcl8 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,27 +369,6 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort } -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). -test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints { - deprecated obsolete -} -setup { - # I don't know how else to open the console, but this is non-portable - set console stdin -} -body { - fconfigure $console -nocomplainencoding 0 -} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" -test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup { - set console stdin - set oldprofile [fconfigure $console -profile] -} -constraints { - obsolete -} -body { - fconfigure $console -strictencoding 1 - fconfigure $console -nocomplainencoding 0 - fconfigure $console -nocomplainencoding -} -cleanup { - fconfigure $console -strictencoding $oldmode -} -result 0 - test iocmd-8.23 {fconfigure -profile badprofile} -body { fconfigure stdin -profile froboz @@ -517,9 +496,16 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { close $f set result } 5 -test iocmd-12.11 {POSIX open access modes: BINARY} { +test iocmd-12.11 {POSIX open access modes: BINARY} -body { + after 100 set f [open $path(test1) {WRONLY BINARY TRUNC}] - puts $f Ɉ ;# gets truncated to H + puts $f Ɉ ;# throws an exception +} -cleanup { + close $f +} -returnCodes 1 -match glob -result {error writing "*": invalid or incomplete multibyte or wide character} +test iocmd-12.12 {POSIX open access modes: BINARY} { + set f [open $path(test1) {WRONLY BINARY TRUNC}] + puts $f H close $f set f [open $path(test1) r] fconfigure $f -translation binary @@ -1403,34 +1389,34 @@ test iocmd-24.15 {chan write, EAGAIN means that writing is not allowed at this t test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} - proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} + proc foo args {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} - proc foo {args} {oninit cget cgetall; onfinal; track; return ""} + proc foo args {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} - proc foo {args} { + proc foo args { oninit cget cgetall; onfinal; track - return "-bar foo -snarf x" + return {-bar foo -snarf x} } set c [chan create {r w} foo] note [fconfigure $c] close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -profile * -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -profile * -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { @@ -2951,7 +2937,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body rename foo {} set res } -constraints {testchannel thread} \ - -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -2964,7 +2950,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -2980,7 +2966,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/iogt.test b/tests/iogt.test index 5692682..cb02d40 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -549,8 +549,8 @@ test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - fconfigure $fin -buffersize 20 - fconfigure $fout -buffersize 10 + fconfigure $fin -buffersize 20 -profile tcl8 + fconfigure $fout -buffersize 10 -profile tcl8 fcopy $fin $fout close $fin close $fout diff --git a/tests/lindex.test b/tests/lindex.test index ffe0d9e..17a9ed2 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -70,11 +70,11 @@ test lindex-3.4 {integer 3} -constraints testevalex -body { test lindex-3.5 {bad octal} -constraints testevalex -body { set x 0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-3.6 {bad octal} -constraints testevalex -body { set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-3.7 {indexes don't shimmer wide ints} -body { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] @@ -114,11 +114,11 @@ test lindex-4.5 {index = end-3} testevalex { test lindex-4.6 {bad octal} -constraints testevalex -body { set x end-0o8 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-4.7 {bad octal} -constraints testevalex -body { set x end--0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-4.8 {bad integer, not octal} testevalex { set x end-0a2 list [catch { testevalex {lindex {a b c} $x} } result] $result @@ -274,11 +274,11 @@ test lindex-11.4 {integer 3} { test lindex-11.5 {bad octal} -body { set x 0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-11.6 {bad octal} -body { set x -0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} # Indices relative to end @@ -320,11 +320,11 @@ test lindex-12.5 {index = end-3} { test lindex-12.6 {bad octal} -body { set x end-0o8 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-12.7 {bad octal} -body { set x end--0o9 list [catch { lindex {a b c} $x } result] $result -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test lindex-12.8 {bad integer, not octal} { set x end-0a2 list [catch { lindex {a b c} $x } result] $result diff --git a/tests/listObj.test b/tests/listObj.test index 55fc089..249d446 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -22,6 +22,9 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] testConstraint memory [llength [info commands memory]] +set INT_MAX 0x7fffffff; # Assumes sizeof(int) == 4 +set SIZE_MAX [expr {(1 << (8*$::tcl_platform(pointerSize) - 1)) - 1}] + catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { # Test removed; tested an internal detail @@ -206,10 +209,25 @@ test listobj-10.3 {Tcl_ListObjReplace with negative count value} testobj { testlistobj replace 1 1 -1 f testlistobj get 1 } {a f b c d e} +test listobj-10.4 {Tcl_ListObjReplace with $SIZE_MAX count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 $SIZE_MAX f + testlistobj get 1 +} {a f} +test listobj-10.5 {Tcl_ListObjReplace with SIZE_MAX-1 count value} testobj { + testlistobj set 1 a b c d e + testlistobj replace 1 1 [expr {$SIZE_MAX -1}] f + testlistobj get 1 +} {a f} test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj { testobj bug3598580 } 123 +test listobj-11.2 {Bug e58d7e19e9: Upwards compatibility of TclObjTypeHasProc()} testobj { + set l [testobj buge58d7e19e9 "a x c"] + # Since $l is a V1 objType, it's lengthProc will be accessed, but not its indexProc. + list [llength $l] [lindex $l 2] +} {100 c} # Stolen from dict.test proc listobjmemcheck script { @@ -301,9 +319,7 @@ test listobj-14.2 {Tcl_ListObjIndex out-of-bounds index for native lists with sp list [testlistobj index 1 -1] [testlistobj index 1 1000] } -result {null null} -test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints { - testobj -} -setup { +test listobj-14.3 {Tcl_ListObjIndex out-of-bounds index for lseq} -constraints {bug-30e4e9102f testobj} -setup { testobj set 1 [lseq 3] } -cleanup { testobj freeallvars diff --git a/tests/listRep.test b/tests/listRep.test index 02ff18f..11af9ad 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -221,7 +221,7 @@ test listrep-1.2 { set l [linsert [freeSpaceNone] $end 99] validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 6 7 99} 0 9] +} -result [list {0 1 2 3 4 5 6 7 99} 0 4] test listrep-1.2.1 { Inserts at back of unshared list with no free space should allocate all @@ -231,7 +231,7 @@ test listrep-1.2.1 { lset l $end+1 99 validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 6 7 99} 0 9] +} -result [list {0 1 2 3 4 5 6 7 99} 0 4] test listrep-1.2.2 { Inserts at back of unshared list with no free space should allocate all @@ -241,7 +241,7 @@ test listrep-1.2.2 { lappend l 99 validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 6 7 99} 0 9] +} -result [list {0 1 2 3 4 5 6 7 99} 0 4] test listrep-1.3 { Inserts in middle of unshared list with no free space should reallocate with @@ -1160,7 +1160,7 @@ test listrep-3.3 { set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange -3 7] 6 5 1] +} -result [list [irange -3 7] 3 2 1] test listrep-3.3.1 { Inserts in front of unshared spanned list with insufficient total freespace @@ -1169,7 +1169,7 @@ test listrep-3.3.1 { set l [lreplace [freeSpaceBoth 8 1 1] $zero -1 -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange -3 7] 6 5 1] +} -result [list [irange -3 7] 3 2 1] test listrep-3.4 { Inserts at back of unshared spanned list with room at back should not @@ -1255,7 +1255,7 @@ test listrep-3.6 { set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 10] 1 10 1] +} -result [list [irange 0 10] 1 4 1] test listrep-3.6.1 { Inserts in back of unshared spanned list with insufficient total freespace @@ -1265,7 +1265,7 @@ test listrep-3.6.1 { set l [lreplace [freeSpaceBoth 8 1 1] $end+1 $end+1 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 10] 1 10 1] +} -result [list [irange 0 10] 1 4 1] test listrep-3.6.2 { Inserts in back of unshared spanned list with insufficient total freespace @@ -1276,7 +1276,7 @@ test listrep-3.6.2 { lappend l 8 9 10 validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 10] 1 10 1] +} -result [list [irange 0 10] 1 4 1] test listrep-3.6.3 { Inserts in back of unshared spanned list with insufficient total freespace @@ -1287,7 +1287,7 @@ test listrep-3.6.3 { lset l $end+1 8 validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list [irange 0 8] 0 9 1] +} -result [list [irange 0 8] 0 4 1] test listrep-3.7 { Inserts in front half of unshared spanned list with room in front should not @@ -1341,7 +1341,7 @@ test listrep-3.10 { set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 4 1] test listrep-3.10.1 { Inserts in front half of unshared spanned list with insufficient total space. @@ -1350,7 +1350,7 @@ test listrep-3.10.1 { set l [lreplace [freeSpaceBoth 8 1 1] $one -1 -3 -2 -1] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1] +} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 4 1] test listrep-3.11 { Inserts in back half of unshared spanned list with room in back should not @@ -1414,7 +1414,7 @@ test listrep-3.14 { set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 4 1] test listrep-3.14.1 { Inserts in back half of unshared spanned list with insufficient @@ -1424,7 +1424,7 @@ test listrep-3.14.1 { set l [lreplace [freeSpaceBoth 8 1 1] $end -1 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1] +} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 4 1] test listrep-3.15 { Deletes from front of small unshared span list results in elements @@ -1714,7 +1714,7 @@ test listrep-3.27 { set l [lreplace [freeSpaceBoth 8 1 1] $zero $one 10 11 12 13 14] validate $l list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l] -} -result [list {10 11 12 13 14 2 3 4 5 6 7} 6 5 1] +} -result [list {10 11 12 13 14 2 3 4 5 6 7} 3 2 1] test listrep-3.28 { Replacement of elements at back with same number of elements in unshared @@ -1770,7 +1770,7 @@ test listrep-3.32 { set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14] validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10] +} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 4] test listrep-3.33 { Replacement of elements in the middle in an unshared spanned list with @@ -1864,7 +1864,7 @@ test listrep-3.41 { set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12] validate $l list $l [leadSpace $l] [tailSpace $l] -} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11] +} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 5] # # 4.* - tests on shared spanned lists diff --git a/tests/load.test b/tests/load.test index be5b1c1..77a6dec 100644 --- a/tests/load.test +++ b/tests/load.test @@ -25,7 +25,7 @@ if {![info exists ext]} { } # Tests require the existence of one of the DLLs in the dltest directory. set testDir [file join [file dirname [info nameofexecutable]] dltest] -set x [file join $testDir pkga$ext] +set x [file join $testDir tcl9pkga$ext] set dll "[file tail $x]Required" testConstraint $dll [file readable $x] @@ -70,31 +70,31 @@ test load-1.8 {basic errors} -returnCodes error -body { load -global } -result {couldn't figure out prefix for -global} -test load-2.1 {basic loading, with guess for package name} -constraints \ - [list $dll $loaded deprecated] -body { - load -global [file join $testDir pkga$ext] +test load-2.1 {basic loading, with guess for package name} \ + [list $dll $loaded] { + load -global [file join $testDir tcl9pkga$ext] list [pkga_eq abc def] [lsort [info commands pkga_*]] -} -result {0 {pkga_eq pkga_quote}} +} {0 {pkga_eq pkga_quote}} interp create -safe child test load-2.2 {loading into a safe interpreter, with package name conversion} \ [list $dll $loaded] { - load -lazy [file join $testDir pkgb$ext] Pkgb child + load -lazy [file join $testDir tcl9pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \ -body { - list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg $errorCode + list [catch {load [file join $testDir tcl9pkgc$ext] Foo} msg] $msg $errorCode } -match glob \ -result [list 1 {cannot find symbol "Foo_Init"*} \ {TCL LOOKUP LOAD_SYMBOL *Foo_Init}] test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg + list [catch {load [file join $testDir tcl9pkga$ext] {} child} msg] $msg } {1 {can't use library in a safe interpreter: no Pkga_SafeInit procedure}} test load-3.1 {error in _Init procedure, same interpreter} \ [list $dll $loaded] { - list [catch {load [file join $testDir pkge$ext] pkge} msg] \ + list [catch {load [file join $testDir tcl9pkge$ext] Pkge} msg] \ $msg $::errorInfo $::errorCode } {1 {couldn't open "non_existent": no such file or directory} {couldn't open "non_existent": no such file or directory while executing @@ -102,14 +102,14 @@ test load-3.1 {error in _Init procedure, same interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir tcl9pkge$ext] Pkge"} {POSIX ENOENT {no such file or directory}}} test load-3.2 {error in _Init procedure, child interpreter} \ [list $dll $loaded] { catch {interp delete x} interp create x set ::errorCode foo set ::errorInfo bar - set result [list [catch {load [file join $testDir pkge$ext] pkge x} msg] \ + set result [list [catch {load [file join $testDir tcl9pkge$ext] Pkge x} msg] \ $msg $::errorInfo $::errorCode] interp delete x set result @@ -119,27 +119,27 @@ test load-3.2 {error in _Init procedure, child interpreter} \ invoked from within "if 44 {open non_existent}" invoked from within -"load [file join $testDir pkge$ext] pkge x"} {POSIX ENOENT {no such file or directory}}} +"load [file join $testDir tcl9pkge$ext] Pkge x"} {POSIX ENOENT {no such file or directory}}} test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg + list [catch {load [file join $testDir tcl9pkga$ext] Pkga} msg] $msg } {0 {}} test load-4.2 {reloading package into same interpreter} -setup { - catch {load [file join $testDir pkga$ext] Pkga} + catch {load [file join $testDir tcl9pkga$ext] Pkga} } -constraints [list $dll $loaded] -returnCodes error -body { - load [file join $testDir pkga$ext] Pkgb -} -result "file \"[file join $testDir pkga$ext]\" is already loaded for prefix \"Pkga\"" + load [file join $testDir tcl9pkga$ext] Pkgb +} -result "file \"[file join $testDir tcl9pkga$ext]\" is already loaded for prefix \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} -setup { catch {interp delete x} interp create x } -constraints [list $dll $loaded] -body { - load -global [file join $testDir pkga$ext] Pkga + load -global [file join $testDir tcl9pkga$ext] Pkga load {} Pkga x info loaded x } -cleanup { interp delete x -} -result [list [list [file join $testDir pkga$ext] Pkga]] +} -result [list [list [file join $testDir tcl9pkga$ext] Pkga]] # On some platforms, like SunOS 4.1.3, these tests can't be run because # they cause the process to exit. @@ -153,8 +153,8 @@ test load-6.1 {errors loading file} [list $dll $loaded] { test load-7.1 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" teststaticlibrary Test 1 0 - load {} test - load {} test child + load {} Test + load {} Test child list [set x] [child eval set x] } {loaded loaded} test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { @@ -168,18 +168,18 @@ test load-7.2 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { test load-7.3 {Tcl_StaticLibrary procedure} [list teststaticlibrary] { set x "not loaded" teststaticlibrary More 0 1 - load {} more + load {} More set x } {not loaded} -catch {load [file join $testDir pkga$ext] Pkga} -catch {load [file join $testDir pkgb$ext] Pkgb} -catch {load [file join $testDir pkge$ext] Pkge} -set currentRealLibraries [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +catch {load [file join $testDir tcl9pkga$ext] Pkga} +catch {load [file join $testDir tcl9pkgb$ext] Pkgb} +catch {load [file join $testDir tcl9pkge$ext] Pkge} +set currentRealLibraries [list [list [file join $testDir tcl9pkge$ext] Pkge] [list [file join $testDir tcl9pkgb$ext] Pkgb] [list [file join $testDir tcl9pkga$ext] Pkga]] test load-7.4 {Tcl_StaticLibrary procedure, redundant calls} -setup { teststaticlibrary Test 1 0 teststaticlibrary Another 0 0 teststaticlibrary More 0 1 -} -constraints [list teststaticlibrary $dll $loaded deprecated] -body { +} -constraints [list teststaticlibrary $dll $loaded] -body { teststaticlibrary Double 0 1 teststaticlibrary Double 0 1 info loaded @@ -204,14 +204,14 @@ test load-8.2 {TclGetLoadedLibraries procedure} -constraints {teststaticlibrary_ } -returnCodes error -result {could not find interpreter "gorp"} test load-8.3a {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded {}] -} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir tcl9pkga$ext] Pkga] [list [file join $testDir tcl9pkgb$ext] Pkgb] {*}$alreadyLoaded]] test load-8.3b {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { lsort -index 1 [info loaded child] -} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] +} [lsort -index 1 [list {{} Test} [list [file join $testDir tcl9pkgb$ext] Pkgb]]] test load-8.4 {TclGetLoadedLibraries procedure} [list teststaticlibrary_8.x $dll $loaded] { - load [file join $testDir pkgb$ext] Pkgb + load [file join $testDir tcl9pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] -} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] +} [list [lsort -index 1 [concat [list [list [file join $testDir tcl9pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir tcl9pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticLibrary, load already-loaded package into another interp} -setup { @@ -234,7 +234,7 @@ test load-10.1 {load from vfs} -setup { cd $testDir testsimplefilesystem 1 } -constraints [list $dll $loaded testsimplefilesystem] -body { - list [catch {load simplefs:/pkgd$ext Pkgd} msg] $msg + list [catch {load simplefs:/tcl9pkgd$ext Pkgd} msg] $msg } -result {0 {}} -cleanup { testsimplefilesystem 0 cd $dir @@ -243,7 +243,7 @@ test load-10.1 {load from vfs} -setup { test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ [list $dll $loaded] { - load [file join $testDir pkgooa$ext] + load [file join $testDir tcl9pkgooa$ext] list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] } {1 pkgooa_stubsok} diff --git a/tests/lrepeat.test b/tests/lrepeat.test index c1c8b02..6734281 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -61,7 +61,7 @@ test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { } -result {} } -test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -body { +test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -constraints knownBug -body { lrepeat 0x10000000 a b c d e f g h } -returnCodes error -match glob -result * diff --git a/tests/lsearch.test b/tests/lsearch.test index c913e60..b8a8aa7 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -552,7 +552,7 @@ test lsearch-23.1 {lsearch -stride option, errors} -body { } -returnCodes error -result {"-stride" option must be followed by stride length} test lsearch-23.2 {lsearch -stride option, errors} -body { lsearch -stride 0 {a b} a -} -returnCodes error -match glob -result {stride length must be between 1 and *} +} -returnCodes error -result {stride length must be at least 1} test lsearch-23.3 {lsearch -stride option, errors} -body { lsearch -stride 2 {a b c} a } -returnCodes error -result {list size must be a multiple of the stride length} @@ -690,7 +690,7 @@ test lsearch-28.9 {lsearch -sorted with -stride} -body { } -result 9 test lsearch-28.10 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 4294967296 -index 1 -subindices -inline {3 5 8 7 2 9} 9 -} -returnCodes 1 -match glob -result {stride length must be between 1 and *} +} -returnCodes 1 -result {list size must be a multiple of the stride length} # cleanup diff --git a/tests/lseq.test b/tests/lseq.test index c2264da..feb0a29 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -17,8 +17,9 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 testConstraint arithSeriesShimmerOk 1 -#testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] -#testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] +testConstraint knownBug 0 +testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] +testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] proc memusage {} { set fd [open /proc/[pid]/statm] @@ -464,9 +465,69 @@ test lseq-3.32 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -b list [lindex [tcl::unsupported::representation $a] 3] $a $b \ [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] } -cleanup { + unset a b srchlist i +} -result {list {{20 23 26 29 32 35 38}} arithseries arithseries} + + +# lsearch - +# -- should not shimmer lseq list +# -- should not leak lseq elements +test lseq-3.33 {lsearch nested lists of lseq} -constraints arithSeriesShimmer -body { + set srchlist {} + for {set i 5} {$i < 25} {incr i} { + lappend srchlist [lseq $i count 7 by 3] + } + set a [lsearch -all -inline -index 1 $srchlist 23] + set b [lmap i $a {lindex [tcl::unsupported::representation $i] 3}] + list [lindex [tcl::unsupported::representation $a] 3] $a $b \ + [lindex [tcl::unsupported::representation [lindex $srchlist 15]] 3] +} -cleanup { unset srchlist i a b } -result {list {{20 23 26 29 32 35 38}} arithseries arithseries} +test lseq-3.34 {"in" operator} -body { + set seq [lseq 0.3 15e4 0.1] + set inlist {} + set nilist {} + foreach y [lseq 3012.0 3013.0 0.03] { + if {$y in $seq} { + lappend inlist $y + } else { + lappend nilist $y + } + } + list $inlist $nilist +} -cleanup { + unset seq inlist nilist y +} -result {{3012.0 3012.3 3012.6 3012.9} {3012.03 3012.06 3012.09 3012.12 3012.15 3012.18 3012.21 3012.24 3012.27 3012.33 3012.36 3012.39 3012.42 3012.45 3012.48 3012.51 3012.54 3012.57 3012.63 3012.66 3012.69 3012.72 3012.75 3012.78 3012.81 3012.84 3012.87 3012.93 3012.96 3012.99}} + +test lseq-3.35 {"in" operator integer} -body { + set seq [lseq 3 int(15e4) 5] + set inlist {} + set nilist {} + foreach y [lseq 3012 3213 3] { + if {$y in $seq} { + lappend inlist $y + } else { + lappend nilist $y + } + } + list $inlist $nilist +} -cleanup { + unset seq inlist nilist y +} -result {{3018 3033 3048 3063 3078 3093 3108 3123 3138 3153 3168 3183 3198 3213} {3012 3015 3021 3024 3027 3030 3036 3039 3042 3045 3051 3054 3057 3060 3066 3069 3072 3075 3081 3084 3087 3090 3096 3099 3102 3105 3111 3114 3117 3120 3126 3129 3132 3135 3141 3144 3147 3150 3156 3159 3162 3165 3171 3174 3177 3180 3186 3189 3192 3195 3201 3204 3207 3210}} + +test lseq-3.36 {"in" non-numeric case} -body { + if {"barney" in [lseq 15]} { + set res found + } else { + set res not-found + } + set res +} -cleanup { + unset res +} -result {not-found} + test lseq-4.1 {end expressions} -body { set start 7 lseq $start $start+11 @@ -532,7 +593,26 @@ test lseq-4.3 {TIP examples} -body { # # Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case -test lseq-4.4 {lseq corner case} -body { +test lseq-4.4 {lseq corner case} -constraints has64BitLengths -body { + set tcmd { + set res {} + set s [catch {lindex [lseq 10 100] 0} e] + lappend res $s $e + set s [catch {lindex [lseq 10 9223372036854775000] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 9223372036854775000]} e] + lappend res $s $e + set s [catch {lindex [lseq 10 2147483647] 0} e] + lappend res $s $e + set s [catch {llength [lseq 10 2147483647]} e] + lappend res $s $e + } + eval $tcmd +} -cleanup { + unset res s e tcmd +} -result {0 10 0 10 0 9223372036854774991 0 10 0 2147483638} + +test lseq-4.4.32 {lseq corner case} -constraints has32BitLengths -body { set tcmd { set res {} set s [catch {lindex [lseq 10 100] 0} e] @@ -556,9 +636,6 @@ test lseq-4.4 {lseq corner case} -body { test lseq-4.5 {lindex off by one} -body { lappend res [eval {lindex [lseq 1 4] end}] lappend res [eval {lindex [lseq 1 4] end-1}] -} -setup { - # Since 4.3 does not clean up and 4.4 may not run under constraint - set res {} } -cleanup { unset res } -result {4 3} @@ -605,11 +682,15 @@ test lseq-4.11 {bug lseq / lindex discrepancies} -body { lindex [lseq 0x7fffffff] 0x80000000 } -result {} -test lseq-4.12 {bug lseq} -body { +test lseq-4.12 {bug lseq} -constraints has64BitLengths -body { + llength [lseq 0x100000000] +} -result {4294967296} + +test lseq-4.12.32 {bug lseq} -constraints has32BitLengths -body { llength [lseq 0x100000000] } -returnCodes 1 -result {max length of a Tcl list exceeded} -test lseq-4.13 {bug lseq} -constraints knownBug -body { +test lseq-4.13 {bug lseq} -constraints has64BitLengths -body { set l [lseq 0x7fffffffffffffff] list \ [llength $l] \ @@ -696,7 +777,7 @@ test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { set premem [memusage] p $l set postmem [memusage] - expr {($postmem - $premem) < 10} + expr {[string match *purify* [tcl::build-info]] || ($postmem - $premem < 10) ? 1 : ($postmem - $premem)} } -result 1 test lseq-bug-578b7e273c03-1 {Arithmetic Series Objects get wrong precision when end value is not specified} -body { diff --git a/tests/main.test b/tests/main.test index 4aadd79..2703dc1 100644 --- a/tests/main.test +++ b/tests/main.test @@ -606,7 +606,7 @@ namespace eval ::tcl::test::main { catch {set f [open "|[list [interpreter]]" w+]} catch {chan configure $f -blocking 0} } -body { - type $f "chan configure stdin -eofchar \"\\x1A {}\" + type $f "chan configure stdin -eofchar \\x1A if 1 \{\n\x1A" variable wait chan event $f readable \ diff --git a/tests/mathop.test b/tests/mathop.test index 3c25a2b..57d48d6 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -126,10 +126,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError @@ -164,10 +164,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "+"} + } -result {can't use non-numeric string "0o8" as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -201,10 +201,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError @@ -239,10 +239,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "*"} + } -result {can't use non-numeric string "0o8" as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -399,10 +399,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError @@ -441,10 +441,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "&"} + } -result {can't use non-numeric string "0o8" as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -509,10 +509,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError @@ -551,10 +551,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "|"} + } -result {can't use non-numeric string "0o8" as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -619,10 +619,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError @@ -661,10 +661,10 @@ namespace eval ::testmathop { } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number "0o8" as operand of "^"} + } -result {can't use non-numeric string "0o8" as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 468c648..36b613f 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -293,12 +293,13 @@ namespace eval test_ns_hier1 { namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } +# TIP 278: secondary lookup disabled for vars, tests disabled with # test namespace-old-5.4 {nested namespaces can access global namespace} { - list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ + list [namespace eval test_ns_hier1 {#set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ - [namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \ + [namespace eval test_ns_hier1::test_ns_hier2 {#set test_ns_var_global}] \ [namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}] -} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}} +} {{} {cmd in ::} {} {cmd in ::}} test namespace-old-5.5 {variables in different namespaces don't conflict} { list [set test_ns_hier1::test_ns_level] \ [set test_ns_hier1::test_ns_hier2::test_ns_level] @@ -468,11 +469,12 @@ test namespace-old-6.11 {commands affect all parent namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{cache2 version} {cache2 version}} +# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.12 {define test variables} { variable test_ns_cache_var "global version" set trigger {set test_ns_cache_var} - namespace eval test_ns_cache1 $trigger -} {global version} + list [catch {namespace eval test_ns_cache1 $trigger} msg] $msg +} {1 {can't read "test_ns_cache_var": no such variable}} set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { @@ -481,22 +483,24 @@ test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 $trigger } {cache1 version} variable ::test_ns_cache_var "global version" +# TIP 278: secondary lookup disabled, catch added, result changed from {global version} test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ - [namespace eval test_ns_cache1 $trigger] -} {{cache1 version} {} {global version}} + [catch {namespace eval test_ns_cache1 $trigger}] +} {{cache1 version} {} 1} +# TIP 278: secondary lookup disabled, catch added, result changed test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" } set trigger2 {set test_ns_cache2::test_ns_cache_var} - list [namespace eval test_ns_cache1 $trigger2] \ - [namespace eval test_ns_cache1::test_ns_cache2 $trigger] -} {{global cache2 version} {global version}} + catch {list [namespace eval test_ns_cache1 $trigger2] \ + [namespace eval test_ns_cache1::test_ns_cache2 $trigger]} +} 1 set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" diff --git a/tests/namespace.test b/tests/namespace.test index c98ad4a..ae233cb 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -48,9 +48,9 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { - lappend l [namespace current] + lappend ::l [namespace current] namespace eval foo { - lappend l [namespace current] + lappend ::l [namespace current] } } lappend l [namespace current] @@ -710,6 +710,8 @@ test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup [catch {namespace children test_ns_777} msg] $msg } } -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} + +# TIP 278: secondary lookup disabled, results changed from {10 20} test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 @@ -721,9 +723,11 @@ test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { } } -body { namespace eval test_ns_1 { - list $v $test_ns_2::v + # list $v $test_ns_2::v + list [catch {set v} msg] $msg [catch {set test_ns_2::v} msg] $msg } -} -result {10 20} +} -result {1 {can't read "v": no such variable} 0 20} + test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -784,15 +788,17 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] } -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} + +# TIP 278: secondary lookup disabled, added catch, result changed from y test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -body { namespace eval test_ns_1 { variable {} - set test_ns_1::(x) y + catch {set test_ns_1::(x) y} ::msg } - set test_ns_1::(x) -} -result y + list $::msg [catch {set test_ns_1::(x)} msg] $msg +} -result {{can't set "test_ns_1::(x)": parent namespace doesn't exist} 1 {can't read "test_ns_1::(x)": no such variable}} test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} } -returnCodes error -body { @@ -965,13 +971,15 @@ test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { set x } } -result {777} + +# TIP 278: secondary lookup disabled, catch added, result changed from 314159 test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { variable x 777 unset x - set x ;# must be global x now + list [catch {set x} msg] $msg ;# must not be global x now } -} {314159} +} {1 {can't read "x": no such variable}} test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { set wuzzat @@ -983,6 +991,8 @@ test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { } set test_ns_1::a } {hello} + +# TIP 278: secondary lookup disabled, result changed from 1 test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} } -body { @@ -996,7 +1006,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} - namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} -result 1 +} -result 0 catch {unset a} catch {unset x} @@ -1617,6 +1627,8 @@ test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { [namespace which ::test_ns_2::cmd2] } } -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} + +# TIP 278: secondary lookup disabled, catch added, result changed test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { @@ -1636,12 +1648,12 @@ test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { } } -body { namespace eval test_ns_3 { - list [namespace which -variable env] \ + list [catch {namespace which -variable env } msg] $msg \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {0 {} ::test_ns_3::v3 ::test_ns_2::v2 0 {}} test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} diff --git a/tests/obj.test b/tests/obj.test index 64a1d5b..eb85c84 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -19,16 +19,13 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] - testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] -test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {testobj deprecated} { +test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { - bytearray bytecode cmdName dict @@ -48,10 +45,10 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 12] - lappend result [testobj convert 1 bytearray] + lappend result [testobj convert 1 string] lappend result [testobj type 1] lappend result [testobj refcount 1] -} {{} 12 12 bytearray 3} +} {{} 12 12 string 3} test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" diff --git a/tests/parse.test b/tests/parse.test index b0c051b..517d577 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -376,12 +376,12 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { return "new result" } set handler1 [testasync create async1] - set aresult xxx - set acode yyy + set ::aresult xxx + set ::acode yyy } -cleanup { testasync delete } -body { - list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult + list [testevalobjv 0 testasync mark $handler1 original 0] $::acode $::aresult } -result {{new result} 0 original} test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv { list [catch {testevalobjv 0 error message} msg] $msg @@ -601,8 +601,8 @@ test parse-12.6 {Tcl_ParseVarName procedure, braced variable name} testparser { testparser {${..[]b}cd} 0 } {- {${..[]b}cd} 1 word {${..[]b}cd} 3 variable {${..[]b}} 1 text {..[]b} 0 text cd 0 {}} test parse-12.7 {Tcl_ParseVarName procedure, braced variable name} testparser { - testparser "\$\{\{\} " 0 -} {- \$\{\{\}\ 1 word \$\{\{\} 2 variable \$\{\{\} 1 text \{ 0 {}} + testparser "\$\{\{\\\\\}\} " 0 +} {- {${{\\}} } 1 word {${{\\}}} 2 variable {${{\\}}} 1 text {{\\}} 0 {}} test parse-12.8 {Tcl_ParseVarName procedure, missing close brace} testparser { list [catch {testparser "$\{abc" 0} msg] $msg $::errorInfo } {1 {missing close-brace for variable name} missing\ close-brace\ for\ variable\ name\n\ \ \ \ (remainder\ of\ script:\ \"\{abc\")\n\ \ \ \ invoked\ from\ within\n\"testparser\ \"\$\\\{abc\"\ 0\"} @@ -797,7 +797,7 @@ test parse-15.16 {CommandComplete procedure} { } 1 test parse-15.17 {CommandComplete procedure} { info complete {a b "c $dd("} -} 0 +} 1 test parse-15.18 {CommandComplete procedure} { info complete {a b "c \"} } 0 diff --git a/tests/parseExpr.test b/tests/parseExpr.test index fd32df9..476a250 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -919,8 +919,8 @@ test parseExpr-21.43 {error message} -body { in expression \"...8901234567890*\"foobar\$\{abcdefghijklmnopqrstuv...\"" test parseExpr-21.44 {error message} -body { expr {123456789012345678901234567890*"foo$bar(abcdefghijklmnopqrstuvwxyz"} -} -returnCodes error -result {missing ) -in expression "...8901234567890*"foo$bar(abcdefghijklmnopqrstuv..."} +} -returnCodes error -result {invalid character in array index +in expression "...8901234567890*"foo$bar(abcdefghijklmnopqrstu..."} test parseExpr-21.45 {error message} -body { expr {123456789012345678901234567890*"foo$bar([{}abcdefghijklmnopqrstuvwxyz])"} } -returnCodes error -result {extra characters after close-brace diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index 33add42..49f5849 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -553,7 +553,7 @@ removeFile [file join pkg circ3.tcl] # Some tests require the existence of one of the DLLs in the dltest directory set x [file join [file dirname [info nameofexecutable]] dltest \ - pkga[info sharedlibextension]] + tcl9pkga[info sharedlibextension]] set dll "[file tail $x]Required" testConstraint $dll [file exists $x] @@ -575,8 +575,8 @@ test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] { # it. set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl] exec [interpreter] << $cmd - pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl -} "0 {{pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" + pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath tcl9pkga[info sharedlibextension] pkga.tcl +} "0 {{pkga:1.0 {tclPkgSetup {tcl9pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}" test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { # Do all [load]ing of shared libraries in another process, so we can diff --git a/tests/regexp.test b/tests/regexp.test index 16c775e..b06c163 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -765,14 +765,14 @@ test regexp-19.2 {regsub null replacement} { string equal $result $expected } 1 -test regexp-20.1 {regsub shared object shimmering} -constraints deprecated -body { +test regexp-20.1 {regsub shared object shimmering} -body { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d - list $d [string length $d] [string bytelength $d] -} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] + list $d [string length $d] +} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37] test regexp-20.2 {regsub shared object shimmering with -about} -body { eval regexp -about abc } -result {0 {}} diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 42f1b3b..6cf95b5 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -16,8 +16,6 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -source [file join [file dirname [info script]] tcltests.tcl] - # Procedure to evaluate a script within a proc, to test compilation # functionality @@ -793,16 +791,16 @@ test regexpComp-19.1 {regsub null replacement} { } } "\0a\0hel\0a\0lo\0a\0 14" -test regexpComp-20.1 {regsub shared object shimmering} deprecated { +test regexpComp-20.1 {regsub shared object shimmering} { evalInProc { # Bug #461322 set a abcdefghijklmnopqurstuvwxyz set b $a set c abcdefghijklmnopqurstuvwxyz0123456789 regsub $a $c $b d - list $d [string length $d] [string bytelength $d] + list $d [string length $d] } -} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] +} [list abcdefghijklmnopqurstuvwxyz0123456789 37] test regexpComp-20.2 {regsub shared object shimmering with -about} { evalInProc { eval regexp -about abc diff --git a/tests/result.test b/tests/result.test index 5ae29b2..770e401 100644 --- a/tests/result.test +++ b/tests/result.test @@ -33,7 +33,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result presentOrFreed} +} {dynamic result freed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -45,7 +45,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 presentOrFreed} +} {42 freed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/tests/safe-stock86.test diff --git a/tests/safe.test b/tests/safe.test index 0a888f4..8af6c24 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -734,10 +734,10 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -cleanup { safe::interpDelete $i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ - {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ - {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ - {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}} test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { # this test shall work, believed equivalent to 9.6 set i [safe::interpCreate \ @@ -759,10 +759,10 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { } -cleanup { safe::interpDelete $i unset -nocomplain a b c d e f g i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ - {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ - {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ - {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}} test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { @@ -1951,7 +1951,7 @@ test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { safe::interpDelete $i set env(HOME) $savedHOME unset savedHOME -} -result {~} +} -result {$p(:0:)/~} test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar @@ -1965,7 +1965,7 @@ test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { safe::interpDelete $i set env(HOME) $savedHOME unset savedHOME -} -result {~} +} -result {$p(:0:)/foo/bar/~} test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { set i [safe::interpCreate] set user $tcl_platform(user) @@ -1974,7 +1974,7 @@ test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup } -cleanup { safe::interpDelete $i unset user -} -result {~USER} +} -result {$p(:0:)/~USER} test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { set i [safe::interpCreate] set user $tcl_platform(user) @@ -1983,7 +1983,7 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup } -cleanup { safe::interpDelete $i unset user -} -result {~USER} +} -result {$p(:0:)/foo/bar/~USER} ### 17. Test the use of ::auto_path for loading commands (via tclIndex files) ### and non-module packages (via pkgIndex.tcl files). diff --git a/tests/scan.test b/tests/scan.test index 98ec314..6d7a9fb 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -864,6 +864,7 @@ test scan-13.9 {Tcl_ScanObjCmd, inline XPG case limit error} -body { scan abc {%2147483648$s} } -result {"%n$" argument index out of range} -returnCodes error + # scan infinities - not working test scan-14.1 {positive infinity} { diff --git a/tests/source.test b/tests/source.test index f5f9f0f..98aaee2 100644 --- a/tests/source.test +++ b/tests/source.test @@ -114,7 +114,7 @@ test source-2.7 {utf-8 with BOM} -setup { puts $out "\uFEFFset y new-y" close $out set y old-y - source -encoding utf-8 $sourcefile + source $sourcefile return $y } -cleanup { removeFile $sourcefile @@ -226,7 +226,7 @@ test source-7.1 {source -encoding test} -setup { close $f } -body { set x unset - source -encoding utf-8 $sourcefile + source $sourcefile set x } -cleanup { removeFile source.file @@ -269,7 +269,7 @@ test source-7.5 {source -encoding: correct operation} -setup { puts $f "proc € {} {return foo}" close $f } -body { - source -encoding utf-8 $sourcefile + source $sourcefile € } -cleanup { removeFile source.file diff --git a/tests/string.test b/tests/string.test index 783368d..26cd8a7 100644 --- a/tests/string.test +++ b/tests/string.test @@ -34,7 +34,6 @@ testConstraint testobj [expr {[info commands testobj] ne {}}] testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint testbytestring [llength [info commands testbytestring]] -testConstraint testutf16string [llength [info commands testutf16string]] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -76,7 +75,7 @@ if {$noComp} { test string-1.1.$noComp {error conditions} -body { list [catch {run {string gorp a b}} msg] $msg -} -match glob -result {1 {unknown or ambiguous subcommand "gorp": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -result {1 {unknown or ambiguous subcommand "gorp": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2.$noComp {error conditions} { list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} @@ -431,7 +430,7 @@ test string-4.16.$noComp {string first, normal string vs pure unicode string} -b # Representation checks are canaries run {list [representationpoke $s] [representationpoke $m] \ [string first $m $s]} -} -match glob -result {{*string 1} {*string 0} 2} +} -result {{string 1} {string 0} 2} test string-4.17.$noComp {string first, corner case} -body { run {string first a aaa 4294967295} } -result -1 @@ -506,10 +505,10 @@ test string-5.16.$noComp {string index, bytearray object with string obj shimmer } 0 test string-5.17.$noComp {string index, bad integer} -body { list [catch {run {string index "abc" 0o8}} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test string-5.18.$noComp {string index, bad integer} -body { list [catch {run {string index "abc" end-0o0289}} msg] $msg -} -match glob -result {1 {*invalid octal number*}} +} -match glob -result {1 {*}} test string-5.19.$noComp {string index, bytearray object out of bounds} { run {string index [binary format I* {0x50515253 0x52}] -1} } {} @@ -1033,19 +1032,6 @@ test string-7.16.$noComp {string last, start index} { run {string last Üa ÜadÜad end-1} } 3 -test string-8.1.$noComp {string bytelength} deprecated { - list [catch {run {string bytelength}} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test string-8.2.$noComp {string bytelength} deprecated { - list [catch {run {string bytelength a b}} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test string-8.3.$noComp {string bytelength} deprecated { - run {string bytelength "\xC7"} -} 2 -test string-8.4.$noComp {string bytelength} deprecated { - run {string b ""} -} 0 - test string-9.1.$noComp {string length} { list [catch {run {string length}} msg] $msg } {1 {wrong # args: should be "string length string"}} @@ -1839,7 +1825,7 @@ test string-20.1.$noComp {string trimright errors} { } {1 {wrong # args: should be "string trimright string ?chars?"}} test string-20.2.$noComp {string trimright errors} -body { list [catch {run {string trimg a}} msg] $msg -} -match glob -result {1 {unknown or ambiguous subcommand "trimg": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -result {1 {unknown or ambiguous subcommand "trimg": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-20.3.$noComp {string trimright} { run {string trimright " XYZ "} } { XYZ} @@ -1948,18 +1934,18 @@ test string-21.22.$noComp {string trimright, unicode} { run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02} } "\uF602Hello world!\uF602" test string-21.23.$noComp {string trim, unicode} { - run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-21.24.$noComp {string trimleft, unicode} { run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-21.25.$noComp {string trimright, unicode} { - run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-22.1.$noComp {string wordstart} -body { list [catch {run {string word a}} msg] $msg -} -match glob -result {1 {unknown or ambiguous subcommand "word": must be *cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} +} -result {1 {unknown or ambiguous subcommand "word": must be cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-22.2.$noComp {string wordstart} -body { list [catch {run {string wordstart a}} msg] $msg } -result {1 {wrong # args: should be "string wordstart string index"}} @@ -2120,22 +2106,22 @@ test string-24.15.$noComp {string reverse command - pure bytearray} { } 030201 test string-24.16.$noComp {string reverse command - surrogates} { run {string reverse \u0444bulb\uD83D\uDE02} -} \uD83D\uDE02blub\u0444 +} \uDE02\uD83Dblub\u0444 test string-24.17.$noComp {string reverse command - surrogates} { run {string reverse \uD83D\uDE02hello\uD83D\uDE02} -} \uD83D\uDE02olleh\uD83D\uDE02 +} \uDE02\uD83Dolleh\uDE02\uD83D test string-24.18.$noComp {string reverse command - surrogates} { set s \u0444bulb\uD83D\uDE02 # shim shimmery ... string index $s 0 run {string reverse $s} -} \uD83D\uDE02blub\u0444 +} \uDE02\uD83Dblub\u0444 test string-24.19.$noComp {string reverse command - surrogates} { set s \uD83D\uDE02hello\uD83D\uDE02 # shim shimmery ... string index $s 0 run {string reverse $s} -} \uD83D\uDE02olleh\uD83D\uDE02 +} \uDE02\uD83Dolleh\uDE02\uD83D test string-25.1.$noComp {string is list} { run {string is list {a b c}} @@ -2432,11 +2418,11 @@ test string-29.11.$noComp {string cat, efficiency} -body { test string-29.12.$noComp {string cat, efficiency} -body { tcl::unsupported::representation \ [run {string cat [encoding convertto utf-8 {}] [list x]}] -} -match glob -result {*, string representation "x"} +} -match glob -result {*, no string representation} test string-29.13.$noComp {string cat, efficiency} -body { tcl::unsupported::representation [run {string cat \ [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}] -} -match glob -result {*, string representation "x"} +} -match glob -result {*, no string representation} test string-29.14.$noComp {string cat, efficiency} -setup { set e [encoding convertto utf-8 {}] } -cleanup { @@ -2624,17 +2610,6 @@ test string-32.17.$noComp {string is dict, valid dict packed in invalid dict} { } 0 }; # foreach noComp {0 1} - -test string-bug-b79df322a9 {Tcl_GetUnicode/Tcl_NewUnicodeObj api} -constraints { - testutf16string deprecated -} -body { - # This simple test suffices because the bug has nothing to do with - # the actual encoding conversion. The test was added because these - # functions are no longer called within the Tcl core and thus - # not tested by either `string`, not `encoding` tests. - testutf16string "abcde" -} -result abcde - # cleanup rename MemStress {} diff --git a/tests/stringObj.test b/tests/stringObj.test index 6fbdc05..605c9dd 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -19,18 +19,20 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] testConstraint testobj [llength [info commands testobj]] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] -test stringObj-1.1 {string type registration} {testobj deprecated} { +test stringObj-1.1 {string type registration} testobj { set t [testobj types] set first [string first "string" $t] set result [expr {$first >= 0}] } 1 +set INT_MAX 0x7fffffff; # Assumes sizeof(int) == 4 +set SIZE_MAX [expr {(1 << (8*$::tcl_platform(pointerSize) - 1)) - 1}] + test stringObj-2.1 {Tcl_NewStringObj} testobj { set result "" lappend result [testobj freeallvars] @@ -56,27 +58,27 @@ test stringObj-3.2 {Tcl_SetStringObj, existing non-"empty string" object} testob lappend result [testobj refcount 1] } {{} 512 foo string 2} -test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} {testobj deprecated} { +test stringObj-4.1 {Tcl_SetObjLength procedure, string gets shorter} testobj { testobj freeallvars teststringobj set 1 test teststringobj setlength 1 3 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {3 3 tes} +} {3 4 tes} test stringObj-4.2 {Tcl_SetObjLength procedure, string gets longer} testobj { testobj freeallvars teststringobj set 1 abcdef teststringobj setlength 1 10 teststringobj length 1 } 10 -test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} {testobj deprecated} { +test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj { testobj freeallvars teststringobj set 1 abcdef teststringobj append 1 xyzq -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {10 10 abcdefxyzq} -test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} {testobj deprecated} { +} {10 15 abcdefxyzq} +test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} testobj { testobj freeallvars testobj newobj 1 teststringobj setlength 1 0 @@ -96,7 +98,7 @@ test stringObj-5.2 {Tcl_AppendToObj procedure, length calculation} testobj { teststringobj append 1 123 -1 teststringobj get 1 } {x y bbCC123} -test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj deprecated} { +test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj { testobj freeallvars teststringobj set 1 xyz teststringobj setlength 1 15 @@ -108,7 +110,7 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} {testobj depr teststringobj append 1 abcdef -1 lappend result [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {15 15 16 16 xy12345678abcdef} +} {15 15 16 24 xy12345678abcdef} test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj { testobj freeallvars @@ -134,13 +136,13 @@ test stringObj-6.4 {Tcl_AppendStringsToObj procedure, counting space} testobj { teststringobj appendstrings 1 { 123 } abcdefg list [teststringobj length 1] [teststringobj get 1] } {15 {abc 123 abcdefg}} -test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} {testobj deprecated} { +test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 123 abcdefg list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1] -} {10 10 123abcdefg} -test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} { +} {10 15 123abcdefg} +test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -149,7 +151,7 @@ test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} {testo list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] } {10 10 ab34567890} -test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testobj deprecated} { +test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testobj { testobj freeallvars teststringobj set 1 abc teststringobj setlength 1 10 @@ -157,8 +159,8 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} {testo teststringobj appendstrings 1 34567890x list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {11 11 ab34567890x} -test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} {testobj deprecated} { +} {11 17 ab34567890x} +test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -171,14 +173,14 @@ test stringObj-6.9 {Tcl_AppendStringToObj, pure unicode} testobj { teststringobj get 1 } adcfoobarsoom -test stringObj-7.1 {SetStringFromAny procedure} {testobj deprecated} { +test stringObj-7.1 {SetStringFromAny procedure} testobj { testobj freeallvars teststringobj set2 1 [list a b] teststringobj append 1 x -1 list [teststringobj length 1] [teststringobj length2 1] \ [teststringobj get 1] -} {4 4 {a bx}} -test stringObj-7.2 {SetStringFromAny procedure, null object} {testobj deprecated} { +} {4 6 {a bx}} +test stringObj-7.2 {SetStringFromAny procedure, null object} testobj { testobj freeallvars testobj newobj 1 teststringobj appendstrings 1 {} @@ -196,7 +198,7 @@ test stringObj-7.4 {SetStringFromAny called with string obj} testobj { [string length $x] [testobj objtype $x] } {6 string 6 string} -test stringObj-8.1 {DupStringInternalRep procedure} {testobj deprecated} { +test stringObj-8.1 {DupStringInternalRep procedure} testobj { testobj freeallvars teststringobj set 1 {} teststringobj append 1 abcde -1 @@ -205,7 +207,7 @@ test stringObj-8.1 {DupStringInternalRep procedure} {testobj deprecated} { [teststringobj maxchars 1] [teststringobj get 1] \ [teststringobj length 2] [teststringobj length2 2] \ [teststringobj maxchars 2] [teststringobj get 2] -} {5 5 5 abcde 5 5 5 abcde} +} {5 8 0 abcde 5 5 0 abcde} test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj { set x abc\xEF\xBF\xAEghi string length $x @@ -454,71 +456,75 @@ test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself 1 3 } foo -test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} { +test stringObj-15.5 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 0 } foofoo -test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} { +test stringObj-15.6 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 1 } foooo -test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj knownBug deprecated} { +test stringObj-15.7 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 2 } fooo -test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj deprecated} { +test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo -test stringObj-16.0 {Tcl_GetRange: normal case} {testobj deprecated} { +test stringObj-16.0 {Tcl_GetRange: normal case} testobj { teststringobj set 1 abcde teststringobj range 1 1 3 } bcd -test stringObj-16.1 {Tcl_GetRange: first > end} {testobj deprecated} { +test stringObj-16.1 {Tcl_GetRange: first > end} testobj { teststringobj set 1 abcde teststringobj range 1 10 5 } {} -test stringObj-16.2 {Tcl_GetRange: last > end} {testobj deprecated} { +test stringObj-16.2 {Tcl_GetRange: last > end} testobj { teststringobj set 1 abcde teststringobj range 1 3 13 } de -test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} {testobj deprecated} { +test stringObj-16.3 {Tcl_GetRange: first = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 -1 3 } abcd -test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} {testobj deprecated} { +test stringObj-16.4 {Tcl_GetRange: last = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 1 -1 } bcde -test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} {testobj deprecated} { +test stringObj-16.5 {Tcl_GetRange: first = last = TCL_INDEX_NONE} testobj { teststringobj set 1 abcde teststringobj range 1 -1 -1 } abcde -test stringObj-16.6 {Tcl_GetRange: old anomaly} {testobj deprecated} { +test stringObj-16.6 {Tcl_GetRange: old anomaly} testobj { # Older implementations could return "cde" teststringobj set 1 abcde teststringobj range 1 2 0 } {} -test stringObj-16.7 {Tcl_GetRange: first = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.7 {Tcl_GetRange: first = INT_MAX-1} testobj { + teststringobj set 1 abcde + teststringobj range 1 [expr {$INT_MAX-1}] 3 +} {} +test stringObj-16.8 {Tcl_GetRange: first = SIZE_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 [expr {0x7FFFFFFF-1}] 3 + teststringobj range 1 [expr {$SIZE_MAX - 1}] 3 } {} -test stringObj-16.8 {Tcl_GetRange: last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.9 {Tcl_GetRange: last = INT_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 1 [expr {0x7FFFFFFF-1}] + teststringobj range 1 1 [expr {$INT_MAX-1}] } bcde -test stringObj-16.9 {Tcl_GetRange: last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.10 {Tcl_GetRange: last = SIZE_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 1 [expr {0x7FFFFFFF - 1}] + teststringobj range 1 1 [expr {$SIZE_MAX - 1}] } bcde -test stringObj-16.10 {Tcl_GetRange: first = last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.11 {Tcl_GetRange: first = last = INT_MAX-1} testobj { teststringobj set 1 abcde - teststringobj range 1 [expr {0x7FFFFFFF-1}] [expr {0x7FFFFFFF-1}] + teststringobj range 1 [expr {$INT_MAX-1}] [expr {$INT_MAX-1}] } {} -test stringObj-16.11 {Tcl_GetRange: first = last = 0x7FFFFFFF-1} {testobj deprecated} { +test stringObj-16.12 {Tcl_GetRange: first = last = SIZE_MAX-1} testobj { teststringobj set 1 abcde - set i [expr {0x7FFFFFFF - 1}] + set i [expr {$SIZE_MAX - 1}] teststringobj range 1 $i $i } {} diff --git a/tests/tcltest.test b/tests/tcltest.test index 114ce30..20d75bb 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -547,6 +547,7 @@ set notReadableDir [file join [temporaryDirectory] notreadable] set notWritableDir [file join [temporaryDirectory] notwritable] makeDirectory notreadable makeDirectory notwritable + switch -- $::tcl_platform(platform) { unix { file attributes $notReadableDir -permissions 0o333 diff --git a/tests/trace.test b/tests/trace.test index 2b16e2f..64c9111 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -19,8 +19,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] - testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevalobjv [llength [info commands testevalobjv]] @@ -900,23 +898,6 @@ foreach type {variable command execution} err $errs abbvlist $abbvs { } rename x {} -test trace-14.7 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.8 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.9 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x y} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.10 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x y z w} msg] $msg -} [list 1 "wrong # args: should be \"trace variable name ops command\""] -test trace-14.11 {trace command, "trace variable" errors} deprecated { - list [catch {trace variable x y z} msg] $msg -} [list 1 "bad operations \"y\": should be one or more of rwua"] - - test trace-14.12 {trace command ("remove variable" option)} { unset -nocomplain x set info {} diff --git a/tests/unload.test b/tests/unload.test index 75cbcde..df217be 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -27,7 +27,7 @@ if {![info exists ext]} { # Tests require the existence of one of the DLLs in the dltest directory. set testDir [file join [file dirname [info nameofexecutable]] dltest] -set x [file join $testDir pkgua$ext] +set x [file join $testDir tcl9pkgua$ext] set dll "[file tail $x]Required" testConstraint $dll [file readable $x] @@ -46,7 +46,7 @@ proc loadIfNotPresent {pkg args} { global testDir ext set loaded [lmap x [info loaded {*}$args] {lindex $x 1}] if {[string totitle $pkg] ni $loaded} { - load [file join $testDir $pkg$ext] + load [file join $testDir tcl9$pkg$ext] } } @@ -77,37 +77,37 @@ set pkgua_loaded {} set pkgua_detached {} set pkgua_unloaded {} # Tests for loading/unloading in trusted (non-safe) interpreters... -test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded deprecated] { +test unload-2.1 {basic loading of non-unloadable package, with guess for prefix} [list $dll $loaded] { loadIfNotPresent pkga list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} -test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded deprecated] { +test unload-2.2 {basic loading of unloadable package, with guess for prefix} [list $dll $loaded] { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [load [file join $testDir pkgua$ext]] \ + [load [file join $testDir tcl9pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} test unload-2.3 {basic unloading of non-unloadable package, with guess for prefix} -setup { loadIfNotPresent pkga } -constraints [list $dll $loaded] -returnCodes error -match glob -body { - unload [file join $testDir pkga$ext] + unload [file join $testDir tcl9pkga$ext] } -result {file "*" cannot be unloaded under a trusted interpreter} test unload-2.4 {basic unloading of unloadable package, with guess for prefix} -setup { loadIfNotPresent pkgua } -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [unload [file join $testDir pkgua$ext]] \ + [unload [file join $testDir tcl9pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {. {} {} {} {} . . .} test unload-2.5 {reloading of unloaded package, with guess for prefix} -setup { if {$pkgua_loaded eq ""} { loadIfNotPresent pkgua - unload [file join $testDir pkgua$ext] + unload [file join $testDir tcl9pkgua$ext] } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [load [file join $testDir pkgua$ext]] \ + [load [file join $testDir tcl9pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} @@ -115,12 +115,12 @@ test unload-2.6 {basic unloading of re-loaded package, with guess for prefix} -s # Establish expected state if {$pkgua_loaded eq ""} { loadIfNotPresent pkgua - unload [file join $testDir pkgua$ext] - load [file join $testDir pkgua$ext] + unload [file join $testDir tcl9pkgua$ext] + load [file join $testDir tcl9pkgua$ext] } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ - [unload [file join $testDir pkgua$ext]] \ + [unload [file join $testDir tcl9pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } -result {.. . . {} {} .. .. ..} @@ -135,14 +135,14 @@ child eval { test unload-3.1 {basic loading of non-unloadable package in a safe interpreter} \ [list $dll $loaded] { catch {rename pkgb_sub {}} - load [file join $testDir pkgb$ext] Pkgb child + load [file join $testDir tcl9pkgb$ext] Pkgb child list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \ [catch {pkgb_sub 12 10} msg2] $msg2 } {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}} test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ - [list $dll $loaded deprecated] { + [list $dll $loaded] { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkgua child] \ + [load [file join $testDir tcl9pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -150,46 +150,46 @@ test unload-3.2 {basic loading of unloadable package in a safe interpreter} \ test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup { loadIfNotPresent pkga } -constraints [list $dll $loaded] -returnCodes error -match glob -body { - unload [file join $testDir pkga$ext] {} child + unload [file join $testDir tcl9pkga$ext] {} child } -result {file "*" has never been loaded in this interpreter} test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for prefix} -setup { if {[lsearch -index 1 [info loaded child] Pkgb] < 0} { - load [file join $testDir pkgb$ext] Pkgb child + load [file join $testDir tcl9pkgb$ext] Pkgb child } } -constraints [list $dll $loaded] -returnCodes error -match glob -body { - unload [file join $testDir pkgb$ext] {} child + unload [file join $testDir tcl9pkgb$ext] {} child } -result {file "*" cannot be unloaded under a safe interpreter} test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for prefix} -setup { if {[lsearch -index 1 [info loaded child] Pkgua] < 0} { - load [file join $testDir pkgua$ext] Pkgua child + load [file join $testDir tcl9pkgua$ext] Pkgua child } } -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] {} child] \ + [unload [file join $testDir tcl9pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . .}} test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for prefix} -setup { if {[child eval set pkgua_loaded] eq ""} { - load [file join $testDir pkgua$ext] {} child - unload [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child + unload [file join $testDir tcl9pkgua$ext] {} child } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] {} child] \ + [load [file join $testDir tcl9pkgua$ext] {} child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with prefix conversion} -setup { if {[child eval set pkgua_loaded] eq ""} { - load [file join $testDir pkgua$ext] {} child - unload [file join $testDir pkgua$ext] {} child - load [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child + unload [file join $testDir tcl9pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] pKgUa child] \ + [unload [file join $testDir tcl9pkgua$ext] Pkgua child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{.. . .} {} {} {.. .. ..}} @@ -208,9 +208,9 @@ test unload-4.1 {loading of unloadable package in trusted interpreter, with gues set pkgua_detached "" set pkgua_unloaded "" incr load(M) -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ - [load [file join $testDir pkgua$ext]] \ + [load [file join $testDir tcl9pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} @@ -222,9 +222,9 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter} -set set pkgua_unloaded "" } incr load(C) -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkgua child] \ + [load [file join $testDir tcl9pkgua$ext] Pkgua child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -232,9 +232,9 @@ test unload-4.2 {basic loading of unloadable package in a safe interpreter} -set ## Load package in child-trusted interpreter... test unload-4.3 {basic loading of unloadable package in a second trusted interpreter} -setup { incr load(T) -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [load [file join $testDir pkgua$ext] pkgua child-trusted] \ + [load [file join $testDir tcl9pkgua$ext] Pkgua child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] @@ -242,45 +242,45 @@ test unload-4.3 {basic loading of unloadable package in a second trusted interpr ## Unload the package from the main trusted interpreter... test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for prefix} -setup { if {!$load(M)} { - load [file join $testDir pkgua$ext] + load [file join $testDir tcl9pkgua$ext] } if {!$load(C)} { - load [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child incr load(C) } if {!$load(T)} { - load [file join $testDir pkgua$ext] {} child-trusted + load [file join $testDir tcl9pkgua$ext] {} child-trusted incr load(T) } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ - [unload [file join $testDir pkgua$ext]] \ + [unload [file join $testDir tcl9pkgua$ext]] \ [info commands pkgua_*] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] } -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child safe interpreter... test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { if {!$load(C)} { - load [file join $testDir pkgua$ext] {} child + load [file join $testDir tcl9pkgua$ext] {} child } if {!$load(T)} { - load [file join $testDir pkgua$ext] {} child-trusted + load [file join $testDir tcl9pkgua$ext] {} child-trusted incr load(T) } -} -constraints [list $dll $loaded deprecated] -body { +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] {} child] \ + [unload [file join $testDir tcl9pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child trusted interpreter... test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for prefix} -setup { if {!$load(T)} { - load [file join $testDir pkgua$ext] {} child-trusted + load [file join $testDir tcl9pkgua$ext] {} child-trusted } } -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ - [unload [file join $testDir pkgua$ext] {} child-trusted] \ + [unload [file join $testDir tcl9pkgua$ext] {} child-trusted] \ [child-trusted eval info commands pkgua_*] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } -result {{. {} {}} {} {} {. . .}} @@ -291,10 +291,10 @@ test unload-5.1 {unload a module loaded from vfs} \ set dir [pwd] cd $testDir testsimplefilesystem 1 - load simplefs:/pkgua$ext pkgua + load simplefs:/tcl9pkgua$ext Pkgua } \ -body { - list [catch {unload simplefs:/pkgua$ext} msg] $msg + list [catch {unload simplefs:/tcl9pkgua$ext} msg] $msg } \ -result {0 {}} diff --git a/tests/upvar.test b/tests/upvar.test index 8a1319e..a394f4d 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -207,6 +207,67 @@ test upvar-5.3 {traces involving upvars} { p1 foo bar set x } {{x1 {} unset} x1} +test upvar-5.4 {read trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + set x1 + } + set x --- + p1 foo bar + set x +} -result {{x1 c read} x1} +test upvar-5.5 {write trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + set x1 22 + } + set x --- + p1 foo bar + set x +} -result {{x1 c write} x1} +test upvar-5.6 {unset trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + unset x1 + } + set x --- + p1 foo bar + set x +} -result {{x1 c unset} x1} +test upvar-5.7 {trace on non-existent upvar array element} -body { + proc p1 {a b} { + array set foo {} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + return [array get foo] + } + proc p2 {} { + upvar foo(hi) x1 + set x1 there + } + set x --- + lappend x [p1 foo bar] + set x +} -result {{x1 hi write} x1 {hi there}} test upvar-6.1 {retargeting an upvar} { proc p1 {} { diff --git a/tests/utf.test b/tests/utf.test index edb01c1..f3242b6 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -16,8 +16,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact tcl::test [info patchlevel]] -source [file join [file dirname [info script]] tcltests.tcl] - testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testfindfirst [llength [info commands testfindfirst]] testConstraint testfindlast [llength [info commands testfindlast]] @@ -49,7 +47,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.0 {Tcl_UniCharToUtf: 4 byte sequences} {testbytestring} { +test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} testbytestring { expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]} } 1 test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring { @@ -64,11 +62,11 @@ test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring { expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]} } 1 -test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {testbytestring} { - expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} +test utf-1.12 {Tcl_UniCharToUtf: Invalid surrogate} testbytestring { + expr {"\UD842" eq [testbytestring \xED\xA1\x82]} } 1 -test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {testbytestring} { - expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} +test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} { + expr {"\UD842" eq "\uD842"} } 1 test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} { set lo \uDE02 @@ -165,9 +163,9 @@ test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars t test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1 } 3 -test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring deprecated} { +test utf-4.12 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring} { testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end -} 2 +} 1 test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} { testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end } 8 @@ -533,13 +531,13 @@ test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} { test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3 } 2 -test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.10 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0] } 1 -test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3 } 1 -test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3 } 1 test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} { @@ -581,13 +579,13 @@ test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} { test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4 } 3 -test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.15 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0] } 1 -test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4 } 1 -test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring} { +test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring} { testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4 } 1 test utf-7.16 {Tcl_UtfPrev} testutfprev { @@ -716,7 +714,7 @@ test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} tes test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} { testutfprev [testbytestring \xE8\xA0\x00] 2 } 0 -test utf-7.48 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { +test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] } 1 test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { @@ -728,7 +726,7 @@ test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbyte test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2 } 1 -test utf-7.49 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { +test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { testutfprev A[testbytestring \xF4\x90\x80\x80] } 4 test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} { @@ -819,10 +817,10 @@ test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring { test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring { expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"} } 1 -test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {testbytestring} { +test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} testbytestring { expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"} } 1 -test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {testbytestring} { +test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} testbytestring { expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"} } 1 diff --git a/tests/utfext.test b/tests/utfext.test index d2da50b..fd82b16 100644 --- a/tests/utfext.test +++ b/tests/utfext.test @@ -66,7 +66,7 @@ foreach {enc utfhex hex} $utfExtMap { # Test for insufficient space test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body { - testencoding Tcl_UtfToExternal ucs-2 A {start end} {} 1 + testencoding Tcl_UtfToExternal utf-16 A {start end} {} 1 } -result [list nospace {} \xFF] -constraints testencoding # Another bug - char limit not obeyed @@ -75,10 +75,10 @@ test xx-bufferoverflow {buffer overflow Tcl_ExternalToUtf} -body { # nospace {} abcÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ test TableToUtf-bug-5be203d6ca {Bug 5be203d6ca - truncated prefix in table encoding} -body { - set src \x82\x4f\x82\x50\x82 - lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] buf - set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] - lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] + set src \x82\x4F\x82\x50\x82 + lassign [testencoding Tcl_ExternalToUtf shiftjis $src {start profiletcl8} 0 16 srcRead dstWritten charsWritten] buf + set result [list [testencoding Tcl_ExternalToUtf shiftjis $src {start profiletcl8} 0 16 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] + lappend result {*}[list [testencoding Tcl_ExternalToUtf shiftjis [string range $src $srcRead end] {end profiletcl8} 0 10 srcRead dstWritten charsWritten] $srcRead $dstWritten $charsWritten] } -result [list [list multibyte 0 \xEF\xBC\x90\xEF\xBC\x91\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 4 6 2 [list ok 0 \xC2\x82\x00\xFF\xFF\xFF\xFF\xFF\xFF\xFF] 1 2 1] -constraints testencoding diff --git a/tests/util.test b/tests/util.test index 04ee73d..2a05ac4 100644 --- a/tests/util.test +++ b/tests/util.test @@ -21,11 +21,8 @@ testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] testConstraint testprint [llength [info commands testprint]] - -testConstraint precision [expr {![catch {set saved_precision $::tcl_precision}]}] testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] - # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -396,38 +393,6 @@ test util-5.52 {Tcl_StringMatch} { } 0 -test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 12 -} -body { - concat x[expr {1.4}] -} -cleanup { - set ::tcl_precision $old_precision -} -result {x1.4} -test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 12 -} -body { - concat x[expr {1.39999999999}] -} -cleanup { - set ::tcl_precision $old_precision -} -result {x1.39999999999} -test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 12 -} -body { - concat x[expr {1.399999999999}] -} -cleanup { - set ::tcl_precision $old_precision -} -result {x1.4} -test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup { - set old_precision $::tcl_precision - set ::tcl_precision 5 -} -body { - concat x[expr {1.123412341234}] -} -cleanup { - set tcl_precision $old_precision -} -result {x1.1234} test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr {2.0}] } {x2.0} @@ -435,50 +400,6 @@ test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr {3.0e98}] } {x3e+98} -test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 7 - set x $tcl_precision - unset tcl_precision - list $x $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {7 7} -test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 12 - interp create child - set x [child eval set tcl_precision] - child eval {set tcl_precision 6} - interp delete child - list $x $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {12 6} -test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 12 - interp create -safe child - set x [child eval { - list [catch {set tcl_precision 8} msg] $msg - }] - interp delete child - list $x $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12} -test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints precision -setup { - set old_precision $::tcl_precision -} -body { - set tcl_precision 12 - list [catch {set tcl_precision abc} msg] $msg $tcl_precision -} -cleanup { - set ::tcl_precision $old_precision -} -result {1 {can't set "tcl_precision": improper value for precision} 12} - # This test always succeeded in the C locale anyway... test util-8.1 {TclNeedSpace - correct utf-8 handling} { # Bug 411825 @@ -2234,1874 +2155,6 @@ test util-15.8 {smallest normal} {*}{ } } -foreach ::tcl_precision {0 12} { - for {set e -312} {$e < -9} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {1.1e$e}" 1.1e$e - } -} -set tcl_precision 0 -for {set e -9} {$e < -4} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {1.1e$e}" 1.1e$e -} -set tcl_precision 12 -for {set e -9} {$e < -4} {incr e} { - test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} precision \ - "expr {1.1e$e}" 1.1e[format %+03d $e] -} -foreach ::tcl_precision {0 12} { - test util-16.1.$::tcl_precision.-4 {shortening of numbers} \ - {expr {1.1e-4}} \ - 0.00011 - test util-16.1.$::tcl_precision.-3 {shortening of numbers} \ - {expr {1.1e-3}} \ - 0.0011 - test util-16.1.$::tcl_precision.-2 {shortening of numbers} \ - {expr {1.1e-2}} \ - 0.011 - test util-16.1.$::tcl_precision.-1 {shortening of numbers} \ - {expr {1.1e-1}} \ - 0.11 - test util-16.1.$::tcl_precision.0 {shortening of numbers} \ - {expr {1.1}} \ - 1.1 - for {set e 1} {$e < 17} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {11[string repeat 0 [expr {$e-1}]].0}" \ - 11[string repeat 0 [expr {$e-1}]].0 - } - for {set e 17} {$e < 309} {incr e} { - test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr {1.1e$e}" 1.1e+$e - } -} -set tcl_precision 17 -test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \ - {expr {1e-300}} \ - 1e-300 -test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \ - {expr {1e-299}} \ - 9.9999999999999999e-300 -test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \ - {expr {1e-298}} \ - 9.9999999999999991e-299 -test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \ - {expr {1e-297}} \ - 1e-297 -test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \ - {expr {1e-296}} \ - 1e-296 -test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \ - {expr {1e-295}} \ - 1.0000000000000001e-295 -test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \ - {expr {1e-294}} \ - 1e-294 -test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \ - {expr {1e-293}} \ - 1.0000000000000001e-293 -test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \ - {expr {1e-292}} \ - 1.0000000000000001e-292 -test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \ - {expr {1e-291}} \ - 9.9999999999999996e-292 -test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \ - {expr {1e-290}} \ - 1.0000000000000001e-290 -test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \ - {expr {1e-289}} \ - 1e-289 -test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \ - {expr {1e-288}} \ - 1.0000000000000001e-288 -test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \ - {expr {1e-287}} \ - 1e-287 -test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \ - {expr {1e-286}} \ - 1.0000000000000001e-286 -test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \ - {expr {1e-285}} \ - 1.0000000000000001e-285 -test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \ - {expr {1e-284}} \ - 1e-284 -test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \ - {expr {1e-283}} \ - 9.9999999999999995e-284 -test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \ - {expr {1e-282}} \ - 1e-282 -test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \ - {expr {1e-281}} \ - 1e-281 -test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \ - {expr {1e-280}} \ - 9.9999999999999996e-281 -test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \ - {expr {1e-279}} \ - 1.0000000000000001e-279 -test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \ - {expr {1e-278}} \ - 9.9999999999999994e-279 -test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \ - {expr {1e-277}} \ - 9.9999999999999997e-278 -test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \ - {expr {1e-276}} \ - 1.0000000000000001e-276 -test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \ - {expr {1e-275}} \ - 9.9999999999999993e-276 -test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \ - {expr {1e-274}} \ - 9.9999999999999997e-275 -test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \ - {expr {1e-273}} \ - 1.0000000000000001e-273 -test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \ - {expr {1e-272}} \ - 9.9999999999999993e-273 -test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \ - {expr {1e-271}} \ - 9.9999999999999996e-272 -test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \ - {expr {1e-270}} \ - 1e-270 -test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \ - {expr {1e-269}} \ - 9.9999999999999996e-270 -test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \ - {expr {1e-268}} \ - 9.9999999999999996e-269 -test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \ - {expr {1e-267}} \ - 9.9999999999999998e-268 -test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \ - {expr {1e-266}} \ - 9.9999999999999998e-267 -test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \ - {expr {1e-265}} \ - 9.9999999999999998e-266 -test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \ - {expr {1e-264}} \ - 1e-264 -test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \ - {expr {1e-263}} \ - 1e-263 -test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \ - {expr {1e-262}} \ - 1e-262 -test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \ - {expr {1e-261}} \ - 9.9999999999999998e-262 -test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \ - {expr {1e-260}} \ - 9.9999999999999996e-261 -test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \ - {expr {1e-259}} \ - 1.0000000000000001e-259 -test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \ - {expr {1e-258}} \ - 9.9999999999999995e-259 -test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \ - {expr {1e-257}} \ - 9.9999999999999998e-258 -test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \ - {expr {1e-256}} \ - 9.9999999999999998e-257 -test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \ - {expr {1e-255}} \ - 1e-255 -test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \ - {expr {1e-254}} \ - 9.9999999999999991e-255 -test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \ - {expr {1e-253}} \ - 1.0000000000000001e-253 -test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \ - {expr {1e-252}} \ - 9.9999999999999994e-253 -test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \ - {expr {1e-251}} \ - 1e-251 -test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \ - {expr {1e-250}} \ - 1.0000000000000001e-250 -test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \ - {expr {1e-249}} \ - 1.0000000000000001e-249 -test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \ - {expr {1e-248}} \ - 9.9999999999999998e-249 -test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \ - {expr {1e-247}} \ - 1e-247 -test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \ - {expr {1e-246}} \ - 9.9999999999999996e-247 -test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \ - {expr {1e-245}} \ - 9.9999999999999993e-246 -test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \ - {expr {1e-244}} \ - 9.9999999999999993e-245 -test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \ - {expr {1e-243}} \ - 1e-243 -test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \ - {expr {1e-242}} \ - 9.9999999999999997e-243 -test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \ - {expr {1e-241}} \ - 9.9999999999999997e-242 -test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \ - {expr {1e-240}} \ - 9.9999999999999997e-241 -test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \ - {expr {1e-239}} \ - 1.0000000000000001e-239 -test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \ - {expr {1e-238}} \ - 9.9999999999999999e-239 -test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \ - {expr {1e-237}} \ - 9.9999999999999999e-238 -test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \ - {expr {1e-236}} \ - 1e-236 -test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \ - {expr {1e-235}} \ - 9.9999999999999996e-236 -test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \ - {expr {1e-234}} \ - 9.9999999999999996e-235 -test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \ - {expr {1e-233}} \ - 9.9999999999999996e-234 -test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \ - {expr {1e-232}} \ - 1e-232 -test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \ - {expr {1e-231}} \ - 9.9999999999999999e-232 -test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \ - {expr {1e-230}} \ - 1e-230 -test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \ - {expr {1e-229}} \ - 1.0000000000000001e-229 -test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \ - {expr {1e-228}} \ - 1e-228 -test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \ - {expr {1e-227}} \ - 9.9999999999999994e-228 -test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \ - {expr {1e-226}} \ - 9.9999999999999992e-227 -test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \ - {expr {1e-225}} \ - 9.9999999999999996e-226 -test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \ - {expr {1e-224}} \ - 1e-224 -test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \ - {expr {1e-223}} \ - 9.9999999999999997e-224 -test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \ - {expr {1e-222}} \ - 1e-222 -test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \ - {expr {1e-221}} \ - 1e-221 -test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \ - {expr {1e-220}} \ - 9.9999999999999999e-221 -test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \ - {expr {1e-219}} \ - 1e-219 -test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \ - {expr {1e-218}} \ - 1e-218 -test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \ - {expr {1e-217}} \ - 1.0000000000000001e-217 -test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \ - {expr {1e-216}} \ - 1e-216 -test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \ - {expr {1e-215}} \ - 1e-215 -test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \ - {expr {1e-214}} \ - 9.9999999999999991e-215 -test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \ - {expr {1e-213}} \ - 9.9999999999999995e-214 -test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \ - {expr {1e-212}} \ - 9.9999999999999995e-213 -test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \ - {expr {1e-211}} \ - 1.0000000000000001e-211 -test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \ - {expr {1e-210}} \ - 1e-210 -test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \ - {expr {1e-209}} \ - 1e-209 -test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \ - {expr {1e-208}} \ - 1.0000000000000001e-208 -test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \ - {expr {1e-207}} \ - 9.9999999999999993e-208 -test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \ - {expr {1e-206}} \ - 1e-206 -test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \ - {expr {1e-205}} \ - 1e-205 -test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \ - {expr {1e-204}} \ - 1e-204 -test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \ - {expr {1e-203}} \ - 1e-203 -test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \ - {expr {1e-202}} \ - 1e-202 -test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \ - {expr {1e-201}} \ - 9.9999999999999995e-202 -test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \ - {expr {1e-200}} \ - 9.9999999999999998e-201 -test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \ - {expr {1e-199}} \ - 9.9999999999999998e-200 -test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \ - {expr {1e-198}} \ - 9.9999999999999991e-199 -test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \ - {expr {1e-197}} \ - 9.9999999999999999e-198 -test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \ - {expr {1e-196}} \ - 1e-196 -test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \ - {expr {1e-195}} \ - 1.0000000000000001e-195 -test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \ - {expr {1e-194}} \ - 1e-194 -test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \ - {expr {1e-193}} \ - 1e-193 -test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \ - {expr {1e-192}} \ - 1.0000000000000001e-192 -test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \ - {expr {1e-191}} \ - 1e-191 -test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \ - {expr {1e-190}} \ - 1e-190 -test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \ - {expr {1e-189}} \ - 1.0000000000000001e-189 -test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \ - {expr {1e-188}} \ - 9.9999999999999995e-189 -test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \ - {expr {1e-187}} \ - 1e-187 -test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \ - {expr {1e-186}} \ - 9.9999999999999991e-187 -test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \ - {expr {1e-185}} \ - 9.9999999999999999e-186 -test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \ - {expr {1e-184}} \ - 1.0000000000000001e-184 -test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \ - {expr {1e-183}} \ - 1e-183 -test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \ - {expr {1e-182}} \ - 1e-182 -test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \ - {expr {1e-181}} \ - 1e-181 -test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \ - {expr {1e-180}} \ - 1e-180 -test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \ - {expr {1e-179}} \ - 1e-179 -test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \ - {expr {1e-178}} \ - 9.9999999999999995e-179 -test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \ - {expr {1e-177}} \ - 9.9999999999999995e-178 -test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \ - {expr {1e-176}} \ - 1e-176 -test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \ - {expr {1e-175}} \ - 1e-175 -test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \ - {expr {1e-174}} \ - 1e-174 -test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \ - {expr {1e-173}} \ - 1e-173 -test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \ - {expr {1e-172}} \ - 1e-172 -test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \ - {expr {1e-171}} \ - 9.9999999999999998e-172 -test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \ - {expr {1e-170}} \ - 9.9999999999999998e-171 -test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \ - {expr {1e-169}} \ - 1e-169 -test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \ - {expr {1e-168}} \ - 1e-168 -test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \ - {expr {1e-167}} \ - 1e-167 -test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \ - {expr {1e-166}} \ - 1e-166 -test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \ - {expr {1e-165}} \ - 1e-165 -test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \ - {expr {1e-164}} \ - 9.9999999999999996e-165 -test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \ - {expr {1e-163}} \ - 9.9999999999999992e-164 -test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \ - {expr {1e-162}} \ - 9.9999999999999995e-163 -test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \ - {expr {1e-161}} \ - 1e-161 -test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \ - {expr {1e-160}} \ - 9.9999999999999999e-161 -test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \ - {expr {1e-159}} \ - 9.9999999999999999e-160 -test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \ - {expr {1e-158}} \ - 1.0000000000000001e-158 -test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \ - {expr {1e-157}} \ - 9.9999999999999994e-158 -test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \ - {expr {1e-156}} \ - 1e-156 -test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \ - {expr {1e-155}} \ - 1e-155 -test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \ - {expr {1e-154}} \ - 9.9999999999999997e-155 -test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \ - {expr {1e-153}} \ - 1e-153 -test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \ - {expr {1e-152}} \ - 1.0000000000000001e-152 -test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \ - {expr {1e-151}} \ - 9.9999999999999994e-152 -test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \ - {expr {1e-150}} \ - 1e-150 -test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \ - {expr {1e-149}} \ - 9.9999999999999998e-150 -test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \ - {expr {1e-148}} \ - 9.9999999999999994e-149 -test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \ - {expr {1e-147}} \ - 9.9999999999999997e-148 -test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \ - {expr {1e-146}} \ - 1e-146 -test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \ - {expr {1e-145}} \ - 9.9999999999999991e-146 -test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \ - {expr {1e-144}} \ - 9.9999999999999995e-145 -test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \ - {expr {1e-143}} \ - 9.9999999999999995e-144 -test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \ - {expr {1e-142}} \ - 1e-142 -test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \ - {expr {1e-141}} \ - 1e-141 -test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \ - {expr {1e-140}} \ - 9.9999999999999998e-141 -test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \ - {expr {1e-139}} \ - 1e-139 -test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \ - {expr {1e-138}} \ - 1.0000000000000001e-138 -test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \ - {expr {1e-137}} \ - 9.9999999999999998e-138 -test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \ - {expr {1e-136}} \ - 1e-136 -test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \ - {expr {1e-135}} \ - 1e-135 -test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \ - {expr {1e-134}} \ - 1e-134 -test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \ - {expr {1e-133}} \ - 1.0000000000000001e-133 -test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \ - {expr {1e-132}} \ - 9.9999999999999999e-133 -test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \ - {expr {1e-131}} \ - 9.9999999999999999e-132 -test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \ - {expr {1e-130}} \ - 1.0000000000000001e-130 -test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \ - {expr {1e-129}} \ - 9.9999999999999993e-130 -test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \ - {expr {1e-128}} \ - 1.0000000000000001e-128 -test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \ - {expr {1e-127}} \ - 1e-127 -test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \ - {expr {1e-126}} \ - 9.9999999999999995e-127 -test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \ - {expr {1e-125}} \ - 1e-125 -test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \ - {expr {1e-124}} \ - 9.9999999999999993e-125 -test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \ - {expr {1e-123}} \ - 1.0000000000000001e-123 -test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \ - {expr {1e-122}} \ - 1.0000000000000001e-122 -test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \ - {expr {1e-121}} \ - 9.9999999999999998e-122 -test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \ - {expr {1e-120}} \ - 9.9999999999999998e-121 -test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \ - {expr {1e-119}} \ - 1e-119 -test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \ - {expr {1e-118}} \ - 9.9999999999999999e-119 -test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \ - {expr {1e-117}} \ - 1e-117 -test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \ - {expr {1e-116}} \ - 9.9999999999999999e-117 -test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \ - {expr {1e-115}} \ - 1.0000000000000001e-115 -test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \ - {expr {1e-114}} \ - 1.0000000000000001e-114 -test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \ - {expr {1e-113}} \ - 9.9999999999999998e-114 -test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \ - {expr {1e-112}} \ - 9.9999999999999995e-113 -test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \ - {expr {1e-111}} \ - 1.0000000000000001e-111 -test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \ - {expr {1e-110}} \ - 1.0000000000000001e-110 -test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \ - {expr {1e-109}} \ - 9.9999999999999999e-110 -test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \ - {expr {1e-108}} \ - 1e-108 -test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \ - {expr {1e-107}} \ - 1e-107 -test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \ - {expr {1e-106}} \ - 9.9999999999999994e-107 -test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \ - {expr {1e-105}} \ - 9.9999999999999997e-106 -test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \ - {expr {1e-104}} \ - 9.9999999999999993e-105 -test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \ - {expr {1e-103}} \ - 9.9999999999999996e-104 -test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \ - {expr {1e-102}} \ - 9.9999999999999993e-103 -test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \ - {expr {1e-101}} \ - 1.0000000000000001e-101 -test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \ - {expr {1e-100}} \ - 1e-100 -test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \ - {expr {1e-99}} \ - 1e-99 -test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \ - {expr {1e-98}} \ - 9.9999999999999994e-99 -test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \ - {expr {1e-97}} \ - 1e-97 -test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \ - {expr {1e-96}} \ - 9.9999999999999991e-97 -test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \ - {expr {1e-95}} \ - 9.9999999999999999e-96 -test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \ - {expr {1e-94}} \ - 9.9999999999999996e-95 -test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \ - {expr {1e-93}} \ - 9.999999999999999e-94 -test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \ - {expr {1e-92}} \ - 9.9999999999999999e-93 -test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \ - {expr {1e-91}} \ - 1e-91 -test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \ - {expr {1e-90}} \ - 9.9999999999999999e-91 -test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \ - {expr {1e-89}} \ - 1e-89 -test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \ - {expr {1e-88}} \ - 9.9999999999999993e-89 -test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \ - {expr {1e-87}} \ - 1e-87 -test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \ - {expr {1e-86}} \ - 1.0000000000000001e-86 -test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \ - {expr {1e-85}} \ - 9.9999999999999998e-86 -test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \ - {expr {1e-84}} \ - 1e-84 -test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \ - {expr {1e-83}} \ - 1e-83 -test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \ - {expr {1e-82}} \ - 9.9999999999999996e-83 -test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \ - {expr {1e-81}} \ - 9.9999999999999996e-82 -test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \ - {expr {1e-80}} \ - 9.9999999999999996e-81 -test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \ - {expr {1e-79}} \ - 1e-79 -test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \ - {expr {1e-78}} \ - 1e-78 -test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \ - {expr {1e-77}} \ - 9.9999999999999993e-78 -test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \ - {expr {1e-76}} \ - 9.9999999999999993e-77 -test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \ - {expr {1e-75}} \ - 9.9999999999999996e-76 -test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \ - {expr {1e-74}} \ - 9.9999999999999996e-75 -test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \ - {expr {1e-73}} \ - 1e-73 -test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \ - {expr {1e-72}} \ - 9.9999999999999997e-73 -test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \ - {expr {1e-71}} \ - 9.9999999999999992e-72 -test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \ - {expr {1e-70}} \ - 1e-70 -test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \ - {expr {1e-69}} \ - 9.9999999999999996e-70 -test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \ - {expr {1e-68}} \ - 1.0000000000000001e-68 -test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \ - {expr {1e-67}} \ - 9.9999999999999994e-68 -test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \ - {expr {1e-66}} \ - 9.9999999999999998e-67 -test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \ - {expr {1e-65}} \ - 9.9999999999999992e-66 -test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \ - {expr {1e-64}} \ - 9.9999999999999997e-65 -test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \ - {expr {1e-63}} \ - 1.0000000000000001e-63 -test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \ - {expr {1e-62}} \ - 1e-62 -test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \ - {expr {1e-61}} \ - 1e-61 -test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \ - {expr {1e-60}} \ - 9.9999999999999997e-61 -test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \ - {expr {1e-59}} \ - 1e-59 -test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \ - {expr {1e-58}} \ - 1e-58 -test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \ - {expr {1e-57}} \ - 9.9999999999999995e-58 -test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \ - {expr {1e-56}} \ - 1e-56 -test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \ - {expr {1e-55}} \ - 9.9999999999999999e-56 -test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \ - {expr {1e-54}} \ - 1e-54 -test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \ - {expr {1e-53}} \ - 1e-53 -test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \ - {expr {1e-52}} \ - 1e-52 -test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \ - {expr {1e-51}} \ - 1e-51 -test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \ - {expr {1e-50}} \ - 1e-50 -test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \ - {expr {1e-49}} \ - 9.9999999999999994e-50 -test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \ - {expr {1e-48}} \ - 9.9999999999999997e-49 -test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \ - {expr {1e-47}} \ - 9.9999999999999997e-48 -test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \ - {expr {1e-46}} \ - 1e-46 -test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \ - {expr {1e-45}} \ - 9.9999999999999998e-46 -test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \ - {expr {1e-44}} \ - 9.9999999999999995e-45 -test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \ - {expr {1e-43}} \ - 1.0000000000000001e-43 -test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \ - {expr {1e-42}} \ - 1e-42 -test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \ - {expr {1e-41}} \ - 1e-41 -test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \ - {expr {1e-40}} \ - 9.9999999999999993e-41 -test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \ - {expr {1e-39}} \ - 9.9999999999999993e-40 -test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \ - {expr {1e-38}} \ - 9.9999999999999996e-39 -test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \ - {expr {1e-37}} \ - 1.0000000000000001e-37 -test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \ - {expr {1e-36}} \ - 9.9999999999999994e-37 -test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \ - {expr {1e-35}} \ - 1e-35 -test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \ - {expr {1e-34}} \ - 9.9999999999999993e-35 -test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \ - {expr {1e-33}} \ - 1.0000000000000001e-33 -test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \ - {expr {1e-32}} \ - 1.0000000000000001e-32 -test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \ - {expr {1e-31}} \ - 1.0000000000000001e-31 -test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \ - {expr {1e-30}} \ - 1.0000000000000001e-30 -test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \ - {expr {1e-29}} \ - 9.9999999999999994e-30 -test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \ - {expr {1e-28}} \ - 9.9999999999999997e-29 -test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \ - {expr {1e-27}} \ - 1e-27 -test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \ - {expr {1e-26}} \ - 1e-26 -test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \ - {expr {1e-25}} \ - 1e-25 -test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \ - {expr {1e-24}} \ - 9.9999999999999992e-25 -test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \ - {expr {1e-23}} \ - 9.9999999999999996e-24 -test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \ - {expr {1e-22}} \ - 1e-22 -test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \ - {expr {1e-21}} \ - 9.9999999999999991e-22 -test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \ - {expr {1e-20}} \ - 9.9999999999999995e-21 -test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \ - {expr {1e-19}} \ - 9.9999999999999998e-20 -test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \ - {expr {1e-18}} \ - 1.0000000000000001e-18 -test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \ - {expr {1e-17}} \ - 1.0000000000000001e-17 -test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \ - {expr {1e-16}} \ - 9.9999999999999998e-17 -test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \ - {expr {1e-15}} \ - 1.0000000000000001e-15 -test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \ - {expr {1e-14}} \ - 1e-14 -test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \ - {expr {1e-13}} \ - 1e-13 -test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \ - {expr {1e-12}} \ - 9.9999999999999998e-13 -test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \ - {expr {1e-11}} \ - 9.9999999999999994e-12 -test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \ - {expr {1e-10}} \ - 1e-10 -test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \ - {expr {1e-9}} \ - 1.0000000000000001e-09 -test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \ - {expr {1e-8}} \ - 1e-08 -test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \ - {expr {1e-7}} \ - 9.9999999999999995e-08 -test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \ - {expr {1e-6}} \ - 9.9999999999999995e-07 -test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \ - {expr {1e-5}} \ - 1.0000000000000001e-05 -test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \ - {expr {1e-4}} \ - 0.0001 -test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \ - {expr {1e-3}} \ - 0.001 -test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \ - {expr {1e-2}} \ - 0.01 -test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \ - {expr {1e-1}} \ - 0.10000000000000001 -test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \ - {expr {1e0}} \ - 1.0 -test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \ - {expr {1e1}} \ - 10.0 -test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \ - {expr {1e2}} \ - 100.0 -test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \ - {expr {1e3}} \ - 1000.0 -test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \ - {expr {1e4}} \ - 10000.0 -test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \ - {expr {1e5}} \ - 100000.0 -test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \ - {expr {1e6}} \ - 1000000.0 -test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \ - {expr {1e7}} \ - 10000000.0 -test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \ - {expr {1e8}} \ - 100000000.0 -test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \ - {expr {1e9}} \ - 1000000000.0 -test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \ - {expr {1e10}} \ - 10000000000.0 -test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \ - {expr {1e11}} \ - 100000000000.0 -test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \ - {expr {1e12}} \ - 1000000000000.0 -test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \ - {expr {1e13}} \ - 10000000000000.0 -test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \ - {expr {1e14}} \ - 100000000000000.0 -test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \ - {expr {1e15}} \ - 1000000000000000.0 -test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \ - {expr {1e16}} \ - 10000000000000000.0 -test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \ - {expr {1e17}} \ - 1e+17 -test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \ - {expr {1e18}} \ - 1e+18 -test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \ - {expr {1e19}} \ - 1e+19 -test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \ - {expr {1e20}} \ - 1e+20 -test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \ - {expr {1e21}} \ - 1e+21 -test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \ - {expr {1e22}} \ - 1e+22 -test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \ - {expr {1e23}} \ - 9.9999999999999992e+22 -test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \ - {expr {1e24}} \ - 9.9999999999999998e+23 -test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \ - {expr {1e25}} \ - 1.0000000000000001e+25 -test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \ - {expr {1e26}} \ - 1e+26 -test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \ - {expr {1e27}} \ - 1e+27 -test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \ - {expr {1e28}} \ - 9.9999999999999996e+27 -test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \ - {expr {1e29}} \ - 9.9999999999999991e+28 -test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \ - {expr {1e30}} \ - 1e+30 -test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \ - {expr {1e31}} \ - 9.9999999999999996e+30 -test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \ - {expr {1e32}} \ - 1.0000000000000001e+32 -test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \ - {expr {1e33}} \ - 9.9999999999999995e+32 -test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \ - {expr {1e34}} \ - 9.9999999999999995e+33 -test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \ - {expr {1e35}} \ - 9.9999999999999997e+34 -test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \ - {expr {1e36}} \ - 1e+36 -test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \ - {expr {1e37}} \ - 9.9999999999999995e+36 -test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \ - {expr {1e38}} \ - 9.9999999999999998e+37 -test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \ - {expr {1e39}} \ - 9.9999999999999994e+38 -test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \ - {expr {1e40}} \ - 1e+40 -test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \ - {expr {1e41}} \ - 1e+41 -test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \ - {expr {1e42}} \ - 1e+42 -test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \ - {expr {1e43}} \ - 1e+43 -test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \ - {expr {1e44}} \ - 1.0000000000000001e+44 -test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \ - {expr {1e45}} \ - 9.9999999999999993e+44 -test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \ - {expr {1e46}} \ - 9.9999999999999999e+45 -test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \ - {expr {1e47}} \ - 1e+47 -test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \ - {expr {1e48}} \ - 1e+48 -test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \ - {expr {1e49}} \ - 9.9999999999999995e+48 -test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \ - {expr {1e50}} \ - 1.0000000000000001e+50 -test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \ - {expr {1e51}} \ - 9.9999999999999999e+50 -test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \ - {expr {1e52}} \ - 9.9999999999999999e+51 -test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \ - {expr {1e53}} \ - 9.9999999999999999e+52 -test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \ - {expr {1e54}} \ - 1.0000000000000001e+54 -test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \ - {expr {1e55}} \ - 1e+55 -test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \ - {expr {1e56}} \ - 1.0000000000000001e+56 -test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \ - {expr {1e57}} \ - 1e+57 -test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \ - {expr {1e58}} \ - 9.9999999999999994e+57 -test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \ - {expr {1e59}} \ - 9.9999999999999997e+58 -test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \ - {expr {1e60}} \ - 9.9999999999999995e+59 -test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \ - {expr {1e61}} \ - 9.9999999999999995e+60 -test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \ - {expr {1e62}} \ - 1e+62 -test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \ - {expr {1e63}} \ - 1.0000000000000001e+63 -test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \ - {expr {1e64}} \ - 1e+64 -test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \ - {expr {1e65}} \ - 9.9999999999999999e+64 -test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \ - {expr {1e66}} \ - 9.9999999999999995e+65 -test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \ - {expr {1e67}} \ - 9.9999999999999998e+66 -test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \ - {expr {1e68}} \ - 9.9999999999999995e+67 -test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \ - {expr {1e69}} \ - 1.0000000000000001e+69 -test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \ - {expr {1e70}} \ - 1.0000000000000001e+70 -test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \ - {expr {1e71}} \ - 1e+71 -test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \ - {expr {1e72}} \ - 9.9999999999999994e+71 -test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \ - {expr {1e73}} \ - 9.9999999999999998e+72 -test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \ - {expr {1e74}} \ - 9.9999999999999995e+73 -test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \ - {expr {1e75}} \ - 9.9999999999999993e+74 -test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \ - {expr {1e76}} \ - 1e+76 -test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \ - {expr {1e77}} \ - 9.9999999999999998e+76 -test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \ - {expr {1e78}} \ - 1e+78 -test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \ - {expr {1e79}} \ - 9.9999999999999997e+78 -test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \ - {expr {1e80}} \ - 1e+80 -test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \ - {expr {1e81}} \ - 9.9999999999999992e+80 -test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \ - {expr {1e82}} \ - 9.9999999999999996e+81 -test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \ - {expr {1e83}} \ - 1e+83 -test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \ - {expr {1e84}} \ - 1.0000000000000001e+84 -test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \ - {expr {1e85}} \ - 1e+85 -test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \ - {expr {1e86}} \ - 1e+86 -test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \ - {expr {1e87}} \ - 9.9999999999999996e+86 -test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \ - {expr {1e88}} \ - 9.9999999999999996e+87 -test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \ - {expr {1e89}} \ - 9.9999999999999999e+88 -test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \ - {expr {1e90}} \ - 9.9999999999999997e+89 -test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \ - {expr {1e91}} \ - 1.0000000000000001e+91 -test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \ - {expr {1e92}} \ - 1e+92 -test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \ - {expr {1e93}} \ - 1e+93 -test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \ - {expr {1e94}} \ - 1e+94 -test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \ - {expr {1e95}} \ - 1e+95 -test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \ - {expr {1e96}} \ - 1e+96 -test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \ - {expr {1e97}} \ - 1.0000000000000001e+97 -test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \ - {expr {1e98}} \ - 1e+98 -test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \ - {expr {1e99}} \ - 9.9999999999999997e+98 -test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \ - {expr {1e100}} \ - 1e+100 -test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \ - {expr {1e101}} \ - 9.9999999999999998e+100 -test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \ - {expr {1e102}} \ - 9.9999999999999998e+101 -test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \ - {expr {1e103}} \ - 1e+103 -test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \ - {expr {1e104}} \ - 1e+104 -test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \ - {expr {1e105}} \ - 9.9999999999999994e+104 -test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \ - {expr {1e106}} \ - 1.0000000000000001e+106 -test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \ - {expr {1e107}} \ - 9.9999999999999997e+106 -test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \ - {expr {1e108}} \ - 1e+108 -test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \ - {expr {1e109}} \ - 9.9999999999999998e+108 -test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \ - {expr {1e110}} \ - 1e+110 -test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \ - {expr {1e111}} \ - 9.9999999999999996e+110 -test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \ - {expr {1e112}} \ - 9.9999999999999993e+111 -test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \ - {expr {1e113}} \ - 1e+113 -test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \ - {expr {1e114}} \ - 1e+114 -test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \ - {expr {1e115}} \ - 1e+115 -test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \ - {expr {1e116}} \ - 1e+116 -test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \ - {expr {1e117}} \ - 1.0000000000000001e+117 -test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \ - {expr {1e118}} \ - 9.9999999999999997e+117 -test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \ - {expr {1e119}} \ - 9.9999999999999994e+118 -test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \ - {expr {1e120}} \ - 9.9999999999999998e+119 -test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \ - {expr {1e121}} \ - 1e+121 -test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \ - {expr {1e122}} \ - 1e+122 -test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \ - {expr {1e123}} \ - 9.9999999999999998e+122 -test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \ - {expr {1e124}} \ - 9.9999999999999995e+123 -test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \ - {expr {1e125}} \ - 9.9999999999999992e+124 -test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \ - {expr {1e126}} \ - 9.9999999999999992e+125 -test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \ - {expr {1e127}} \ - 9.9999999999999995e+126 -test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \ - {expr {1e128}} \ - 1.0000000000000001e+128 -test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \ - {expr {1e129}} \ - 1e+129 -test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \ - {expr {1e130}} \ - 1.0000000000000001e+130 -test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \ - {expr {1e131}} \ - 9.9999999999999991e+130 -test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \ - {expr {1e132}} \ - 9.9999999999999999e+131 -test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \ - {expr {1e133}} \ - 1e+133 -test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \ - {expr {1e134}} \ - 9.9999999999999992e+133 -test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \ - {expr {1e135}} \ - 9.9999999999999996e+134 -test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \ - {expr {1e136}} \ - 1.0000000000000001e+136 -test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \ - {expr {1e137}} \ - 1e+137 -test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \ - {expr {1e138}} \ - 1e+138 -test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \ - {expr {1e139}} \ - 1e+139 -test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \ - {expr {1e140}} \ - 1.0000000000000001e+140 -test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \ - {expr {1e141}} \ - 1e+141 -test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \ - {expr {1e142}} \ - 1.0000000000000001e+142 -test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \ - {expr {1e143}} \ - 1e+143 -test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \ - {expr {1e144}} \ - 1e+144 -test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \ - {expr {1e145}} \ - 9.9999999999999999e+144 -test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \ - {expr {1e146}} \ - 9.9999999999999993e+145 -test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \ - {expr {1e147}} \ - 9.9999999999999998e+146 -test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \ - {expr {1e148}} \ - 1e+148 -test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \ - {expr {1e149}} \ - 1e+149 -test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \ - {expr {1e150}} \ - 9.9999999999999998e+149 -test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \ - {expr {1e151}} \ - 1e+151 -test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \ - {expr {1e152}} \ - 1e+152 -test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \ - {expr {1e153}} \ - 1e+153 -test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \ - {expr {1e154}} \ - 1e+154 -test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \ - {expr {1e155}} \ - 1e+155 -test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \ - {expr {1e156}} \ - 9.9999999999999998e+155 -test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \ - {expr {1e157}} \ - 9.9999999999999998e+156 -test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \ - {expr {1e158}} \ - 9.9999999999999995e+157 -test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \ - {expr {1e159}} \ - 9.9999999999999993e+158 -test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \ - {expr {1e160}} \ - 1e+160 -test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \ - {expr {1e161}} \ - 1e+161 -test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \ - {expr {1e162}} \ - 9.9999999999999994e+161 -test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \ - {expr {1e163}} \ - 9.9999999999999994e+162 -test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \ - {expr {1e164}} \ - 1e+164 -test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \ - {expr {1e165}} \ - 9.999999999999999e+164 -test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \ - {expr {1e166}} \ - 9.9999999999999994e+165 -test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \ - {expr {1e167}} \ - 1e+167 -test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \ - {expr {1e168}} \ - 9.9999999999999993e+167 -test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \ - {expr {1e169}} \ - 9.9999999999999993e+168 -test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \ - {expr {1e170}} \ - 1e+170 -test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \ - {expr {1e171}} \ - 9.9999999999999995e+170 -test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \ - {expr {1e172}} \ - 1.0000000000000001e+172 -test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \ - {expr {1e173}} \ - 1e+173 -test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \ - {expr {1e174}} \ - 1.0000000000000001e+174 -test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \ - {expr {1e175}} \ - 9.9999999999999994e+174 -test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \ - {expr {1e176}} \ - 1e+176 -test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \ - {expr {1e177}} \ - 1e+177 -test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \ - {expr {1e178}} \ - 1.0000000000000001e+178 -test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \ - {expr {1e179}} \ - 9.9999999999999998e+178 -test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \ - {expr {1e180}} \ - 1e+180 -test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \ - {expr {1e181}} \ - 9.9999999999999992e+180 -test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \ - {expr {1e182}} \ - 1.0000000000000001e+182 -test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \ - {expr {1e183}} \ - 9.9999999999999995e+182 -test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \ - {expr {1e184}} \ - 1e+184 -test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \ - {expr {1e185}} \ - 9.9999999999999998e+184 -test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \ - {expr {1e186}} \ - 9.9999999999999998e+185 -test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \ - {expr {1e187}} \ - 9.9999999999999991e+186 -test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \ - {expr {1e188}} \ - 1e+188 -test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \ - {expr {1e189}} \ - 1e+189 -test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \ - {expr {1e190}} \ - 1.0000000000000001e+190 -test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \ - {expr {1e191}} \ - 1.0000000000000001e+191 -test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \ - {expr {1e192}} \ - 1e+192 -test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \ - {expr {1e193}} \ - 1.0000000000000001e+193 -test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \ - {expr {1e194}} \ - 9.9999999999999994e+193 -test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \ - {expr {1e195}} \ - 9.9999999999999998e+194 -test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \ - {expr {1e196}} \ - 9.9999999999999995e+195 -test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \ - {expr {1e197}} \ - 9.9999999999999995e+196 -test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \ - {expr {1e198}} \ - 1e+198 -test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \ - {expr {1e199}} \ - 1.0000000000000001e+199 -test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \ - {expr {1e200}} \ - 9.9999999999999997e+199 -test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \ - {expr {1e201}} \ - 1e+201 -test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \ - {expr {1e202}} \ - 9.999999999999999e+201 -test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \ - {expr {1e203}} \ - 9.9999999999999999e+202 -test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \ - {expr {1e204}} \ - 9.9999999999999999e+203 -test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \ - {expr {1e205}} \ - 1e+205 -test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \ - {expr {1e206}} \ - 1e+206 -test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \ - {expr {1e207}} \ - 1e+207 -test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \ - {expr {1e208}} \ - 9.9999999999999998e+207 -test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \ - {expr {1e209}} \ - 1.0000000000000001e+209 -test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \ - {expr {1e210}} \ - 9.9999999999999993e+209 -test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \ - {expr {1e211}} \ - 9.9999999999999996e+210 -test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \ - {expr {1e212}} \ - 9.9999999999999991e+211 -test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \ - {expr {1e213}} \ - 9.9999999999999998e+212 -test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \ - {expr {1e214}} \ - 9.9999999999999995e+213 -test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \ - {expr {1e215}} \ - 9.9999999999999991e+214 -test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \ - {expr {1e216}} \ - 1e+216 -test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \ - {expr {1e217}} \ - 9.9999999999999996e+216 -test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \ - {expr {1e218}} \ - 1.0000000000000001e+218 -test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \ - {expr {1e219}} \ - 9.9999999999999997e+218 -test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \ - {expr {1e220}} \ - 1e+220 -test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \ - {expr {1e221}} \ - 1e+221 -test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \ - {expr {1e222}} \ - 1e+222 -test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \ - {expr {1e223}} \ - 1e+223 -test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \ - {expr {1e224}} \ - 9.9999999999999997e+223 -test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \ - {expr {1e225}} \ - 9.9999999999999993e+224 -test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \ - {expr {1e226}} \ - 9.9999999999999996e+225 -test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \ - {expr {1e227}} \ - 1.0000000000000001e+227 -test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \ - {expr {1e228}} \ - 9.9999999999999992e+227 -test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \ - {expr {1e229}} \ - 9.9999999999999999e+228 -test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \ - {expr {1e230}} \ - 1.0000000000000001e+230 -test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \ - {expr {1e231}} \ - 1.0000000000000001e+231 -test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \ - {expr {1e232}} \ - 1.0000000000000001e+232 -test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \ - {expr {1e233}} \ - 9.9999999999999997e+232 -test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \ - {expr {1e234}} \ - 1e+234 -test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \ - {expr {1e235}} \ - 1.0000000000000001e+235 -test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \ - {expr {1e236}} \ - 1.0000000000000001e+236 -test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \ - {expr {1e237}} \ - 9.9999999999999994e+236 -test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \ - {expr {1e238}} \ - 1e+238 -test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \ - {expr {1e239}} \ - 9.9999999999999999e+238 -test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \ - {expr {1e240}} \ - 1e+240 -test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \ - {expr {1e241}} \ - 1.0000000000000001e+241 -test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \ - {expr {1e242}} \ - 1.0000000000000001e+242 -test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \ - {expr {1e243}} \ - 1.0000000000000001e+243 -test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \ - {expr {1e244}} \ - 1.0000000000000001e+244 -test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \ - {expr {1e245}} \ - 1e+245 -test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \ - {expr {1e246}} \ - 1.0000000000000001e+246 -test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \ - {expr {1e247}} \ - 9.9999999999999995e+246 -test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \ - {expr {1e248}} \ - 1e+248 -test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \ - {expr {1e249}} \ - 9.9999999999999992e+248 -test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \ - {expr {1e250}} \ - 9.9999999999999992e+249 -test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \ - {expr {1e251}} \ - 1e+251 -test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \ - {expr {1e252}} \ - 1.0000000000000001e+252 -test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \ - {expr {1e253}} \ - 9.9999999999999994e+252 -test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \ - {expr {1e254}} \ - 9.9999999999999994e+253 -test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \ - {expr {1e255}} \ - 9.9999999999999999e+254 -test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \ - {expr {1e256}} \ - 1e+256 -test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \ - {expr {1e257}} \ - 1e+257 -test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \ - {expr {1e258}} \ - 1.0000000000000001e+258 -test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \ - {expr {1e259}} \ - 9.9999999999999993e+258 -test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \ - {expr {1e260}} \ - 1.0000000000000001e+260 -test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \ - {expr {1e261}} \ - 9.9999999999999993e+260 -test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \ - {expr {1e262}} \ - 1e+262 -test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \ - {expr {1e263}} \ - 1e+263 -test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \ - {expr {1e264}} \ - 1e+264 -test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \ - {expr {1e265}} \ - 1.0000000000000001e+265 -test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \ - {expr {1e266}} \ - 1e+266 -test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \ - {expr {1e267}} \ - 9.9999999999999997e+266 -test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \ - {expr {1e268}} \ - 9.9999999999999997e+267 -test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \ - {expr {1e269}} \ - 1e+269 -test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \ - {expr {1e270}} \ - 1e+270 -test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \ - {expr {1e271}} \ - 9.9999999999999995e+270 -test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \ - {expr {1e272}} \ - 1.0000000000000001e+272 -test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \ - {expr {1e273}} \ - 9.9999999999999995e+272 -test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \ - {expr {1e274}} \ - 9.9999999999999992e+273 -test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \ - {expr {1e275}} \ - 9.9999999999999996e+274 -test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \ - {expr {1e276}} \ - 1.0000000000000001e+276 -test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \ - {expr {1e277}} \ - 1e+277 -test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \ - {expr {1e278}} \ - 9.9999999999999996e+277 -test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \ - {expr {1e279}} \ - 1.0000000000000001e+279 -test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \ - {expr {1e280}} \ - 1e+280 -test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \ - {expr {1e281}} \ - 1e+281 -test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \ - {expr {1e282}} \ - 1e+282 -test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \ - {expr {1e283}} \ - 9.9999999999999996e+282 -test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \ - {expr {1e284}} \ - 1.0000000000000001e+284 -test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \ - {expr {1e285}} \ - 9.9999999999999998e+284 -test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \ - {expr {1e286}} \ - 1e+286 -test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \ - {expr {1e287}} \ - 1.0000000000000001e+287 -test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \ - {expr {1e288}} \ - 1e+288 -test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \ - {expr {1e289}} \ - 1.0000000000000001e+289 -test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \ - {expr {1e290}} \ - 1.0000000000000001e+290 -test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \ - {expr {1e291}} \ - 9.9999999999999996e+290 -test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \ - {expr {1e292}} \ - 1e+292 -test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \ - {expr {1e293}} \ - 9.9999999999999992e+292 -test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \ - {expr {1e294}} \ - 1.0000000000000001e+294 -test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \ - {expr {1e295}} \ - 9.9999999999999998e+294 -test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \ - {expr {1e296}} \ - 9.9999999999999998e+295 -test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \ - {expr {1e297}} \ - 1e+297 -test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \ - {expr {1e298}} \ - 9.9999999999999996e+297 -test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \ - {expr {1e299}} \ - 1.0000000000000001e+299 -test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \ - {expr {1e300}} \ - 1.0000000000000001e+300 -test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \ - {expr {1e301}} \ - 1.0000000000000001e+301 -test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \ - {expr {1e302}} \ - 1.0000000000000001e+302 -test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \ - {expr {1e303}} \ - 1e+303 -test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \ - {expr {1e304}} \ - 9.9999999999999994e+303 -test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \ - {expr {1e305}} \ - 9.9999999999999994e+304 -test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \ - {expr {1e306}} \ - 1e+306 -test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \ - {expr {1e307}} \ - 9.9999999999999999e+306 - test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { set r {} foreach {input} { @@ -4187,10 +2240,6 @@ test util-18.14 {Tcl_ObjPrintf} -constraints {testprint longIs64bit} -body { testprint "%llu %zu %lu" -1 } -result {18446744073709551615 18446744073709551615 18446744073709551615} -if {[catch {set ::tcl_precision $saved_precision}]} { - unset ::tcl_precision -} - # cleanup ::tcltest::cleanupTests return diff --git a/tests/var.test b/tests/var.test index 5300adc..405a4b8 100644 --- a/tests/var.test +++ b/tests/var.test @@ -269,10 +269,11 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 1 a {} vv namespace + testupvar 2 a {} vv namespace } p } + # Modified: that should create a global var according to the docs! list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { @@ -464,7 +465,7 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { set six 666 namespace eval test_ns_var { variable five 5 six - lappend a $five + lappend ::a $five } lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six @@ -491,9 +492,9 @@ test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, l set a "" namespace eval test_ns_var { variable eight 8 - lappend a $eight + lappend ::a $eight variable eight - lappend a $eight + lappend ::a $eight } set a } {8 8} @@ -1479,6 +1480,781 @@ test var-24.24 {array default unset: errors} -setup { } -returnCodes error -cleanup { unset -nocomplain ary } -result * -match glob + +# The const command +test var-25.1 {const: no argument} -body { + apply {{} { + const + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.2 {const: single argument} -body { + apply {{} { + const X + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.3 {const: two arguments (basic correct usage)} { + apply {{} { + set res [const X gorp] + return [list $res $X] + }} +} {{} gorp} +test var-25.4 {const: three arguments} -body { + apply {{} { + const X gorp foo + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} +test var-25.5 {const: four arguments} -body { + apply {{} { + const X gorp foo bar + return $X + }} +} -returnCodes error -result {wrong # args: should be "const varName value"} + +test var-26.1 {const: unmodifiable by set} -body { + apply {{} { + const X 123 + set X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.2 {const: unmodifiable by append} -body { + apply {{} { + const X 123 + append X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.3 {const: unmodifiable by lappend} -body { + apply {{} { + const X 123 + lappend X gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.4 {const: unmodifiable by incr} -body { + apply {{} { + const X 123 + incr X + }} +} -returnCodes error -result {can't incr "X": variable is a constant} +test var-26.5 {const: unmodifiable by dict set} -body { + apply {{} { + const X {a 123} + dict set X a gorp + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.6 {const: unmodifiable by regsub} -body { + apply {{} { + const X abcabc + regsub -all {a(.)} $X {\1\1} X + }} +} -returnCodes error -result {can't set "X": variable is a constant} +test var-26.7 {const: unmodifiable by gets} -setup { + set file [makeFile foo var26.7.txt] + set f [open $file] +} -body { + apply {f { + const X abcabc + gets $f X + }} $f +} -returnCodes error -cleanup { + close $f + removeFile $file +} -result {can't set "X": variable is a constant} +test var-26.8 {const: may not be array} -body { + apply {{} { + array set X {a b} + const X 1 + return $X + }} +} -returnCodes error -result {can't make constant "X": variable is array} +test var-26.9.1 {const: may not be array element} -body { + apply {{} { + array set X {a b} + const X(a) 1 + return $X(a) + }} +} -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} +test var-26.9.2 {const: may not be array element} -body { + apply {{} { + array set X {a b} + const X(b) 1 + return $X(b) + }} +} -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} +test var-26.10.1 {const: unmodifiable by const but not an error} { + apply {{} { + const X 1 + const X 2 + return $X + }} +} 1 +test var-26.10.2 {const: unmodifiable by const but not an error} { + apply {{} { + lmap x {1 2 3} { + const A 2 + const B 3 + const C 5 + expr {$A * $x**2 + $B * $x + $C} + } + }} +} {10 19 32} +test var-26.11 {const: may not be unset} -body { + apply {{} { + const X 1 + unset X + }} +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-26.12 {const: may not be unset, but -nocomplain doesn't complain} { + apply {{} { + const X 1 + unset -nocomplain X + return $X + }} +} 1 +test var-26.13 {const and traces: write trace causes fail} -body { + apply {{} { + trace add variable X write {apply {args { + error "ERR: $args" + }}} + const X gorp + return $X + }} +} -returnCodes error -result {can't set "X": ERR: X {} write} +test var-26.14 {const and traces: write trace err causes no const} -body { + apply {{} { + set trace {apply {args { + error "ERR: $args" + }}} + trace add variable X write $trace + catch { + const X gorp + } + trace remove variable X write $trace + set X 123 + return $X + }} +} -result 123 +test var-26.15 {const and traces: read traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {{} { + trace add variable X read {apply {args { + lappend ::traces $args + }}} + const X gorp + list $X $X $::traces + }} +} -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { + unset -nocomplain traces +} +test var-26.16 {const and traces: write traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {{} { + trace add variable X write {apply {args { + lappend ::traces $args + }}} + const X gorp + const X foo + catch {set X bar} + list $X $::traces + }} +} -result {gorp {{X {} write}}} -cleanup { + unset -nocomplain traces +} +test var-26.17 {const and traces: unset traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + list {*}[apply {{} { + trace add variable X unset {apply {args { + lappend ::traces $args + }}} + const X gorp + unset -nocomplain X + list $X $::traces + }}] $traces +} -result {gorp {} {{X {} unset}}} -cleanup { + unset -nocomplain traces +} + +# Same [const], but definitely not compiled +test var-27.1 {const: unmodifiable by set} -body { + apply {const { + $const X 123 + set X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.2 {const: unmodifiable by append} -body { + apply {const { + $const X 123 + append X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.3 {const: unmodifiable by lappend} -body { + apply {const { + $const X 123 + lappend X gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.4 {const: unmodifiable by incr} -body { + apply {const { + $const X 123 + incr X + }} const +} -returnCodes error -result {can't incr "X": variable is a constant} +test var-27.5 {const: unmodifiable by dict set} -body { + apply {const { + $const X {a 123} + dict set X a gorp + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.6 {const: unmodifiable by regsub} -body { + apply {const { + $const X abcabc + regsub -all {a(.)} $X {\1\1} X + }} const +} -returnCodes error -result {can't set "X": variable is a constant} +test var-27.7 {const: unmodifiable by gets} -setup { + set file [makeFile foo var27.7.txt] + set f [open $file] +} -body { + apply {{const f} { + $const X abcabc + gets $f X + }} const $f +} -returnCodes error -cleanup { + close $f + removeFile $file +} -result {can't set "X": variable is a constant} +test var-27.8 {const: may not be array} -body { + apply {const { + array set X {a b} + $const X 1 + return $X + }} const +} -returnCodes error -result {can't make constant "X": variable is array} +test var-27.9.1 {const: may not be array element} -body { + apply {const { + array set X {a b} + $const X(a) 1 + return $X(a) + }} const +} -returnCodes error -result {can't make constant "X(a)": name refers to an element in an array} +test var-27.9.2 {const: may not be array element} -body { + apply {const { + array set X {a b} + $const X(b) 1 + return $X(b) + }} const +} -returnCodes error -result {can't make constant "X(b)": name refers to an element in an array} +test var-27.10.1 {const: unmodifiable by const but not an error} { + apply {const { + $const X 1 + $const X 2 + return $X + }} const +} 1 +test var-27.10.2 {const: unmodifiable by const but not an error} { + apply {const { + lmap x {1 2 3} { + $const A 2 + $const B 3 + $const C 5 + expr {$A * $x**2 + $B * $x + $C} + } + }} const +} {10 19 32} +test var-27.11 {const: may not be unset} -body { + apply {const { + $const X 1 + unset X + }} const +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-27.12 {const: may not be unset, but -nocomplain doesn't complain} { + apply {const { + $const X 1 + unset -nocomplain X + return $X + }} const +} 1 +test var-27.13 {const and traces: write trace causes fail} -body { + apply {const { + trace add variable X write {apply {args { + error "ERR: $args" + }}} + $const X gorp + return $X + }} const +} -returnCodes error -result {can't set "X": ERR: X {} write} +test var-27.14 {const and traces: write trace err causes no const} -body { + apply {const { + set trace {apply {args { + error "ERR: $args" + }}} + trace add variable X write $trace + catch { + $const X gorp + } + trace remove variable X write $trace + set X 123 + return $X + }} const +} -result 123 +test var-27.15 {const and traces: read traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {const { + trace add variable X read {apply {args { + lappend ::traces $args + }}} + $const X gorp + list $X $X $::traces + }} const +} -result {gorp gorp {{X {} read} {X {} read}}} -cleanup { + unset -nocomplain traces +} +test var-27.16 {const and traces: write traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + apply {const { + trace add variable X write {apply {args { + lappend ::traces $args + }}} + $const X gorp + $const X foo + catch {set X bar} + list $X $::traces + }} const +} -result {gorp {{X {} write}}} -cleanup { + unset -nocomplain traces +} +test var-27.17 {const and traces: unset traces} -setup { + unset -nocomplain traces + set traces {} +} -body { + list {*}[apply {const { + trace add variable X unset {apply {args { + lappend ::traces $args + }}} + $const X gorp + unset -nocomplain X + list $X $::traces + }} const] $traces +} -result {gorp {} {{X {} unset}}} -cleanup { + unset -nocomplain traces +} + +test var-28.1 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + return $X + } +} -cleanup { + namespace delete var28 +} -result gorp +test var-28.2 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + apply {{} { + variable X + set X 123 + } var28} +} -cleanup { + namespace delete var28 +} -returnCodes error -result {can't set "X": variable is a constant} +test var-28.3 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + apply {{} { + variable X + unset X + } var28} +} -cleanup { + namespace delete var28 +} -returnCodes error -result {can't unset "X": variable is a constant} +test var-28.4 {const: in a namespace} -setup { + namespace eval var28 {} +} -body { + namespace eval var28 { + variable X + const X gorp + } + namespace delete var28 + namespace eval var28 { + variable X abc + } + apply {{} { + variable X + return $X + } var28} +} -cleanup { + namespace delete var28 +} -result abc +test var-28.5 {const: in a namespace, direct access from proc} -setup { + namespace eval var28 {} +} -body { + set result [apply {{} { + const ::var28::X abc + # Constant in namespace, NOT locally! + info exists X + }}] + apply {res { + variable X + list $res [catch {unset X} msg] $msg $X + } var28} $result +} -cleanup { + namespace delete var28 +} -result {0 1 {can't unset "X": variable is a constant} abc} + +test var-29.1 {const: globally} -setup { + set int [interp create] +} -body { + $int eval { + const X gorp + apply {{} { + global X + return $X + }} + } +} -cleanup { + interp delete $int +} -result gorp +test var-29.2 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + variable X + constructor {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.3 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + private variable X + constructor {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.4 {const: TclOO variable resolution} -setup { + oo::class create Parent +} -body { + oo::class create C { + superclass Parent + variable X + constructor {} { + set X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + set X gorp + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + set c [C new] + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Parent destroy +} -result {123 {0 abc} {0 gorp} 0 {}} +test var-29.5 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + variable X + method init {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.6 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + private variable X + method init {} { + const X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {1 {can't set "X": variable is a constant}} {1 {can't unset "X": variable is a constant}} 1 X} +test var-29.7 {const: TclOO variable resolution} -setup { + set c [oo::object create Instance] +} -body { + oo::objdefine $c { + variable X + method init {} { + set X 123 + } + method checkRead {} { + return $X + } + method checkWrite {} { + list [catch { + set X abc + } msg] $msg + } + method checkUnset {} { + list [catch { + unset X + set X gorp + } msg] $msg + } + method checkProbe {} { + info constant X + } + method checkList {} { + info consts + } + } + $c init + list [$c checkRead] [$c checkWrite] [$c checkUnset] [$c checkProbe] [$c checkList] +} -cleanup { + Instance destroy +} -result {123 {0 abc} {0 gorp} 0 {}} + +# The info constant and info consts commands +test var-30.1 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts]] [info constant X] + const X 1 + lappend consts [lsort [info consts]] [info constant X] + const Y 2 + lappend consts [lsort [info consts]] + const X 3 + lappend consts [lsort [info consts]] + }} +} {{} 0 X 1 {X Y} {X Y}} +test var-30.2 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + const X 1 + lappend consts [lsort [info consts X]] + const Y 2 + lappend consts [lsort [info consts X]] + const X 3 + lappend consts [lsort [info consts X]] + }} +} {{} X X X} +test var-30.3 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts ?]] + const X 1 + lappend consts [lsort [info consts ?]] + const Y 2 + lappend consts [lsort [info consts ?]] + const XX 3 + lappend consts [lsort [info consts ?]] + }} +} {{} X {X Y} {X Y}} +test var-30.4 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + set X 1 + lappend consts [lsort [info consts X]] + set Y 2 + lappend consts [lsort [info consts X]] + set X 3 + lappend consts [lsort [info consts X]] + }} +} {{} {} {} {}} +test var-30.5 {info consts: in a namespace} -setup { + namespace eval var30 {} +} -body { + namespace eval var30 { + const X gorp + info consts + } +} -cleanup { + namespace delete var30 +} -result X +test var-30.6 {info consts: in a namespace} -setup { + namespace eval var30 {} +} -body { + namespace eval var30 { + const X gorp + variable Y foo + } + info consts var30::* +} -cleanup { + namespace delete var30 +} -result ::var30::X +test var-30.7 {info constant: bad constant names: array element} { + apply {{} { + info constant a(b) + }} +} 0 +test var-30.8 {info constant: bad constant names: array} { + apply {{} { + array set a {} + info constant a + }} +} 0 +test var-30.9 {info constant: bad constant names: no var} { + apply {{} { + info constant a + }} +} 0 +test var-30.10 {info constant: bad constant names: no namespace} { + apply {{} { + info constant ::var29::no::such::ns::a + }} +} 0 +test var-30.11 {info constant: bad constant names: dangling upvar} { + apply {{} { + upvar 0 no_var a + info constant a + }} +} 0 +test var-30.12 {info constant: bad constant names: bad name} { + apply {{} { + info constant a(b + }} +} 0 +test var-30.13 {info constant: bad constant names: nesting} { + apply {{} { + array set b {c d} + upvar 0 b(c) a + info constant a(d) + }} +} 0 + +test var-31.1 {info constant: syntax} -returnCodes error -body { + info constant +} -result {wrong # args: should be "info constant varName"} +test var-31.2 {info constant: syntax} -returnCodes error -body { + info constant foo bar +} -result {wrong # args: should be "info constant varName"} +test var-31.3 {info consts: syntax} -returnCodes error -body { + info consts foo bar +} -result {wrong # args: should be "info consts ?pattern?"} catch {namespace delete ns} catch {unset arr} diff --git a/tests/winConsole.test b/tests/winConsole.test index 166599f..1d4a4b5 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -266,7 +266,7 @@ test console-fconfigure-get-1.[incr testnum] { Console get stdin option -eofchar } -constraints {win interactive} -body { fconfigure stdin -eofchar -} -result \x1A +} -result "" test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize diff --git a/tests/winFile.test b/tests/winFile.test index 0c13a0e..231fb3f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -28,7 +28,7 @@ testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser -} -returnCodes error -result {user "nosuchuser" doesn't exist} +} -result {} test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator diff --git a/tests/zipfs.test b/tests/zipfs.test index b696308..124a43f 100644 --- a/tests/zipfs.test +++ b/tests/zipfs.test @@ -1448,14 +1448,14 @@ namespace eval test_ns_zipfs { testzipfsglob basic-type-d $basicMounts [list -type d $defMountPt/*] [zipfspathsmt $defMountPt testdir] testzipfsglob basic-type-f $basicMounts [list -type f $defMountPt/*] [zipfspathsmt $defMountPt test] testzipfsglob basic-type-d-f $basicMounts [list -type {d f} $defMountPt/*] [zipfspathsmt $defMountPt test testdir] - testzipfsglob basic-type-l $basicMounts [list -type l $defMountPt/*] "no files matched glob pattern \"$defMountPt/*\"" -returnCodes error + testzipfsglob basic-type-l $basicMounts [list -type l $defMountPt/*] {} foreach type {b c l p s} { - testzipfsglob basic-type-1-$type $basicMounts [list -type $type $defMountPt/*] "no files matched glob pattern \"$defMountPt/*\"" -returnCodes error + testzipfsglob basic-type-1-$type $basicMounts [list -type $type $defMountPt/*] {} testzipfsglob basic-type-f-$type $basicMounts [list -type [list f $type] $defMountPt/*] [zipfspathsmt $defMountPt test] testzipfsglob basic-type-d-$type $basicMounts [list -type [list d $type] $defMountPt/*] [zipfspathsmt $defMountPt testdir] } testzipfsglob basic-path $basicMounts [list -path $defMountPt/t *d*] [zipfspathsmt $defMountPt testdir] - testzipfsglob basic-enoent $basicMounts [list $defMountPt/x*] "no files matched glob pattern \"$defMountPt/x*\"" -returnCodes error + testzipfsglob basic-enoent $basicMounts [list $defMountPt/x*] {} testzipfsglob basic-enoent-ok $basicMounts [list -nocomplain $defMountPt/x*] {} # NOTE: test root mounts separately because some bugs only showed up on these @@ -1473,7 +1473,7 @@ namespace eval test_ns_zipfs { testzipfsglob root-type-f $rootMounts [list -type f [zipfs root]*] [zipfspaths test] testzipfsglob root-type-d-f $rootMounts [list -type {d f} [zipfs root]*] [zipfspaths test testdir] -constraints !zipfslib testzipfsglob root-path $rootMounts [list -path [zipfs root]t *d*] [zipfspaths testdir] - testzipfsglob root-enoent $rootMounts [list [zipfs root]x*] {no files matched glob pattern "//zipfs:/x*"} -returnCodes error + testzipfsglob root-enoent $rootMounts [list [zipfs root]x*] {} testzipfsglob root-enoent-ok $rootMounts [list -nocomplain [zipfs root]x*] {} # glob operations on intermediate directories (mezzo) in mount diff --git a/tests/zlib.test b/tests/zlib.test index 7679102..6becb91 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -288,23 +288,23 @@ test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { test zlib-8.6 {transformation and fconfigure} -setup { set file [makeFile {} test.z] set fd [open $file wb] -} -constraints {zlib deprecated} -body { +} -constraints zlib -body { list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ [chan pop $fd; fconfigure $fd] } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] -} -constraints {zlib deprecated} -body { +} -constraints zlib -body { list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ [chan pop $fd; fconfigure $fd] } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -profile tcl8 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding iso8859-1 -eofchar {} -profile strict -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" |