diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | tests/binary.test | 1503 | ||||
| -rw-r--r-- | tests/cmdAH.test | 7 | ||||
| -rw-r--r-- | tests/cmdIL.test | 370 | ||||
| -rw-r--r-- | tests/cmdMZ.test | 269 | ||||
| -rw-r--r-- | tests/compile.test | 87 | ||||
| -rw-r--r-- | tests/fileSystem.test | 598 |
7 files changed, 1401 insertions, 1440 deletions
@@ -1,3 +1,10 @@ +2008-09-10 Donal K. Fellows <dkf@users.sf.net> + + * tests/binary.test,cmdAH.test,cmdIL.test,cmdMZ.test,fileSystem.test: + More use of tcltest2 to simplify the tests as exposed to people. + * tests/compile.test (compile-18.*): Added *some* tests of the + disassmbler, though not of its output format. + 2008-09-10 Miguel Sofer <msofer@users.sf.net> * tests/nre.test: add missing constraints; enable test of foreach diff --git a/tests/binary.test b/tests/binary.test index 7f41559..8b8a1ab 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -1,16 +1,16 @@ -# This file tests the tclBinary.c file and the "binary" Tcl command. +# This file tests the tclBinary.c file and the "binary" Tcl command. # -# 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. +# 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 (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: binary.test,v 1.36 2008/07/23 23:19:33 ferrieux Exp $ +# RCS: @(#) $Id: binary.test,v 1.37 2008/09/10 13:50:04 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -19,35 +19,90 @@ if {[lsearch [namespace children] ::tcltest] == -1} { testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] +# Big test for correct ordering of data in [expr] +proc testIEEE {} { + variable ieeeValues + binary scan [binary format dd -1.0 1.0] c* c + switch -exact -- $c { + {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { + # little endian + binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ + ieeeValues(-Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ + ieeeValues(-Normal) + binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ + ieeeValues(-Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ + ieeeValues(+Subnormal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ + ieeeValues(+Normal) + binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ + ieeeValues(+Infinity) + binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 1 + return 1 + } + {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { + binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Infinity) + binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Normal) + binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-Subnormal) + binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(-0) + binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+0) + binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Subnormal) + binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Normal) + binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(+Infinity) + binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ + ieeeValues(NaN) + set ieeeValues(littleEndian) 0 + return 1 + } + default { + return 0 + } + } +} + +testConstraint ieeeFloatingPoint [testIEEE] + +# ---------------------------------------------------------------------- + test binary-0.1 {DupByteArrayInternalRep} { set hdr [binary format cc 0 0316] set buf hellomatt - set data $hdr append data $buf - string length $data } 11 test binary-1.1 {Tcl_BinaryObjCmd: bad args} -body { binary } -returnCodes error -match glob -result {wrong # args: *} -test binary-1.2 {Tcl_BinaryObjCmd: bad args} -body { +test binary-1.2 {Tcl_BinaryObjCmd: bad args} -returnCodes error -body { binary foo -} -returnCodes error -match glob -result {unknown or ambiguous subcommand "foo": *} - -test binary-1.3 {Tcl_BinaryObjCmd: format error} -body { +} -match glob -result {unknown or ambiguous subcommand "foo": *} +test binary-1.3 {Tcl_BinaryObjCmd: format error} -returnCodes error -body { binary f -} -returnCodes error \ - -result {wrong # args: should be "binary format formatString ?arg ...?"} +} -result {wrong # args: should be "binary format formatString ?arg ...?"} test binary-1.4 {Tcl_BinaryObjCmd: format} -body { binary format "" } -result {} - -test binary-2.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format a } msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-2.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format a +} -result {not enough arguments for all format specifiers} test binary-2.2 {Tcl_BinaryObjCmd: format} { binary format a0 foo } {} @@ -70,9 +125,9 @@ test binary-2.8 {Tcl_BinaryObjCmd: format} { binary format a*X3a2 foobar x } foox\x00r -test binary-3.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format A} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-3.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format A +} -result {not enough arguments for all format specifiers} test binary-3.2 {Tcl_BinaryObjCmd: format} { binary format A0 f } {} @@ -95,9 +150,9 @@ test binary-3.8 {Tcl_BinaryObjCmd: format} { binary format A*X3A2 foobar x } {foox r} -test binary-4.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format B} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-4.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format B +} -result {not enough arguments for all format specifiers} test binary-4.2 {Tcl_BinaryObjCmd: format} { binary format B0 1 } {} @@ -119,13 +174,13 @@ test binary-4.7 {Tcl_BinaryObjCmd: format} { test binary-4.8 {Tcl_BinaryObjCmd: format} { binary format B2B3 10 010 } \x80\x40 -test binary-4.9 {Tcl_BinaryObjCmd: format} { - list [catch {binary format B1B5 1 foo} msg] $msg -} {1 {expected binary string but got "foo" instead}} +test binary-4.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format B1B5 1 foo +} -result {expected binary string but got "foo" instead} -test binary-5.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format b} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-5.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format b +} -result {not enough arguments for all format specifiers} test binary-5.2 {Tcl_BinaryObjCmd: format} { binary format b0 1 } {} @@ -150,13 +205,13 @@ test binary-5.8 {Tcl_BinaryObjCmd: format} { test binary-5.9 {Tcl_BinaryObjCmd: format} { binary format b2b3 10 010 } \x01\x02 -test binary-5.10 {Tcl_BinaryObjCmd: format} { - list [catch {binary format b1b5 1 foo} msg] $msg -} {1 {expected binary string but got "foo" instead}} +test binary-5.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format b1b5 1 foo +} -result {expected binary string but got "foo" instead} -test binary-6.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format h} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-6.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format h +} -result {not enough arguments for all format specifiers} test binary-6.2 {Tcl_BinaryObjCmd: format} { binary format h0 1 } {} @@ -184,13 +239,13 @@ test binary-6.9 {Tcl_BinaryObjCmd: format} { test binary-6.10 {Tcl_BinaryObjCmd: format} { binary format h2h3 23 456 } \x32\x54\x06 -test binary-6.11 {Tcl_BinaryObjCmd: format} { - list [catch {binary format h2 foo} msg] $msg -} {1 {expected hexadecimal string but got "foo" instead}} +test binary-6.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format h2 foo +} -result {expected hexadecimal string but got "foo" instead} -test binary-7.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format H} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-7.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format H +} -result {not enough arguments for all format specifiers} test binary-7.2 {Tcl_BinaryObjCmd: format} { binary format H0 1 } {} @@ -218,16 +273,16 @@ test binary-7.9 {Tcl_BinaryObjCmd: format} { test binary-7.10 {Tcl_BinaryObjCmd: format} { binary format H2H3 23 456 } \x23\x45\x60 -test binary-7.11 {Tcl_BinaryObjCmd: format} { - list [catch {binary format H2 foo} msg] $msg -} {1 {expected hexadecimal string but got "foo" instead}} - -test binary-8.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format c} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-8.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format c blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-7.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format H2 foo +} -result {expected hexadecimal string but got "foo" instead} + +test binary-8.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format c +} -result {not enough arguments for all format specifiers} +test binary-8.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format c blat +} -result {expected integer but got "blat"} test binary-8.3 {Tcl_BinaryObjCmd: format} { binary format c0 0x50 } {} @@ -246,24 +301,24 @@ test binary-8.7 {Tcl_BinaryObjCmd: format} { test binary-8.8 {Tcl_BinaryObjCmd: format} { binary format c* {0x50 0x52} } PR -test binary-8.9 {Tcl_BinaryObjCmd: format} { - list [catch {binary format c2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-8.10 {Tcl_BinaryObjCmd: format} { +test binary-8.9 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format c2 {0x50} +} -result {number of elements in list does not match count} +test binary-8.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format c $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format c $a +} -result "expected integer but got \"0x50 0x51\"" test binary-8.11 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format c1 $a } P -test binary-9.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format s} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-9.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format s blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-9.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format s +} -result {not enough arguments for all format specifiers} +test binary-9.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format s blat +} -result {expected integer but got "blat"} test binary-9.3 {Tcl_BinaryObjCmd: format} { binary format s0 0x50 } {} @@ -285,24 +340,24 @@ test binary-9.8 {Tcl_BinaryObjCmd: format} { test binary-9.9 {Tcl_BinaryObjCmd: format} { binary format s2 {0x50 0x52 0x53} 0x54 } P\x00R\x00 -test binary-9.10 {Tcl_BinaryObjCmd: format} { - list [catch {binary format s2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-9.11 {Tcl_BinaryObjCmd: format} { +test binary-9.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format s2 {0x50} +} -result {number of elements in list does not match count} +test binary-9.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format s $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format s $a +} -result "expected integer but got \"0x50 0x51\"" test binary-9.12 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format s1 $a } P\x00 -test binary-10.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format S} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-10.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format S blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-10.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format S +} -result {not enough arguments for all format specifiers} +test binary-10.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format S blat +} -result {expected integer but got "blat"} test binary-10.3 {Tcl_BinaryObjCmd: format} { binary format S0 0x50 } {} @@ -324,24 +379,24 @@ test binary-10.8 {Tcl_BinaryObjCmd: format} { test binary-10.9 {Tcl_BinaryObjCmd: format} { binary format S2 {0x50 0x52 0x53} 0x54 } \x00P\x00R -test binary-10.10 {Tcl_BinaryObjCmd: format} { - list [catch {binary format S2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-10.11 {Tcl_BinaryObjCmd: format} { +test binary-10.10 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format S2 {0x50} +} -result {number of elements in list does not match count} +test binary-10.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format S $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format S $a +} -result "expected integer but got \"0x50 0x51\"" test binary-10.12 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format S1 $a } \x00P -test binary-11.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format i} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-11.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format i blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-11.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format i +} -result {not enough arguments for all format specifiers} +test binary-11.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format i blat +} -result {expected integer but got "blat"} test binary-11.3 {Tcl_BinaryObjCmd: format} { binary format i0 0x50 } {} @@ -366,24 +421,24 @@ test binary-11.9 {Tcl_BinaryObjCmd: format} { test binary-11.10 {Tcl_BinaryObjCmd: format} { binary format i* {0x50515253 0x52} } SRQPR\x00\x00\x00 -test binary-11.11 {Tcl_BinaryObjCmd: format} { - list [catch {binary format i2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-11.12 {Tcl_BinaryObjCmd: format} { +test binary-11.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format i2 {0x50} +} -result {number of elements in list does not match count} +test binary-11.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format i $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format i $a +} -result "expected integer but got \"0x50 0x51\"" test binary-11.13 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format i1 $a } P\x00\x00\x00 -test binary-12.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format I} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-12.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format I blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-12.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format I +} -result {not enough arguments for all format specifiers} +test binary-12.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format I blat +} -result {expected integer but got "blat"} test binary-12.3 {Tcl_BinaryObjCmd: format} { binary format I0 0x50 } {} @@ -408,24 +463,24 @@ test binary-12.9 {Tcl_BinaryObjCmd: format} { test binary-12.10 {Tcl_BinaryObjCmd: format} { binary format I* {0x50515253 0x52} } PQRS\x00\x00\x00R -test binary-12.11 {Tcl_BinaryObjCmd: format} { - list [catch {binary format i2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-12.12 {Tcl_BinaryObjCmd: format} { +test binary-12.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format i2 {0x50} +} -result {number of elements in list does not match count} +test binary-12.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format I $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format I $a +} -result "expected integer but got \"0x50 0x51\"" test binary-12.13 {Tcl_BinaryObjCmd: format} { set a {0x50 0x51} binary format I1 $a } \x00\x00\x00P -test binary-13.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format f} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-13.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format f blat} msg] $msg -} {1 {expected floating-point number but got "blat"}} +test binary-13.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format f +} -result {not enough arguments for all format specifiers} +test binary-13.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format f blat +} -result {expected floating-point number but got "blat"} test binary-13.3 {Tcl_BinaryObjCmd: format} { binary format f0 1.6 } {} @@ -465,13 +520,13 @@ test binary-13.14 {Tcl_BinaryObjCmd: float underflow} bigEndian { test binary-13.15 {Tcl_BinaryObjCmd: float underflow} littleEndian { binary format f -3.402825e-100 } \x00\x00\x00\x80 -test binary-13.16 {Tcl_BinaryObjCmd: format} { - list [catch {binary format f2 {1.6}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-13.17 {Tcl_BinaryObjCmd: format} { +test binary-13.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format f2 {1.6} +} -result {number of elements in list does not match count} +test binary-13.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {1.6 3.4} - list [catch {binary format f $a} msg] $msg -} [list 1 "expected floating-point number but got \"1.6 3.4\""] + binary format f $a +} -result "expected floating-point number but got \"1.6 3.4\"" test binary-13.18 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format f1 $a @@ -481,12 +536,12 @@ test binary-13.19 {Tcl_BinaryObjCmd: format} littleEndian { binary format f1 $a } \xcd\xcc\xcc\x3f -test binary-14.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format d} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-14.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format d blat} msg] $msg -} {1 {expected floating-point number but got "blat"}} +test binary-14.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format d +} -result {not enough arguments for all format specifiers} +test binary-14.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format d blat +} -result {expected floating-point number but got "blat"} test binary-14.3 {Tcl_BinaryObjCmd: format} { binary format d0 1.6 } {} @@ -514,13 +569,13 @@ test binary-14.10 {Tcl_BinaryObjCmd: format} bigEndian { test binary-14.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format d2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 -test binary-14.14 {Tcl_BinaryObjCmd: format} { - list [catch {binary format d2 {1.6}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-14.15 {Tcl_BinaryObjCmd: format} { +test binary-14.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format d2 {1.6} +} -result {number of elements in list does not match count} +test binary-14.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {1.6 3.4} - list [catch {binary format d $a} msg] $msg -} [list 1 "expected floating-point number but got \"1.6 3.4\""] + binary format d $a +} -result "expected floating-point number but got \"1.6 3.4\"" test binary-14.16 {Tcl_BinaryObjCmd: format} bigEndian { set a {1.6 3.4} binary format d1 $a @@ -534,9 +589,9 @@ test binary-14.18 {FormatNumber: Bug 1116542} { set w } 1.25 -test binary-15.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format ax*a "y" "z"} msg] $msg -} {1 {cannot use "*" in format string with "x"}} +test binary-15.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format ax*a "y" "z" +} -result {cannot use "*" in format string with "x"} test binary-15.2 {Tcl_BinaryObjCmd: format} { binary format axa "y" "z" } y\x00z @@ -585,810 +640,840 @@ test binary-17.3 {Tcl_BinaryObjCmd: format} { binary format {a* @0 a2 @* a*} "foobar" "ab" "blat" } abobarblat -test binary-18.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format u0a3 abc abd} msg] $msg -} {1 {bad field specifier "u"}} +test binary-18.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format u0a3 abc abd +} -result {bad field specifier "u"} - -test binary-19.1 {Tcl_BinaryObjCmd: errors} { - list [catch {binary s} msg] $msg -} {1 {wrong # args: should be "binary scan value formatString ?varName ...?"}} -test binary-19.2 {Tcl_BinaryObjCmd: errors} { - list [catch {binary scan foo} msg] $msg -} {1 {wrong # args: should be "binary scan value formatString ?varName ...?"}} +test binary-19.1 {Tcl_BinaryObjCmd: errors} -returnCodes error -body { + binary s +} -result {wrong # args: should be "binary scan value formatString ?varName ...?"} +test binary-19.2 {Tcl_BinaryObjCmd: errors} -returnCodes error -body { + binary scan foo +} -result {wrong # args: should be "binary scan value formatString ?varName ...?"} test binary-19.3 {Tcl_BinaryObjCmd: scan} { binary scan {} {} } 0 -test binary-20.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc a} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-20.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-20.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc a +} -result {not enough arguments for all format specifiers} +test binary-20.2 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan abc a arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-20.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + binary scan abc a arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-20.3 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { set arg1 abc list [binary scan abc a0 arg1] $arg1 -} {1 {}} -test binary-20.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 {}} +test binary-20.4 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc a* arg1] $arg1 -} {1 abc} -test binary-20.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 abc} +test binary-20.5 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc a5 arg1] [info exists arg1] -} {0 0} +} -result {0 0} test binary-20.6 {Tcl_BinaryObjCmd: scan} { set arg1 foo list [binary scan abc a2 arg1] $arg1 } {1 ab} -test binary-20.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} +test binary-20.7 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 + unset -nocomplain arg2 +} -body { list [binary scan abcdef a2a2 arg1 arg2] $arg1 $arg2 -} {2 ab cd} -test binary-20.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {2 ab cd} +test binary-20.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc a2 arg1(a)] $arg1(a) -} {1 ab} -test binary-20.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 ab} +test binary-20.9 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc a arg1(a)] $arg1(a) -} {1 a} +} -result {1 a} -test binary-21.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc A} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-21.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-21.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc A +} -result {not enough arguments for all format specifiers} +test binary-21.2 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan abc A arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-21.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + binary scan abc A arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-21.3 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { set arg1 abc list [binary scan abc A0 arg1] $arg1 -} {1 {}} -test binary-21.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 {}} +test binary-21.4 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc A* arg1] $arg1 -} {1 abc} -test binary-21.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 abc} +test binary-21.5 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc A5 arg1] [info exists arg1] -} {0 0} +} -result {0 0} test binary-21.6 {Tcl_BinaryObjCmd: scan} { set arg1 foo list [binary scan abc A2 arg1] $arg1 } {1 ab} -test binary-21.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} +test binary-21.7 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 + unset -nocomplain arg2 +} -body { list [binary scan abcdef A2A2 arg1 arg2] $arg1 $arg2 -} {2 ab cd} -test binary-21.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {2 ab cd} +test binary-21.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc A2 arg1(a)] $arg1(a) -} {1 ab} -test binary-21.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 ab} +test binary-21.9 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc A2 arg1(a)] $arg1(a) -} {1 ab} -test binary-21.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 ab} +test binary-21.10 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan abc A arg1(a)] $arg1(a) -} {1 a} -test binary-21.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 a} +test binary-21.11 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan "abc def \x00 " A* arg1] $arg1 -} {1 {abc def}} -test binary-21.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +} -result {1 {abc def}} +test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -body { list [binary scan "abc def \x00ghi " A* arg1] $arg1 -} [list 1 "abc def \x00ghi"] +} -result [list 1 "abc def \x00ghi"] -test binary-22.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc b} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-22.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc b +} -result {not enough arguments for all format specifiers} test binary-22.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 b* arg1] $arg1 } {1 0100101011001010} test binary-22.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 b arg1] $arg1 } {1 0} test binary-22.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 b1 arg1] $arg1 } {1 0} test binary-22.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 b0 arg1] $arg1 } {1 {}} test binary-22.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 b5 arg1] $arg1 } {1 01001} test binary-22.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 b8 arg1] $arg1 } {1 01001010} test binary-22.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 b14 arg1] $arg1 } {1 01001010110010} test binary-22.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 b14 arg1] $arg1 } {0 foo} -test binary-22.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-22.10 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 b1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-22.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + binary scan \x52\x53 b1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-22.11 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 arg2 +} -body { set arg1 foo set arg2 bar list [binary scan \x07\x87\x05 b5b* arg1 arg2] $arg1 $arg2 -} {2 11100 1110000110100000} - +} -result {2 11100 1110000110100000} -test binary-23.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc B} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-23.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc B +} -result {not enough arguments for all format specifiers} test binary-23.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 B* arg1] $arg1 } {1 0101001001010011} test binary-23.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 B arg1] $arg1 } {1 1} test binary-23.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 B1 arg1] $arg1 } {1 1} test binary-23.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 B0 arg1] $arg1 } {1 {}} test binary-23.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 B5 arg1] $arg1 } {1 01010} test binary-23.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 B8 arg1] $arg1 } {1 01010010} test binary-23.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 B14 arg1] $arg1 } {1 01010010010100} test binary-23.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 B14 arg1] $arg1 } {0 foo} -test binary-23.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-23.10 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 B1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-23.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + binary scan \x52\x53 B1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-23.11 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 arg2 +} -body { set arg1 foo set arg2 bar list [binary scan \x70\x87\x05 B5B* arg1 arg2] $arg1 $arg2 -} {2 01110 1000011100000101} +} -result {2 01110 1000011100000101} -test binary-24.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc h} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-24.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc h +} -result {not enough arguments for all format specifiers} test binary-24.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 h* arg1] $arg1 } {1 253a} test binary-24.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xc2\xa3 h arg1] $arg1 } {1 2} test binary-24.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 h1 arg1] $arg1 } {1 2} test binary-24.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 h0 arg1] $arg1 } {1 {}} test binary-24.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xf2\x53 h2 arg1] $arg1 } {1 2f} test binary-24.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 h3 arg1] $arg1 } {1 253} test binary-24.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 h3 arg1] $arg1 } {0 foo} -test binary-24.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-24.9 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 h1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-24.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + binary scan \x52\x53 h1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-24.10 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 arg2 +} -body { set arg1 foo set arg2 bar list [binary scan \x70\x87\x05 h2h* arg1 arg2] $arg1 $arg2 -} {2 07 7850} +} -result {2 07 7850} -test binary-25.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc H} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-25.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc H +} -result {not enough arguments for all format specifiers} test binary-25.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 H* arg1] $arg1 } {1 52a3} test binary-25.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xc2\xa3 H arg1] $arg1 } {1 c} test binary-25.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x82\x53 H1 arg1] $arg1 } {1 8} test binary-25.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 H0 arg1] $arg1 } {1 {}} test binary-25.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xf2\x53 H2 arg1] $arg1 } {1 f2} test binary-25.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\x53 H3 arg1] $arg1 } {1 525} test binary-25.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 H3 arg1] $arg1 } {0 foo} -test binary-25.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-25.9 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 H1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53 H1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-25.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x70\x87\x05 H2H* arg1 arg2] $arg1 $arg2 } {2 70 8705} -test binary-26.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc c} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-26.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc c +} -result {not enough arguments for all format specifiers} test binary-26.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 c* arg1] $arg1 } {1 {82 -93}} test binary-26.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 c arg1] $arg1 } {1 82} test binary-26.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 c1 arg1] $arg1 } {1 82} test binary-26.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 c0 arg1] $arg1 } {1 {}} test binary-26.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 c2 arg1] $arg1 } {1 {82 -93}} test binary-26.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xff c arg1] $arg1 } {1 -1} test binary-26.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 c3 arg1] $arg1 } {0 foo} -test binary-26.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-26.9 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 c1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53 c1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-26.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2 } {2 {112 -121} 5} test binary-26.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 cu* arg1] $arg1 } {1 {82 163}} test binary-26.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 cu arg1] $arg1 } {1 82} test binary-26.13 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xff cu arg1] $arg1 } {1 255} test binary-26.14 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x80\x80 cuc arg1 arg2] $arg1 $arg2 } {2 128 -128} test binary-26.15 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x80\x80 ccu arg1 arg2] $arg1 $arg2 } {2 -128 128} -test binary-27.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc s} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-27.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc s +} -result {not enough arguments for all format specifiers} test binary-27.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1 } {1 {-23726 21587}} test binary-27.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 s arg1] $arg1 } {1 -23726} test binary-27.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 s1 arg1] $arg1 } {1 -23726} test binary-27.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 s0 arg1] $arg1 } {1 {}} test binary-27.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 s2 arg1] $arg1 } {1 {-23726 21587}} test binary-27.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 s1 arg1] $arg1 } {0 foo} -test binary-27.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-27.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 s1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53 s1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-27.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2 } {2 {-23726 21587} 5} test binary-27.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1 } {1 {41810 21587}} test binary-27.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2 } {2 65535 -1} test binary-27.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2 } {2 -1 65535} -test binary-28.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc S} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-28.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc S +} -result {not enough arguments for all format specifiers} test binary-28.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1 } {1 {21155 21332}} test binary-28.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 S arg1] $arg1 } {1 21155} test binary-28.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 S1 arg1] $arg1 } {1 21155} test binary-28.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 S0 arg1] $arg1 } {1 {}} test binary-28.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 S2 arg1] $arg1 } {1 {21155 21332}} test binary-28.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 S1 arg1] $arg1 } {0 foo} -test binary-28.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-28.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 S1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53 S1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-28.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2 } {2 {21155 21332} 5} test binary-28.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1 } {1 {21155 21332}} test binary-28.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1 } {1 {41810 21587}} -test binary-29.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc i} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-29.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc i +} -result {not enough arguments for all format specifiers} test binary-29.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1 } {1 {1414767442 67305985}} test binary-29.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i arg1] $arg1 } {1 1414767442} test binary-29.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 i1 arg1] $arg1 } {1 1414767442} test binary-29.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53 i0 arg1] $arg1 } {1 {}} test binary-29.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i2 arg1] $arg1 } {1 {1414767442 67305985}} test binary-29.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 i1 arg1] $arg1 } {0 foo} -test binary-29.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-29.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53\x53\x54 i1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53\x53\x54 i1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-29.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2 } {2 {1414767442 67305985} 5} test binary-29.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2 } {2 4294967295 -1} test binary-29.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2 } {2 -1 4294967295} test binary-29.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 iuiu arg1 arg2] $arg1 $arg2 } {2 128 2147483648} -test binary-30.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc I} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-30.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc I +} -result {not enough arguments for all format specifiers} test binary-30.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1 } {1 {1386435412 16909060}} test binary-30.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I arg1] $arg1 } {1 1386435412} test binary-30.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 I1 arg1] $arg1 } {1 1386435412} test binary-30.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53 I0 arg1] $arg1 } {1 {}} test binary-30.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I2 arg1] $arg1 } {1 {1386435412 16909060}} test binary-30.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 I1 arg1] $arg1 } {0 foo} -test binary-30.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-30.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53\x53\x54 I1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53\x53\x54 I1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-30.9 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} test binary-30.10 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2 } {2 4294967295 -1} test binary-30.11 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2 } {2 -1 4294967295} test binary-30.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 IuIu arg1 arg2] $arg1 $arg2 } {2 2147483648 128} -test binary-31.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc f} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-31.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc f +} -result {not enough arguments for all format specifiers} test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.3 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.4 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f arg1] $arg1 } {1 1.600000023841858} test binary-31.5 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f arg1] $arg1 } {1 1.600000023841858} test binary-31.6 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.7 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f f1 arg1] $arg1 } {1 1.600000023841858} test binary-31.8 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd f0 arg1] $arg1 } {1 {}} test binary-31.9 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f f0 arg1] $arg1 } {1 {}} test binary-31.10 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.11 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 f2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-31.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 f1 arg1] $arg1 } {0 foo} -test binary-31.13 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-31.13 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x3f\xcc\xcc\xcd f1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x3f\xcc\xcc\xcd f1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-31.14 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-31.15 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 f2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} -test binary-32.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc d} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-32.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc d +} -result {not enough arguments for all format specifiers} test binary-32.2 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d* arg1] $arg1 } {1 {1.6 3.4}} test binary-32.3 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d* arg1] $arg1 } {1 {1.6 3.4}} test binary-32.4 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d arg1] $arg1 } {1 1.6} test binary-32.5 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d arg1] $arg1 } {1 1.6} test binary-32.6 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1] $arg1 } {1 1.6} test binary-32.7 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d1 arg1] $arg1 } {1 1.6} test binary-32.8 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d0 arg1] $arg1 } {1 {}} test binary-32.9 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f d0 arg1] $arg1 } {1 {}} test binary-32.10 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 d2 arg1] $arg1 } {1 {1.6 3.4}} test binary-32.11 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 d2 arg1] $arg1 } {1 {1.6 3.4}} test binary-32.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 d1 arg1] $arg1 } {0 foo} -test binary-32.13 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-32.13 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a d1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-32.14 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 d2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-32.15 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 d2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-33.1 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 list [binary scan abcdefg a2xa3 arg1 arg2] $arg1 $arg2 } {2 ab def} test binary-33.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abcdefg a3x*a3 arg1 arg2] $arg1 $arg2 } {1 abc foo} test binary-33.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abcdefg a3x20a3 arg1 arg2] $arg1 $arg2 } {1 abc foo} test binary-33.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abc a3x20a3 arg1 arg2] $arg1 $arg2 } {1 abc foo} test binary-33.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x1a1 arg1] $arg1 } {1 b} test binary-33.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x5a1 arg1] $arg1 } {1 f} test binary-33.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x0a1 arg1] $arg1 } {1 a} test binary-34.1 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 list [binary scan abcdefg a2Xa3 arg1 arg2] $arg1 $arg2 } {2 ab bcd} test binary-34.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abcdefg a3X*a3 arg1 arg2] $arg1 $arg2 } {2 abc abc} test binary-34.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abcdefg a3X20a3 arg1 arg2] $arg1 $arg2 } {2 abc abc} test binary-34.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abc X20a3 arg1] $arg1 } {1 abc} test binary-34.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x*X1a1 arg1] $arg1 } {1 f} test binary-34.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x*X5a1 arg1] $arg1 } {1 b} test binary-34.7 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x3X0a1 arg1] $arg1 } {1 d} -test binary-35.1 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} - list [catch {binary scan abcdefg a2@a3 arg1 arg2} msg] $msg -} {1 {missing count for "@" field specifier}} +test binary-35.1 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 + unset -nocomplain arg2 +} -returnCodes error -body { + binary scan abcdefg a2@a3 arg1 arg2 +} -result {missing count for "@" field specifier} test binary-35.2 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abcdefg a3@*a3 arg1 arg2] $arg1 $arg2 } {1 abc foo} test binary-35.3 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} - catch {unset arg2} + unset -nocomplain arg1 + unset -nocomplain arg2 set arg2 foo list [binary scan abcdefg a3@20a3 arg1 arg2] $arg1 $arg2 } {1 abc foo} test binary-35.4 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef @2a3 arg1] $arg1 } {1 cde} test binary-35.5 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x*@1a1 arg1] $arg1 } {1 b} test binary-35.6 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan abcdef x*@0a1 arg1] $arg1 } {1 a} -test binary-36.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abcdef u0a3} msg] $msg -} {1 {bad field specifier "u"}} +test binary-36.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abcdef u0a3 +} -result {bad field specifier "u"} -# GetFormatSpec is pretty thoroughly tested above, but there are a few -# cases we should text explicitly +# GetFormatSpec is pretty thoroughly tested above, but there are a few cases +# we should text explicitly test binary-37.1 {GetFormatSpec: whitespace} { binary format "a3 a5 a3" foo barblat baz @@ -1408,11 +1493,11 @@ test binary-37.5 {GetFormatSpec: whitespace} { test binary-37.6 {GetFormatSpec: whitespace} { binary format " a3 " foo } foo -test binary-37.7 {GetFormatSpec: numbers} { - list [catch {binary scan abcdef "x-1" foo} msg] $msg -} {1 {bad field specifier "-"}} +test binary-37.7 {GetFormatSpec: numbers} -returnCodes error -body { + binary scan abcdef "x-1" foo +} -result {bad field specifier "-"} test binary-37.8 {GetFormatSpec: numbers} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan abcdef "a0x3" arg1] $arg1 } {1 {}} @@ -1450,92 +1535,85 @@ test binary-38.8 {FormatNumber: word alignment} littleEndian { } \x01\xcd\xcc\xcc\x3f test binary-39.1 {ScanNumber: sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 c2 arg1] $arg1 } {1 {82 -93}} test binary-39.2 {ScanNumber: sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 s4 arg1] $arg1 } {1 {513 -32511 386 -32127}} test binary-39.3 {ScanNumber: sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 S4 arg1] $arg1 } {1 {258 385 -32255 -32382}} test binary-39.4 {ScanNumber: sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 i5 arg1] $arg1 } {1 {33620225 16843137 16876033 25297153 -2130640639}} test binary-39.5 {ScanNumber: sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1 } {1 {16843010 -2130640639 25297153 16876033 16843137}} test binary-39.6 {ScanNumber: no sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 cu2 arg1] $arg1 } {1 {82 163}} test binary-39.7 {ScanNumber: no sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 su4 arg1] $arg1 } {1 {513 33025 386 33409}} test binary-39.8 {ScanNumber: no sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 Su4 arg1] $arg1 } {1 {258 385 33281 33154}} test binary-39.9 {ScanNumber: no sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 iu5 arg1] $arg1 } {1 {33620225 16843137 16876033 25297153 2164326657}} test binary-39.10 {ScanNumber: no sign extension} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 Iu5 arg1] $arg1 } {1 {16843010 2164326657 25297153 16876033 16843137}} -test binary-40.3 {ScanNumber: NaN} \ - -body { - catch {unset arg1} - list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 - } \ - -match glob \ - -result {1 -NaN*} - -test binary-40.4 {ScanNumber: NaN} \ - -body { - catch {unset arg1} - list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 - } \ - -match glob \ - -result {1 -NaN*} +test binary-40.3 {ScanNumber: NaN} -body { + unset -nocomplain arg1 + list [binary scan \xff\xff\xff\xff f1 arg1] $arg1 +} -match glob -result {1 -NaN*} +test binary-40.4 {ScanNumber: NaN} -body { + unset -nocomplain arg1 + list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff d arg1] $arg1 +} -match glob -result {1 -NaN*} test binary-41.1 {ScanNumber: word alignment} { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x01\x00 c1s1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.2 {ScanNumber: word alignment} { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x00\x01 c1S1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.3 {ScanNumber: word alignment} { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x01\x00\x00\x00 c1i1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.4 {ScanNumber: word alignment} { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x00\x00\x00\x01 c1I1 arg1 arg2] $arg1 $arg2 } {2 1 1} test binary-41.5 {ScanNumber: word alignment} bigEndian { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x3f\xcc\xcc\xcd c1f1 arg1 arg2] $arg1 $arg2 } {2 1 1.600000023841858} test binary-41.6 {ScanNumber: word alignment} littleEndian { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\xcd\xcc\xcc\x3f c1f1 arg1 arg2] $arg1 $arg2 } {2 1 1.600000023841858} test binary-41.7 {ScanNumber: word alignment} bigEndian { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x3f\xf9\x99\x99\x99\x99\x99\x9a c1d1 arg1 arg2] $arg1 $arg2 } {2 1 1.6} test binary-41.8 {ScanNumber: word alignment} littleEndian { - catch {unset arg1; unset arg2} + unset -nocomplain arg1; unset arg2 list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2 } {2 1 1.6} @@ -1568,23 +1646,23 @@ test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { set x } 6442450944 test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] W arg1] $arg1 } {1 -9223372036854775808} test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] Wu arg1] $arg1 } {1 9223372036854775808} test binary-43.7 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan [string repeat \x00 7]\x80 wu arg1] $arg1 } {1 9223372036854775808} test binary-43.8 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan \x80[string repeat \x00 7]\x80[string repeat \x00 7] WuW arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} @@ -1620,22 +1698,22 @@ test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} { } "1 \u00a4 \u20ac" test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} { - # This test is only reliable when memory debugging is turned on, - # but without even memory debugging it should still generate the - # expected answers and might therefore still pick up memory corruption - # caused by [Bug 851747]. + # This test is only reliable when memory debugging is turned on, but + # without even memory debugging it should still generate the expected + # answers and might therefore still pick up memory corruption caused by + # [Bug 851747]. list [binary scan aba ccc x x x] $x } {3 97} ### TIP#129: endian specifiers ---- # format t -test binary-48.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format t} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-48.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format t blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-48.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format t +} -result {not enough arguments for all format specifiers} +test binary-48.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format t blat +} -result {expected integer but got "blat"} test binary-48.3 {Tcl_BinaryObjCmd: format} { binary format S0 0x50 } {} @@ -1663,10 +1741,10 @@ test binary-48.10 {Tcl_BinaryObjCmd: format} bigEndian { test binary-48.11 {Tcl_BinaryObjCmd: format} littleEndian { binary format t2 {0x50 0x52} } P\x00R\x00 -test binary-48.12 {Tcl_BinaryObjCmd: format} bigEndian { +test binary-48.12 {Tcl_BinaryObjCmd: format} bigEndian { binary format t* {0x5051 0x52} } PQ\x00R -test binary-48.13 {Tcl_BinaryObjCmd: format} littleEndian { +test binary-48.13 {Tcl_BinaryObjCmd: format} littleEndian { binary format t* {0x5051 0x52} } QPR\x00 test binary-48.14 {Tcl_BinaryObjCmd: format} bigEndian { @@ -1675,13 +1753,13 @@ test binary-48.14 {Tcl_BinaryObjCmd: format} bigEndian { test binary-48.15 {Tcl_BinaryObjCmd: format} littleEndian { binary format t2 {0x50 0x52 0x53} 0x54 } P\x00R\x00 -test binary-48.16 {Tcl_BinaryObjCmd: format} { - list [catch {binary format t2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-48.17 {Tcl_BinaryObjCmd: format} { +test binary-48.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format t2 {0x50} +} -result {number of elements in list does not match count} +test binary-48.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format t $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format t $a +} -result "expected integer but got \"0x50 0x51\"" test binary-48.18 {Tcl_BinaryObjCmd: format} bigEndian { set a {0x50 0x51} binary format t1 $a @@ -1692,12 +1770,12 @@ test binary-48.19 {Tcl_BinaryObjCmd: format} littleEndian { } P\x00 # format n -test binary-49.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format n} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-49.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format n blat} msg] $msg -} {1 {expected integer but got "blat"}} +test binary-49.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format n +} -result {not enough arguments for all format specifiers} +test binary-49.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format n blat +} -result {expected integer but got "blat"} test binary-49.3 {Tcl_BinaryObjCmd: format} { binary format n0 0x50 } {} @@ -1722,13 +1800,13 @@ test binary-49.9 {Tcl_BinaryObjCmd: format} littleEndian { test binary-49.10 {Tcl_BinaryObjCmd: format} littleEndian { binary format n* {0x50515253 0x52} } SRQPR\x00\x00\x00 -test binary-49.11 {Tcl_BinaryObjCmd: format} { - list [catch {binary format n2 {0x50}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-49.12 {Tcl_BinaryObjCmd: format} { +test binary-49.11 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format n2 {0x50} +} -result {number of elements in list does not match count} +test binary-49.12 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {0x50 0x51} - list [catch {binary format n $a} msg] $msg -} [list 1 "expected integer but got \"0x50 0x51\""] + binary format n $a +} -result "expected integer but got \"0x50 0x51\"" test binary-49.13 {Tcl_BinaryObjCmd: format} littleEndian { set a {0x50 0x51} binary format n1 $a @@ -1771,14 +1849,13 @@ test binary-50.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian { set x } 6442450944 - # format Q/q -test binary-51.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format Q} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-51.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format q blat} msg] $msg -} {1 {expected floating-point number but got "blat"}} +test binary-51.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format Q +} -result {not enough arguments for all format specifiers} +test binary-51.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format q blat +} -result {expected floating-point number but got "blat"} test binary-51.3 {Tcl_BinaryObjCmd: format} { binary format q0 1.6 } {} @@ -1806,13 +1883,13 @@ test binary-51.10 {Tcl_BinaryObjCmd: format} {} { test binary-51.11 {Tcl_BinaryObjCmd: format} {} { binary format q2 {1.6 3.4 5.6} } \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 -test binary-51.14 {Tcl_BinaryObjCmd: format} { - list [catch {binary format q2 {1.6}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-51.15 {Tcl_BinaryObjCmd: format} { +test binary-51.14 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format q2 {1.6} +} -result {number of elements in list does not match count} +test binary-51.15 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {1.6 3.4} - list [catch {binary format q $a} msg] $msg -} [list 1 "expected floating-point number but got \"1.6 3.4\""] + binary format q $a +} -result "expected floating-point number but got \"1.6 3.4\"" test binary-51.16 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format Q1 $a @@ -1823,12 +1900,12 @@ test binary-51.17 {Tcl_BinaryObjCmd: format} {} { } \x9a\x99\x99\x99\x99\x99\xf9\x3f # format R/r -test binary-53.1 {Tcl_BinaryObjCmd: format} { - list [catch {binary format r} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-53.2 {Tcl_BinaryObjCmd: format} { - list [catch {binary format r blat} msg] $msg -} {1 {expected floating-point number but got "blat"}} +test binary-53.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format r +} -result {not enough arguments for all format specifiers} +test binary-53.2 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format r blat +} -result {expected floating-point number but got "blat"} test binary-53.3 {Tcl_BinaryObjCmd: format} { binary format f0 1.6 } {} @@ -1868,13 +1945,13 @@ test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} { test binary-53.15 {Tcl_BinaryObjCmd: float underflow} {} { binary format r -3.402825e-100 } \x00\x00\x00\x80 -test binary-53.16 {Tcl_BinaryObjCmd: format} { - list [catch {binary format r2 {1.6}} msg] $msg -} {1 {number of elements in list does not match count}} -test binary-53.17 {Tcl_BinaryObjCmd: format} { +test binary-53.16 {Tcl_BinaryObjCmd: format} -returnCodes error -body { + binary format r2 {1.6} +} -result {number of elements in list does not match count} +test binary-53.17 {Tcl_BinaryObjCmd: format} -returnCodes error -body { set a {1.6 3.4} - list [catch {binary format r $a} msg] $msg -} [list 1 "expected floating-point number but got \"1.6 3.4\""] + binary format r $a +} -result "expected floating-point number but got \"1.6 3.4\"" test binary-53.18 {Tcl_BinaryObjCmd: format} {} { set a {1.6 3.4} binary format R1 $a @@ -1885,346 +1962,352 @@ test binary-53.19 {Tcl_BinaryObjCmd: format} {} { } \xcd\xcc\xcc\x3f # scan t (s) -test binary-54.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc t} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-54.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc t +} -result {not enough arguments for all format specifiers} test binary-54.2 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1 } {1 {-23726 21587}} test binary-54.3 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 t arg1] $arg1 } {1 -23726} test binary-54.4 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 t1 arg1] $arg1 } {1 -23726} test binary-54.5 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3 t0 arg1] $arg1 } {1 {}} test binary-54.6 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1 } {1 {-23726 21587}} test binary-54.7 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 t1 arg1] $arg1 } {0 foo} -test binary-54.8 {Tcl_BinaryObjCmd: scan} {} { - catch {unset arg1} +test binary-54.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 t1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x52\x53 t1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 } {2 {-23726 21587} 5} -test binary-54.10 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} +test binary-54.10 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x00\x80\x00\x80 tut arg1 arg2] $arg1 $arg2 } {2 32768 -32768} -test binary-54.11 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} +test binary-54.11 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x00\x80\x00\x80 ttu arg1 arg2] $arg1 $arg2 } {2 -32768 32768} # scan t (b) -test binary-55.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc t} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-55.2 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-55.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc t +} -result {not enough arguments for all format specifiers} +test binary-55.2 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1 } {1 {21155 21332}} -test binary-55.3 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-55.3 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 t arg1] $arg1 } {1 21155} -test binary-55.4 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-55.4 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3 t1 arg1] $arg1 } {1 21155} -test binary-55.5 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-55.5 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3 t0 arg1] $arg1 } {1 {}} -test binary-55.6 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-55.6 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1 } {1 {21155 21332}} -test binary-55.7 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-55.7 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 t1 arg1] $arg1 } {0 foo} -test binary-55.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-55.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53 t1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} + binary scan \x52\x53 t1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2 } {2 {21155 21332} 5} -test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} +test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x80\x00\x80\x00 tut arg1 arg2] $arg1 $arg2 } {2 32768 -32768} -test binary-55.11 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} +test binary-55.11 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x80\x00\x80\x00 ttu arg1 arg2] $arg1 $arg2 } {2 -32768 32768} # scan n (s) -test binary-56.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc n} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-56.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc n +} -result {not enough arguments for all format specifiers} test binary-56.2 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 } {1 {1414767442 67305985}} -test binary-56.3 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} +test binary-56.3 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 } {1 1414767442} -test binary-56.4 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} +test binary-56.4 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1 } {1 1414767442} -test binary-56.5 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} +test binary-56.5 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53 n0 arg1] $arg1 } {1 {}} -test binary-56.6 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} +test binary-56.6 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 } {1 {1414767442 67305985}} -test binary-56.7 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} +test binary-56.7 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 n1 arg1] $arg1 } {0 foo} -test binary-56.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-56.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53\x53\x54 n1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} + binary scan \x52\x53\x53\x54 n1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1414767442 67305985} 5} -test binary-56.10 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} +test binary-56.10 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x80\x00\x00\x00\x80\x00\x00\x00 nun arg1 arg2] $arg1 $arg2 } {2 128 128} -test binary-56.11 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} +test binary-56.11 {Tcl_BinaryObjCmd: scan} littleEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x00\x00\x00\x80\x00\x00\x00\x80 nun arg1 arg2] $arg1 $arg2 } {2 2147483648 -2147483648} # scan n (b) -test binary-57.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc n} msg] $msg -} {1 {not enough arguments for all format specifiers}} -test binary-57.2 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-57.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc n +} -result {not enough arguments for all format specifiers} +test binary-57.2 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1 } {1 {1386435412 16909060}} -test binary-57.3 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-57.3 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1 } {1 1386435412} -test binary-57.4 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-57.4 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1 } {1 1386435412} -test binary-57.5 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-57.5 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53 n0 arg1] $arg1 } {1 {}} -test binary-57.6 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-57.6 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1 } {1 {1386435412 16909060}} -test binary-57.7 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} +test binary-57.7 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 n1 arg1] $arg1 } {0 foo} -test binary-57.8 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-57.8 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x52\x53\x53\x54 n1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} -test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} + binary scan \x52\x53\x53\x54 n1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} +test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2 } {2 {1386435412 16909060} 5} -test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} +test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x80\x00\x00\x00\x80\x00\x00\x00 nun arg1 arg2] $arg1 $arg2 } {2 2147483648 -2147483648} -test binary-57.11 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} +test binary-57.11 {Tcl_BinaryObjCmd: scan} bigEndian { + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x00\x00\x00\x80\x00\x00\x00\x80 nun arg1 arg2] $arg1 $arg2 } {2 128 128} # scan Q/q -test binary-58.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc q} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-58.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc q +} -result {not enough arguments for all format specifiers} test binary-58.2 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1 } {1 {1.6 3.4}} test binary-58.3 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q* arg1] $arg1 } {1 {1.6 3.4}} test binary-58.4 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q arg1] $arg1 } {1 1.6} test binary-58.5 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q arg1] $arg1 } {1 1.6} test binary-58.6 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q1 arg1] $arg1 } {1 1.6} test binary-58.7 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q1 arg1] $arg1 } {1 1.6} test binary-58.8 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q0 arg1] $arg1 } {1 {}} test binary-58.9 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q0 arg1] $arg1 } {1 {}} test binary-58.10 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1 } {1 {1.6 3.4}} test binary-58.11 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q2 arg1] $arg1 } {1 {1.6 3.4}} test binary-58.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 q1 arg1] $arg1 } {0 foo} -test binary-58.13 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-58.13 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-58.14 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} test binary-58.15 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 q2c* arg1 arg2] $arg1 $arg2 } {2 {1.6 3.4} 5} # scan R/r -test binary-59.1 {Tcl_BinaryObjCmd: scan} { - list [catch {binary scan abc r} msg] $msg -} {1 {not enough arguments for all format specifiers}} +test binary-59.1 {Tcl_BinaryObjCmd: scan} -returnCodes error -body { + binary scan abc r +} -result {not enough arguments for all format specifiers} test binary-59.2 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.3 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.4 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1 } {1 1.600000023841858} test binary-59.5 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1 } {1 1.600000023841858} test binary-59.6 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1 } {1 1.600000023841858} test binary-59.7 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1 } {1 1.600000023841858} test binary-59.8 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1 } {1 {}} test binary-59.9 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1 } {1 {}} test binary-59.10 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.11 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1} + unset -nocomplain arg1 list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1 } {1 {1.600000023841858 3.4000000953674316}} test binary-59.12 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} + unset -nocomplain arg1 set arg1 foo list [binary scan \x52 r1 arg1] $arg1 } {0 foo} -test binary-59.13 {Tcl_BinaryObjCmd: scan} { - catch {unset arg1} +test binary-59.13 {Tcl_BinaryObjCmd: scan} -setup { + unset -nocomplain arg1 +} -returnCodes error -body { set arg1 1 - list [catch {binary scan \x3f\xcc\xcc\xcd r1 arg1(a)} msg] $msg -} {1 {can't set "arg1(a)": variable isn't array}} + binary scan \x3f\xcc\xcc\xcd r1 arg1(a) +} -result {can't set "arg1(a)": variable isn't array} test binary-59.14 {Tcl_BinaryObjCmd: scan} bigEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2 } {2 {1.600000023841858 3.4000000953674316} 5} test binary-59.15 {Tcl_BinaryObjCmd: scan} littleEndian { - catch {unset arg1 arg2} + unset -nocomplain arg1 arg2 set arg1 foo set arg2 bar list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2 @@ -2245,7 +2328,7 @@ test binary-61.2 {Tcl_BinaryObjCmd: scan wide int} littleEndian { binary scan lcTolleH m x set x } 5216694956358656876 -test binary-61.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian { +test binary-61.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} littleEndian { binary scan [binary format w [expr {wide(3) << 31}]] m x set x } 6442450944 @@ -2254,65 +2337,6 @@ test binary-61.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} bigEndian { set x } 6442450944 -# Big test for correct ordering of data in [expr] - -proc testIEEE {} { - variable ieeeValues - binary scan [binary format dd -1.0 1.0] c* c - switch -exact -- $c { - {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { - # little endian - binary scan \x00\x00\x00\x00\x00\x00\xf0\xff d \ - ieeeValues(-Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf0\xbf d \ - ieeeValues(-Normal) - binary scan \x00\x00\x00\x00\x00\x00\x08\x80 d \ - ieeeValues(-Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\x00\x80 d \ - ieeeValues(-0) - binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+0) - binary scan \x00\x00\x00\x00\x00\x00\x08\x00 d \ - ieeeValues(+Subnormal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x3f d \ - ieeeValues(+Normal) - binary scan \x00\x00\x00\x00\x00\x00\xf0\x7f d \ - ieeeValues(+Infinity) - binary scan \x00\x00\x00\x00\x00\x00\xf8\x7f d \ - ieeeValues(NaN) - set ieeeValues(littleEndian) 1 - return 1 - } - {-65 -16 0 0 0 0 0 0 63 -16 0 0 0 0 0 0} { - binary scan \xff\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Infinity) - binary scan \xbf\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Normal) - binary scan \x80\x08\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-Subnormal) - binary scan \x80\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(-0) - binary scan \x00\x00\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+0) - binary scan \x00\x08\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Subnormal) - binary scan \x3f\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Normal) - binary scan \x7f\xf0\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(+Infinity) - binary scan \x7f\xf8\x00\x00\x00\x00\x00\x00 d \ - ieeeValues(NaN) - set ieeeValues(littleEndian) 0 - return 1 - } - default { - return 0 - } - } -} - -testConstraint ieeeFloatingPoint [testIEEE] - # scan/format infinities test binary-62.1 {infinity} ieeeFloatingPoint { @@ -2358,20 +2382,15 @@ test binary-63.4 {NaN} ieeeFloatingPoint { binary scan [binary format q {NaN( 3123456789aBc)}] w w format 0x%016lx [expr {$w & 0xfff3ffffffffffff}] } 0x7ff3123456789abc -test binary-64.1 {NaN} \ - -constraints ieeeFloatingPoint \ - -body { - binary scan [binary format w 0x7ff8000000000000] q d - set d - } \ - -match glob -result NaN* -test binary-64.2 {NaN} \ - -constraints ieeeFloatingPoint \ - -body { - binary scan [binary format w 0x7ff0123456789aBc] q d - set d - } \ - -match glob -result NaN(*123456789abc) + +test binary-64.1 {NaN} -constraints ieeeFloatingPoint -body { + binary scan [binary format w 0x7ff8000000000000] q d + set d +} -match glob -result NaN* +test binary-64.2 {NaN} -constraints ieeeFloatingPoint -body { + binary scan [binary format w 0x7ff0123456789aBc] q d + set d +} -match glob -result NaN(*123456789abc) test binary-65.1 {largest significand} ieeeFloatingPoint { binary scan [binary format w 0x3fcfffffffffffff] q d diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 94f422a..73a8819 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.61 2008/09/08 10:49:04 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.62 2008/09/10 13:50:04 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -968,9 +968,8 @@ test cmdAH-20.2 {Tcl_FileObjCmd: atime} -setup { [expr {[file atime $gorpfile] == $stat(atime)}] } -result {1 1} test cmdAH-20.3 {Tcl_FileObjCmd: atime} { - string tolower [list [catch {file atime _bogus_} msg] \ - $msg $errorCode] -} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}} + list [catch {file atime _bogus_} msg] [string tolower $msg] $errorCode +} {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} test cmdAH-20.4 {Tcl_FileObjCmd: atime} -returnCodes error -body { file atime $file notint } -result {expected integer but got "notint"} diff --git a/tests/cmdIL.test b/tests/cmdIL.test index cc1546e..ca9377a 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -1,14 +1,14 @@ -# This file contains a collection of tests for the procedures in the -# file tclCmdIL.c. Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. +# This file contains a collection of tests for the procedures in the file +# tclCmdIL.c. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdIL.test,v 1.39 2008/07/13 23:15:21 nijtmans Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.40 2008/09/10 13:50:05 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -17,22 +17,23 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +testConstraint testobj [llength [info commands testobj]] -test cmdIL-1.1 {Tcl_LsortObjCmd procedure} { - list [catch {lsort} msg] $msg -} {1 {wrong # args: should be "lsort ?-option value ...? list"}} -test cmdIL-1.2 {Tcl_LsortObjCmd procedure} { - list [catch {lsort -foo {1 3 2 5}} msg] $msg -} {1 {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique}} +test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body { + lsort +} -result {wrong # args: should be "lsort ?-option value ...? list"} +test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body { + lsort -foo {1 3 2 5} +} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, or -unique} test cmdIL-1.3 {Tcl_LsortObjCmd procedure, default options} { lsort {d e c b a \{ d35 d300} } {a b c d d300 d35 e \{} test cmdIL-1.4 {Tcl_LsortObjCmd procedure, -ascii option} { lsort -integer -ascii {d e c b a d35 d300} } {a b c d d300 d35 e} -test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} { - list [catch {lsort -command {1 3 2 5}} msg] $msg -} {1 {"-command" option must be followed by comparison command}} +test cmdIL-1.5 {Tcl_LsortObjCmd procedure, -command option} -body { + lsort -command {1 3 2 5} +} -returnCodes error -result {"-command" option must be followed by comparison command} test cmdIL-1.6 {Tcl_LsortObjCmd procedure, -command option} -setup { proc cmp {a b} { expr {[string match x* $b] - [string match x* $a]} @@ -54,12 +55,12 @@ test cmdIL-1.9 {Tcl_LsortObjCmd procedure, -dictionary option} { test cmdIL-1.10 {Tcl_LsortObjCmd procedure, -increasing option} { lsort -decreasing -increasing {d e c b a d35 d300} } {a b c d d300 d35 e} -test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} { - list [catch {lsort -index {1 3 2 5}} msg] $msg -} {1 {"-index" option must be followed by list index}} -test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} { - list [catch {lsort -index foo {1 3 2 5}} msg] $msg -} {1 {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?}} +test cmdIL-1.11 {Tcl_LsortObjCmd procedure, -index option} -body { + lsort -index {1 3 2 5} +} -returnCodes error -result {"-index" option must be followed by list index} +test cmdIL-1.12 {Tcl_LsortObjCmd procedure, -index option} -body { + lsort -index foo {1 3 2 5} +} -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} test cmdIL-1.13 {Tcl_LsortObjCmd procedure, -index option} { lsort -index end -integer {{2 25} {10 20 50 100} {3 16 42} 1} } {1 {2 25} {3 16 42} {10 20 50 100}} @@ -69,15 +70,15 @@ test cmdIL-1.14 {Tcl_LsortObjCmd procedure, -index option} { test cmdIL-1.15 {Tcl_LsortObjCmd procedure, -integer option} { lsort -integer {24 6 300 18} } {6 18 24 300} -test cmdIL-1.16 {Tcl_LsortObjCmd procedure, -integer option} { - list [catch {lsort -integer {1 3 2.4}} msg] $msg -} {1 {expected integer but got "2.4"}} +test cmdIL-1.16 {Tcl_LsortObjCmd procedure, -integer option} -body { + lsort -integer {1 3 2.4} +} -returnCodes error -result {expected integer but got "2.4"} test cmdIL-1.17 {Tcl_LsortObjCmd procedure, -real option} { lsort -real {24.2 6e3 150e-1} } {150e-1 24.2 6e3} -test cmdIL-1.18 {Tcl_LsortObjCmd procedure, bogus list} { - list [catch {lsort "1 2 3 \{ 4"} msg] $msg -} {1 {unmatched open brace in list}} +test cmdIL-1.18 {Tcl_LsortObjCmd procedure, bogus list} -body { + lsort "1 2 3 \{ 4" +} -returnCodes error -result {unmatched open brace in list} test cmdIL-1.19 {Tcl_LsortObjCmd procedure, empty list} { lsort {} } {} @@ -93,22 +94,21 @@ test cmdIL-1.24 {Tcl_LsortObjCmd procedure, order of -index and -command} -setup proc testcmp {a b} {return [string compare $a $b]} } -body { set l [list [list a b] [list c d]] - list [catch {lsort -command testcmp -index 1 $l} msg] $msg + lsort -command testcmp -index 1 $l } -cleanup { rename testcmp "" -} -result [list 0 [list [list a b] [list c d]]] +} -result [list [list a b] [list c d]] test cmdIL-1.25 {Tcl_LsortObjCmd procedure, order of -index and -command} -setup { catch {rename 1 ""} proc testcmp {a b} {return [string compare $a $b]} } -body { set l [list [list a b] [list c d]] - list [catch {lsort -index 1 -command testcmp $l} msg] $msg + lsort -index 1 -command testcmp $l } -cleanup { rename testcmp "" -} -result [list 0 [list [list a b] [list c d]]] -# Note that the required order only exists in the end-1'th element; -# indexing using the end element or any fixed offset from the start -# will not work... +} -result [list [list a b] [list c d]] +# Note that the required order only exists in the end-1'th element; indexing +# using the end element or any fixed offset from the start will not work... test cmdIL-1.26 {Tcl_LsortObjCmd procedure, offset indexing from end} { lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}} } {{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}} @@ -123,8 +123,8 @@ test cmdIL-1.29 {Tcl_LsortObjCmd procedure, loss of list rep during sorting} { string length [lsort -command {apply {args {string length $::l}}} $l] } 5 -# Can't think of any good tests for the MergeSort and MergeLists -# procedures, except a bunch of random lists to sort. +# Can't think of any good tests for the MergeSort and MergeLists procedures, +# except a bunch of random lists to sort. test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup { set result {} @@ -154,34 +154,30 @@ test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup { rename rand "" } -result {} -test cmdIL-3.1 {SortCompare procedure, skip comparisons after error} -setup { - proc cmp {a b} { - global x - incr x - error "error #$x" - } -} -body { - set x 0 - list [catch {lsort -integer -command cmp {48 6 28 190 16 2 3 6 1}} msg] \ - $msg $x -} -cleanup { - rename cmp "" +test cmdIL-3.1 {SortCompare procedure, skip comparisons after error} -body { + set ::x 0 + list [catch { + lsort -integer -command {apply {{a b} { + incr ::x + error "error #$::x" + }}} {48 6 28 190 16 2 3 6 1} + } msg] $msg $::x } -result {1 {error #1} 1} -test cmdIL-3.2 {SortCompare procedure, -index option} { - list [catch {lsort -integer -index 2 "\\\{ {30 40 50}"} msg] $msg -} {1 {unmatched open brace in list}} -test cmdIL-3.3 {SortCompare procedure, -index option} { - list [catch {lsort -integer -index 2 {{20 10} {15 30 40}}} msg] $msg -} {1 {element 2 missing from sublist "20 10"}} -test cmdIL-3.4 {SortCompare procedure, -index option} { - list [catch {lsort -integer -index 2 "{a b c} \\\{"} msg] $msg -} {1 {expected integer but got "c"}} -test cmdIL-3.4.1 {SortCompare procedure, -index option} { - list [catch {lsort -integer -index 2 "{1 2 3} \\\{"} msg] $msg -} {1 {unmatched open brace in list}} -test cmdIL-3.5 {SortCompare procedure, -index option} { - list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg -} {1 {element 2 missing from sublist "15"}} +test cmdIL-3.2 {SortCompare procedure, -index option} -body { + lsort -integer -index 2 "\\\{ {30 40 50}" +} -returnCodes error -result {unmatched open brace in list} +test cmdIL-3.3 {SortCompare procedure, -index option} -body { + lsort -integer -index 2 {{20 10} {15 30 40}} +} -returnCodes error -result {element 2 missing from sublist "20 10"} +test cmdIL-3.4 {SortCompare procedure, -index option} -body { + lsort -integer -index 2 "{a b c} \\\{" +} -returnCodes error -result {expected integer but got "c"} +test cmdIL-3.4.1 {SortCompare procedure, -index option} -body { + lsort -integer -index 2 "{1 2 3} \\\{" +} -returnCodes error -result {unmatched open brace in list} +test cmdIL-3.5 {SortCompare procedure, -index option} -body { + lsort -integer -index 2 {{20 10 13} {15}} +} -returnCodes error -result {element 2 missing from sublist "15"} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} @@ -191,21 +187,21 @@ test cmdIL-3.7 {SortCompare procedure, -ascii option} { test cmdIL-3.8 {SortCompare procedure, -dictionary option} { lsort -dictionary {d e c b a d35 d300 100 20} } {20 100 a b c d d35 d300 e} -test cmdIL-3.9 {SortCompare procedure, -integer option} { - list [catch {lsort -integer {x 3}} msg] $msg -} {1 {expected integer but got "x"}} -test cmdIL-3.10 {SortCompare procedure, -integer option} { - list [catch {lsort -integer {3 q}} msg] $msg -} {1 {expected integer but got "q"}} +test cmdIL-3.9 {SortCompare procedure, -integer option} -body { + lsort -integer {x 3} +} -returnCodes error -result {expected integer but got "x"} +test cmdIL-3.10 {SortCompare procedure, -integer option} -body { + lsort -integer {3 q} +} -returnCodes error -result {expected integer but got "q"} test cmdIL-3.11 {SortCompare procedure, -integer option} { lsort -integer {35 21 0x20 30 0o23 100 8} } {8 0o23 21 30 0x20 35 100} -test cmdIL-3.12 {SortCompare procedure, -real option} { - list [catch {lsort -real {6...4 3}} msg] $msg -} {1 {expected floating-point number but got "6...4"}} -test cmdIL-3.13 {SortCompare procedure, -real option} { - list [catch {lsort -real {3 1x7}} msg] $msg -} {1 {expected floating-point number but got "1x7"}} +test cmdIL-3.12 {SortCompare procedure, -real option} -body { + lsort -real {6...4 3} +} -returnCodes error -result {expected floating-point number but got "6...4"} +test cmdIL-3.13 {SortCompare procedure, -real option} -body { + lsort -real {3 1x7} +} -returnCodes error -result {expected floating-point number but got "1x7"} test cmdIL-3.14 {SortCompare procedure, -real option} { lsort -real {24 2.5e01 16.7 85e-1 10.004} } {85e-1 10.004 16.7 24 2.5e01} @@ -237,10 +233,10 @@ test cmdIL-3.17 {SortCompare procedure, -command option, non-integer result} -bo proc cmp {a b} { return foow } - list [catch {lsort -command cmp {48 6}} msg] $msg -} -cleanup { + lsort -command cmp {48 6} +} -returnCodes error -cleanup { rename cmp "" -} -result {1 {-compare command returned non-integer result}} +} -result {-compare command returned non-integer result} test cmdIL-3.18 {SortCompare procedure, -command option} -body { proc cmp {a b} { expr {$b - $a} @@ -440,108 +436,71 @@ test cmdIL-5.5 {lsort with list style index and sharing} -body { } # Compiled version -test cmdIL-6.1 {lassign command syntax} -body { - proc testLassign {} { - lassign - } - testLassign -} -returnCodes 1 -cleanup { - rename testLassign {} +test cmdIL-6.1 {lassign command syntax} -returnCodes error -body { + apply {{} { lassign }} } -result {wrong # args: should be "lassign list varName ?varName ...?"} -test cmdIL-6.2 {lassign command syntax} -body { - proc testLassign {} { - lassign x - } - testLassign -} -returnCodes 1 -cleanup { - rename testLassign {} +test cmdIL-6.2 {lassign command syntax} -returnCodes error -body { + apply {{} { lassign x }} } -result {wrong # args: should be "lassign list varName ?varName ...?"} test cmdIL-6.3 {lassign command} -body { - proc testLassign {} { + apply {{} { set x FAIL list [lassign a x] $x - } - testLassign -} -result {{} a} -cleanup { - rename testLassign {} -} + }} +} -result {{} a} test cmdIL-6.4 {lassign command} -body { - proc testLassign {} { + apply {{} { set x FAIL set y FAIL list [lassign a x y] $x $y - } - testLassign -} -result {{} a {}} -cleanup { - rename testLassign {} -} + }} +} -result {{} a {}} test cmdIL-6.5 {lassign command} -body { - proc testLassign {} { + apply {{} { set x FAIL set y FAIL list [lassign {a b} x y] $x $y - } - testLassign -} -result {{} a b} -cleanup { - rename testLassign {} -} + }} +} -result {{} a b} test cmdIL-6.6 {lassign command} -body { - proc testLassign {} { + apply {{} { set x FAIL set y FAIL list [lassign {a b c} x y] $x $y - } - testLassign -} -result {c a b} -cleanup { - rename testLassign {} -} + }} +} -result {c a b} test cmdIL-6.7 {lassign command} -body { - proc testLassign {} { + apply {{} { set x FAIL set y FAIL list [lassign {a b c d} x y] $x $y - } - testLassign -} -result {{c d} a b} -cleanup { - rename testLassign {} -} + }} +} -result {{c d} a b} test cmdIL-6.8 {lassign command - list format error} -body { - proc testLassign {} { + apply {{} { set x FAIL set y FAIL list [catch {lassign {a {b}c d} x y} msg] $msg $x $y - } - testLassign -} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} -cleanup { - rename testLassign {} -} + }} +} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} test cmdIL-6.9 {lassign command - assignment to arrays} -body { - proc testLassign {} { + apply {{} { list [lassign {a b} x(x)] $x(x) - } - testLassign -} -result {b a} -cleanup { - rename testLassign {} -} + }} +} -result {b a} test cmdIL-6.10 {lassign command - variable update error} -body { - proc testLassign {} { + apply {{} { set x(x) {} lassign a x - } - testLassign -} -returnCodes 1 -result {can't set "x": variable is array} -cleanup { - rename testLassign {} -} + }} +} -returnCodes error -result {can't set "x": variable is array} test cmdIL-6.11 {lassign command - variable update error} -body { - proc testLassign {} { + apply {{} { set x(x) {} set y FAIL list [catch {lassign a y x} msg] $msg $y - } - testLassign -} -result {1 {can't set "x": variable is array} a} -cleanup { - rename testLassign {} -} + }} +} -result {1 {can't set "x": variable is array} a} test cmdIL-6.12 {lassign command - memory leak testing} -setup { unset -nocomplain x y set x(x) {} @@ -570,119 +529,86 @@ test cmdIL-6.12 {lassign command - memory leak testing} -setup { rename stress {} } # Force non-compiled version -test cmdIL-6.13 {lassign command syntax} -body { - proc testLassign {} { +test cmdIL-6.13 {lassign command syntax} -returnCodes error -body { + apply {{} { set lassign lassign $lassign - } - testLassign -} -returnCodes 1 -cleanup { - rename testLassign {} + }} } -result {wrong # args: should be "lassign list varName ?varName ...?"} -test cmdIL-6.14 {lassign command syntax} -body { - proc testLassign {} { +test cmdIL-6.14 {lassign command syntax} -returnCodes error -body { + apply {{} { set lassign lassign $lassign x - } - testLassign -} -returnCodes 1 -cleanup { - rename testLassign {} + }} } -result {wrong # args: should be "lassign list varName ?varName ...?"} test cmdIL-6.15 {lassign command} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x FAIL list [$lassign a x] $x - } - testLassign -} -result {{} a} -cleanup { - rename testLassign {} -} + }} +} -result {{} a} test cmdIL-6.16 {lassign command} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x FAIL set y FAIL list [$lassign a x y] $x $y - } - testLassign -} -result {{} a {}} -cleanup { - rename testLassign {} -} + }} +} -result {{} a {}} test cmdIL-6.17 {lassign command} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x FAIL set y FAIL list [$lassign {a b} x y] $x $y - } - testLassign -} -result {{} a b} -cleanup { - rename testLassign {} -} + }} +} -result {{} a b} test cmdIL-6.18 {lassign command} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x FAIL set y FAIL list [$lassign {a b c} x y] $x $y - } - testLassign -} -result {c a b} -cleanup { - rename testLassign {} -} + }} +} -result {c a b} test cmdIL-6.19 {lassign command} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x FAIL set y FAIL list [$lassign {a b c d} x y] $x $y - } - testLassign -} -result {{c d} a b} -cleanup { - rename testLassign {} -} + }} +} -result {{c d} a b} test cmdIL-6.20 {lassign command - list format error} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x FAIL set y FAIL list [catch {$lassign {a {b}c d} x y} msg] $msg $x $y - } - testLassign -} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} -cleanup { - rename testLassign {} -} + }} +} -result {1 {list element in braces followed by "c" instead of space} FAIL FAIL} test cmdIL-6.21 {lassign command - assignment to arrays} -body { - proc testLassign {} { + apply {{} { set lassign lassign list [$lassign {a b} x(x)] $x(x) - } - testLassign -} -result {b a} -cleanup { - rename testLassign {} -} + }} +} -result {b a} test cmdIL-6.22 {lassign command - variable update error} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x(x) {} $lassign a x - } - testLassign -} -returnCodes 1 -result {can't set "x": variable is array} -cleanup { - rename testLassign {} -} + }} +} -returnCodes 1 -result {can't set "x": variable is array} test cmdIL-6.23 {lassign command - variable update error} -body { - proc testLassign {} { + apply {{} { set lassign lassign set x(x) {} set y FAIL list [catch {$lassign a y x} msg] $msg $y - } - testLassign -} -result {1 {can't set "x": variable is array} a} -cleanup { - rename testLassign {} -} + }} +} -result {1 {can't set "x": variable is array} a} test cmdIL-6.24 {lassign command - memory leak testing} -setup { set x(x) {} set y FAIL @@ -712,24 +638,18 @@ test cmdIL-6.24 {lassign command - memory leak testing} -setup { } # Assorted shimmering problems test cmdIL-6.25 {lassign command - shimmering protection} -body { - proc testLassign {} { + apply {{} { set x {a b c} list [lassign $x $x y] $x [set $x] $y - } - testLassign -} -result {c {a b c} a b} -cleanup { - rename testLassign {} -} + }} +} -result {c {a b c} a b} test cmdIL-6.26 {lassign command - shimmering protection} -body { - proc testLassign {} { + apply {{} { set x {a b c} set lassign lassign list [$lassign $x $x y] $x [set $x] $y - } - testLassign -} -result {c {a b c} a b} -cleanup { - rename testLassign {} -} + }} +} -result {c {a b c} a b} test cmdIL-7.1 {lreverse command} -body { lreverse @@ -753,8 +673,6 @@ test cmdIL-7.6 {lreverse command - unshared object [Bug 1672585]} { test cmdIL-7.7 {lreverse command - empty object [Bug 1876793]} { lreverse [list] } {} - -testConstraint testobj [llength [info commands testobj]] test cmdIL-7.8 {lreverse command - shared intrep [Bug 1675044]} -setup { teststringobj set 1 {1 2 3} testobj convert 1 list diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 85b7bde..ae96301 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -1,17 +1,17 @@ # The tests in this file cover the procedures in tclCmdMZ.c. # -# 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. +# 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 (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdMZ.test,v 1.25 2006/10/09 19:15:44 msofer Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.26 2008/09/10 13:50:05 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -26,49 +26,64 @@ namespace eval ::tcl::test::cmdMZ { namespace import ::tcltest::temporaryDirectory namespace import ::tcltest::test + proc ListGlobMatch {expected actual} { + if {[llength $expected] != [llength $actual]} { + return 0 + } + foreach e $expected a $actual { + if {![string match $e $a]} { + return 0 + } + } + return 1 + } + customMatch listGlob [namespace which ListGlobMatch] + # Tcl_PwdObjCmd -test cmdMZ-1.1 {Tcl_PwdObjCmd} { - list [catch {pwd a} msg] $msg -} {1 {wrong # args: should be "pwd"}} +test cmdMZ-1.1 {Tcl_PwdObjCmd} -returnCodes error -body { + pwd a +} -result {wrong # args: should be "pwd"} test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} { catch pwd } 0 -test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} { - expr [string length pwd]>0 -} 1 -test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unix nonPortable} { - # This test fails on various unix platforms (eg Linux) where - # permissions caching causes this to fail. The caching is strictly - # incorrect, but we have no control over that. +test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} -body { + pwd +} -match glob -result {?*} +test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} -setup { + set cwd [pwd] set foodir [file join [temporaryDirectory] foo] file delete -force $foodir file mkdir $foodir - set cwd [pwd] cd $foodir +} -constraints {unix nonPortable} -body { + # This test fails on various unix platforms (eg Linux) where permissions + # caching causes this to fail. The caching is strictly incorrect, but we + # have no control over that. file attr . -permissions 000 - set result [list [catch {pwd} msg] $msg] + pwd +} -returnCodes error -cleanup { cd $cwd file delete -force $foodir - set result -} {1 {error getting working directory name: permission denied}} +} -result {error getting working directory name: permission denied} # The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test # Tcl_RenameObjCmd -test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} { - list [catch {rename r1} msg] $msg $::errorCode -} {1 {wrong # args: should be "rename oldName newName"} NONE} -test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} { - list [catch {rename r1 r2 r3} msg] $msg $::errorCode -} {1 {wrong # args: should be "rename oldName newName"} NONE} -test cmdMZ-2.3 {Tcl_RenameObjCmd: success} { +test cmdMZ-2.1 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body { + rename r1 +} -result {wrong # args: should be "rename oldName newName"} +test cmdMZ-2.2 {Tcl_RenameObjCmd: error conditions} -returnCodes error -body { + rename r1 r2 r3 +} -result {wrong # args: should be "rename oldName newName"} +test cmdMZ-2.3 {Tcl_RenameObjCmd: success} -setup { catch {rename r2 {}} +} -body { proc r1 {} {return "r1"} rename r1 r2 r2 -} {r1} +} -result {r1} test cmdMZ-2.4 {Tcl_RenameObjCmd: success} { proc r1 {} {return "r1"} rename r1 {} @@ -88,17 +103,18 @@ test cmdMZ-return-1.2 {return checks for bad option values} -body { } -returnCodes error -match glob -result {bad completion code*} test cmdMZ-return-1.3 {return checks for bad option values} -body { return -level foo -} -returnCodes error -match glob -result {bad -level value:*} +} -returnCodes error -match glob -result {bad -level value: *} test cmdMZ-return-1.4 {return checks for bad option values} -body { return -level -1 -} -returnCodes error -match glob -result {bad -level value:*} +} -returnCodes error -match glob -result {bad -level value: *} test cmdMZ-return-1.5 {return checks for bad option values} -body { return -level 3.1415926 -} -returnCodes error -match glob -result {bad -level value:*} +} -returnCodes error -match glob -result {bad -level value: *} proc dictSort {d} { + set result {} foreach k [lsort [dict keys $d]] { - lappend result $k [dict get $d $k] + dict set result $k [dict get $d $k] } return $result } @@ -150,67 +166,61 @@ test cmdMZ-return-2.13 {return option handling} -body { test cmdMZ-return-2.14 {return option handling} -body { return -level 0 -code error -options {-code foo -options {-code break}} } -returnCodes break -result {} - test cmdMZ-return-2.15 {return opton handling} -setup { - proc p {} { - return -code error -errorcode {a b} c - } - } -body { - list [catch p result] $result $::errorCode - } -cleanup { - rename p {} - } -result {1 c {a b}} - + proc p {} { + return -code error -errorcode {a b} c + } +} -body { + list [catch p result] $result $::errorCode +} -cleanup { + rename p {} +} -result {1 c {a b}} test cmdMZ-return-2.16 {return opton handling} -setup { - proc p {} { - return -code error -errorcode [list a b] c - } - } -body { - list [catch p result] $result $::errorCode - } -cleanup { - rename p {} - } -result {1 c {a b}} - + proc p {} { + return -code error -errorcode [list a b] c + } +} -body { + list [catch p result] $result $::errorCode +} -cleanup { + rename p {} +} -result {1 c {a b}} test cmdMZ-return-2.17 {return opton handling} -setup { - proc p {} { - return -code error -errorcode a\ b c - } - } -body { - list [catch p result] $result $::errorCode - } -cleanup { - rename p {} - } -result {1 c {a b}} - + proc p {} { + return -code error -errorcode a\ b c + } +} -body { + list [catch p result] $result $::errorCode +} -cleanup { + rename p {} +} -result {1 c {a b}} # Check that the result of a [return -options $opts $result] is -# indistinguishable from that of the originally caught script, no -# matter what the script is/does. (TIP 90) -set i 0 -foreach script { - {} - {format x} - {set} - {set a 1} - {error} - {error foo} - {error foo bar} - {error foo bar baz} - {return -level 0} - {return -code error} - {return -code error -errorinfo foo} - {return -code error -errorinfo foo -errorcode bar} - {return -code error -errorinfo foo -errorcode bar -errorline 10} - {return -options {x y z 2}} - {return -level 3 -code break sdf} +# indistinguishable from that of the originally caught script, no matter what +# the script is/does. (TIP 90) +foreach {testid script} { + cmdMZ-return-3.0 {} + cmdMZ-return-3.1 {format x} + cmdMZ-return-3.2 {set} + cmdMZ-return-3.3 {set a 1} + cmdMZ-return-3.4 {error} + cmdMZ-return-3.5 {error foo} + cmdMZ-return-3.6 {error foo bar} + cmdMZ-return-3.7 {error foo bar baz} + cmdMZ-return-3.8 {return -level 0} + cmdMZ-return-3.9 {return -code error} + cmdMZ-return-3.10 {return -code error -errorinfo foo} + cmdMZ-return-3.11 {return -code error -errorinfo foo -errorcode bar} + cmdMZ-return-3.12 {return -code error -errorinfo foo -errorcode bar -errorline 10} + cmdMZ-return-3.13 {return -options {x y z 2}} + cmdMZ-return-3.14 {return -level 3 -code break sdf} } { - test cmdMZ-return-3.$i "check that return after a catch is same:\n$script" { + test $testid "check that return after a catch is same:\n$script" { set one [list [catch $script foo bar] $foo [dictSort $bar] \ $::errorCode $::errorInfo] set two [list [catch {return -options $bar $foo} foo2 bar2] \ $foo2 [dictSort $bar2] $::errorCode $::errorInfo] string equal $one $two } 1 - incr i } # The tests for Tcl_ScanObjCmd are in scan.test @@ -220,58 +230,44 @@ foreach script { test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrPc -} -body { - list [catch {source} msg] $msg -} -match glob -result {1 {wrong # args: should be "source*fileName"}} +} -returnCodes error -body { + source +} -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrPc -} -body { - list [catch {source a b} msg] $msg -} -match glob -result {1 {wrong # args: should be "source*fileName"}} - -proc ListGlobMatch {expected actual} { - if {[llength $expected] != [llength $actual]} { - return 0 - } - foreach e $expected a $actual { - if {![string match $e $a]} { - return 0 - } - } - return 1 -} -customMatch listGlob [namespace which ListGlobMatch] - +} -returnCodes error -body { + source a b +} -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { set x 146 error "error in sourced file" set y $x } source.file] - set result [list [catch {source $file} msg] $msg $::errorInfo] + list [catch {source $file} msg] $msg $::errorInfo +} -cleanup { removeFile source.file - set result } -match listGlob -result {1 {error in sourced file} {error in sourced file while executing "error "error in sourced file"" (file "*" line 3) invoked from within "source $file"}} -test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} { - set file [makeFile {list result} source.file] - set result [source $file] +test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} -body { + set file [makeFile {list ok} source.file] + source $file +} -cleanup { removeFile source.file - set result -} result +} -result ok # Tcl_SplitObjCmd -test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} { - list [catch split msg] $msg $::errorCode -} {1 {wrong # args: should be "split string ?splitChars?"} NONE} -test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} { - list [catch {split a b c} msg] $msg $::errorCode -} {1 {wrong # args: should be "split string ?splitChars?"} NONE} +test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} -returnCodes error -body { + split +} -result {wrong # args: should be "split string ?splitChars?"} +test cmdMZ-4.2 {Tcl_SplitObjCmd: split errors} -returnCodes error -body { + split a b c +} -result {wrong # args: should be "split string ?splitChars?"} test cmdMZ-4.3 {Tcl_SplitObjCmd: basic split commands} { split "a\n b\t\r c\n " } {a {} b {} {} c {} {}} @@ -294,23 +290,22 @@ test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { split { } } {{} {} {} {}} test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { - proc foo {} { + apply {{} { set x {} foreach f [split {]\n} {}] { append x $f } - return $x - } - foo + return $x + }} } {]\n} test cmdMZ-4.11 {Tcl_SplitObjCmd: basic split commands} { - proc foo {} { + apply {{} { set x ab\000c set y [split $x {}] - return $y - } - foo -} "a b \000 c" + binary scan $y c* z + return $z + }} +} {97 32 98 32 0 32 99} test cmdMZ-4.12 {Tcl_SplitObjCmd: basic split commands} { split "a0ab1b2bbb3\000c4" ab\000c } {{} 0 {} 1 2 {} {} 3 {} 4} @@ -323,21 +318,21 @@ test cmdMZ-4.13 {Tcl_SplitObjCmd: basic split commands} { # The tests for Tcl_SubstObjCmd are in subst.test # The tests for Tcl_SwitchObjCmd are in switch.test -test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} { - list [catch {time} msg] $msg -} {1 {wrong # args: should be "time command ?count?"}} -test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} { - list [catch {time a b c} msg] $msg -} {1 {wrong # args: should be "time command ?count?"}} -test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} { - list [catch {time a b} msg] $msg -} {1 {expected integer but got "b"}} +test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body { + time +} -returnCodes error -result {wrong # args: should be "time command ?count?"} +test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body { + time a b c +} -returnCodes error -result {wrong # args: should be "time command ?count?"} +test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body { + time a b +} -returnCodes error -result {expected integer but got "b"} test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} { time bogusCmd -12456 } {0 microseconds per iteration} -test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} { - regexp {^\d+ microseconds per iteration} [time {format 1}] -} 1 +test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body { + time {format 1} +} -match regexp -result {^\d+ microseconds per iteration} test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} { expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]} } 1 @@ -356,3 +351,7 @@ cleanupTests } namespace delete ::tcl::test::cmdMZ return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/compile.test b/tests/compile.test index fe2deea..7d282ae 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compile.test,v 1.48 2007/12/13 15:26:06 dgp Exp $ +# RCS: @(#) $Id: compile.test,v 1.49 2008/09/10 13:50:05 dkf Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -601,6 +601,91 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup interp delete $i } -result substituted +# This tests the supported parts of the unsupported [disassemble] command. It +# does not check the format of disassembled bytecode though; that's liable to +# change without warning. + +test compile-18.1 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble +} -match glob -result {wrong # args: should be "*"} +test compile-18.2 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble ? +} -match glob -result {bad type "?": must be *} +test compile-18.3 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble lambda +} -match glob -result {wrong # args: should be "* lambda lambdaTerm"} +test compile-18.4 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble lambda \{ +} -result "can't interpret \"\{\" as a lambda expression" +test compile-18.5 {disassembler - basics} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble lambda {{} {}} +} -match glob -result * +test compile-18.6 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble proc +} -match glob -result {wrong # args: should be "* proc procName"} +test compile-18.7 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble proc nosuchproc +} -result {"nosuchproc" isn't a procedure} +test compile-18.8 {disassembler - basics} -setup { + proc chewonthis {} {} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble proc chewonthis +} -cleanup { + rename chewonthis {} +} -match glob -result * +test compile-18.9 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble script +} -match glob -result {wrong # args: should be "* script script"} +test compile-18.10 {disassembler - basics} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble script {} +} -match glob -result * +test compile-18.11 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble method +} -match glob -result {wrong # args: should be "* method className methodName"} +test compile-18.12 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble method nosuchclass foo +} -result {nosuchclass does not refer to an object} +test compile-18.13 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble method justanobject foo +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.14 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble method oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.15 {disassembler - basics} -setup { + oo::class create foo {method bar {} {}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble method foo bar +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.16 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble objmethod +} -match glob -result {wrong # args: should be "* objmethod objectName methodName"} +test compile-18.17 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble objmethod nosuchobject foo +} -result {nosuchobject does not refer to an object} +test compile-18.18 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble objmethod oo::object nosuchmethod +} -result {unknown method "nosuchmethod"} +test compile-18.19 {disassembler - basics} -setup { + oo::object create foo + oo::objdefine foo {method bar {} {}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble objmethod foo bar +} -cleanup { + foo destroy +} -match glob -result * +# TODO sometime - check that bytecode from tbcload is *not* disassembled. + # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 2acdbd2..9937618 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -1,13 +1,13 @@ # This file tests the filesystem and vfs internals. # -# 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. +# 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 (c) 2002 Vincent Darley. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2 namespace eval ::tcl::test::fileSystem { @@ -88,6 +88,8 @@ testConstraint hasLinks [expr {![catch { if {[testConstraint testsetplatform]} { set platform [testgetplatform] } + +# ---------------------------------------------------------------------- test filesystem-1.0 {link normalisation} {hasLinks} { string equal [file normalize gorp.file] [file normalize link.file] @@ -112,16 +114,16 @@ test filesystem-1.5 {link normalisation} {hasLinks} { [file normalize [file join dir.dir linkinside.file]] } {1} test filesystem-1.6 {link normalisation} {hasLinks} { - string equal [file normalize [file join dir.dir linkinside.file]] \ - [file normalize [file join dir.link inside.file]] + string equal [file normalize [file join dir.dir linkinside.file]] \ + [file normalize [file join dir.link inside.file]] } {0} test filesystem-1.7 {link normalisation} {hasLinks unix} { testPathEqual [file normalize [file join dir.link linkinside.file foo]] \ [file normalize [file join dir.dir inside.file foo]] } {1} test filesystem-1.8 {link normalisation} {hasLinks} { - string equal [file normalize [file join dir.dir linkinside.filefoo]] \ - [file normalize [file join dir.link inside.filefoo]] + string equal [file normalize [file join dir.dir linkinside.filefoo]] \ + [file normalize [file join dir.link inside.filefoo]] } {0} test filesystem-1.9 {link normalisation} {unix hasLinks} { file delete -force dir.link @@ -203,12 +205,8 @@ test filesystem-1.26 {link normalisation: link and ..} {hasLinks} { file link dir2.link [file join dir2 foo bar] set res [list [file normalize [file join dir2 foo x]] \ [file normalize [file join dir2.link .. x]]] - if {![string equal [lindex $res 0] [lindex $res 1]]} { - set res "$res not equal" - } else { - set res "ok" - } -} {ok} + testPathEqual [lindex $res 0] [lindex $res 1] +} 1 test filesystem-1.27 {file normalisation: up and down with ..} { set dir [file join dir2 foo bar] file mkdir $dir @@ -229,12 +227,8 @@ test filesystem-1.28 {link normalisation: link with .. and ..} {hasLinks} { file link dir2.link $to set res [list [file normalize [file join dir2 foo x]] \ [file normalize [file join dir2.link .. x]]] - if {![string equal [lindex $res 0] [lindex $res 1]]} { - set res "$res not equal" - } else { - set res "ok" - } -} {ok} + testPathEqual [lindex $res 0] [lindex $res 1] +} 1 test filesystem-1.29 {link normalisation: link with ..} {hasLinks} { file delete -force dir2.link set dir [file join dir2 foo bar] @@ -242,11 +236,10 @@ test filesystem-1.29 {link normalisation: link with ..} {hasLinks} { set to [file join dir2 .. dir2 foo .. foo bar] file link dir2.link $to set res [file normalize [file join dir2.link x yyy z]] - if {[string first ".." $res] != -1} { - set res "$res must not contain '..'" - } else { - set res "ok" + if {[string match *..* $res]} { + return "$res must not contain '..'" } + return "ok" } {ok} test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} { testPathEqual [file normalize [file join dir.link dirinside.link abc]] \ @@ -260,9 +253,9 @@ 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} { - list [catch {file normalize ~noonewiththisname} err] $err -} {1 {user "noonewiththisname" doesn't exist}} +test filesystem-1.30 {normalisation of nonexistent user} -body { + file normalize ~noonewiththisname +} -returnCodes error -result {user "noonewiththisname" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar @@ -275,8 +268,8 @@ test filesystem-1.33 {link normalisation: link near filesystem root} {testsetpla testsetplatform windows set res [file normalize C:/../bar] if {[testConstraint unix]} { - # Some unices go further in normalizing this -- not really - # a problem since this is a Windows test + # Some unices go further in normalizing this -- not really a problem + # since this is a Windows test. regexp {C:/bar$} $res res } set res @@ -346,7 +339,6 @@ test filesystem-1.39 {file normalisation with volume relative} {win} { test filesystem-1.40 {file normalisation with repeated separators} { set a [file norm foo////bar] set b [file norm foo/bar] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -356,7 +348,6 @@ test filesystem-1.40 {file normalisation with repeated separators} { test filesystem-1.41 {file normalisation with repeated separators} {win} { set a [file norm foo\\\\\\bar] set b [file norm foo/bar] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -366,7 +357,6 @@ test filesystem-1.41 {file normalisation with repeated separators} {win} { test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/..] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -376,7 +366,6 @@ test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/../] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -386,7 +375,6 @@ test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/foo/../..] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -396,7 +384,6 @@ test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/foo/../../] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -406,7 +393,6 @@ test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/foo/../../bar] set b [file norm /bar] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -416,7 +402,6 @@ test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/../../bar] set b [file norm /bar] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -426,7 +411,6 @@ test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /xxx/../bar] set b [file norm /bar] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -436,7 +420,6 @@ test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /..] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -446,7 +429,6 @@ test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /../] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -456,7 +438,6 @@ test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /.] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -466,7 +447,6 @@ test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /./] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -476,7 +456,6 @@ test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /../..] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -486,7 +465,6 @@ test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} { test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} { set a [file norm /../../] set b [file norm /] - if {![string equal $a $b]} { set res "Paths should be equal: $a , $b" } else { @@ -507,15 +485,12 @@ if {[testConstraint testfilesystem]} { while {![catch {testfilesystem 0}]} {} } -test filesystem-3.0 {Tcl_FSRegister} testfilesystem { - testfilesystem 1 -} {registered} -test filesystem-3.1 {Tcl_FSUnregister} testfilesystem { - testfilesystem 0 -} {unregistered} -test filesystem-3.2 {Tcl_FSUnregister} testfilesystem { - list [catch {testfilesystem 0} err] $err -} {1 failed} +test filesystem-3.1 {Tcl_FSRegister & Tcl_FSUnregister} testfilesystem { + set result {} + lappend result [testfilesystem 1] + lappend result [testfilesystem 0] + lappend result [catch {testfilesystem 0} msg] $msg +} {registered unregistered 1 failed} test filesystem-3.3 {Tcl_FSRegister} testfilesystem { testfilesystem 1 testfilesystem 1 @@ -531,274 +506,212 @@ test filesystem-3.5 {Tcl_FSUnregister} testfilesystem { lindex [file system bar] 0 } {native} -test filesystem-4.0 {testfilesystem} { - -constraints testfilesystem - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - file exists foo - testfilesystem 0 - set filesystemReport - } - -result {*{access foo}} -} -test filesystem-4.1 {testfilesystem} { - -constraints testfilesystem - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - catch {file stat foo bar} - testfilesystem 0 - set filesystemReport - } - -result {*{stat foo}} -} -test filesystem-4.2 {testfilesystem} { - -constraints testfilesystem - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - catch {file lstat foo bar} - testfilesystem 0 - set filesystemReport - } - -result {*{lstat foo}} -} -test filesystem-4.3 {testfilesystem} { - -constraints testfilesystem - -match glob - -body { - testfilesystem 1 - set filesystemReport {} - catch {glob *} - testfilesystem 0 - set filesystemReport - } - -result {*{matchindirectory *}*} -} +test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + file exists foo + testfilesystem 0 + set filesystemReport +} -match glob -result {*{access foo}} +test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + catch {file stat foo bar} + testfilesystem 0 + set filesystemReport +} -match glob -result {*{stat foo}} +test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + catch {file lstat foo bar} + testfilesystem 0 + set filesystemReport +} -match glob -result {*{lstat foo}} +test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { + testfilesystem 1 + set filesystemReport {} + catch {glob *} + testfilesystem 0 + set filesystemReport +} -match glob -result {*{matchindirectory *}*} -test filesystem-5.1 {cache and ~} { - -constraints testfilesystem - -match regexp - -body { - set orig $::env(HOME) - set ::env(HOME) /foo/bar/blah - set testdir ~ - set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]" - set ::env(HOME) /a/b/c - set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]" - set ::env(HOME) $orig - list $res1 $res2 - } - -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/a/b|a:b)}} -} +test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { + set orig $::env(HOME) +} -body { + set ::env(HOME) /foo/bar/blah + set testdir ~ + set res1 "Parent of ~ (/foo/bar/blah) is [file dirname $testdir]" + set ::env(HOME) /a/b/c + set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]" + list $res1 $res2 +} -cleanup { + set ::env(HOME) $orig +} -match regexp -result {{Parent of ~ \(/foo/bar/blah\) is ([a-zA-Z]:)?(/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is ([a-zA-Z]:)?(/a/b|a:b)}} -test filesystem-6.1 {empty file name} { - list [catch {open ""} msg] $msg -} {1 {couldn't open "": no such file or directory}} -test filesystem-6.2 {empty file name} { - list [catch {file stat "" arr} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.3 {empty file name} { - list [catch {file atime ""} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.4 {empty file name} { - list [catch {file attributes ""} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.5 {empty file name} { - list [catch {file copy "" ""} msg] $msg -} {1 {error copying "": no such file or directory}} -test filesystem-6.6 {empty file name} { - list [catch {file delete ""} msg] $msg -} {0 {}} -test filesystem-6.7 {empty file name} { - list [catch {file dirname ""} msg] $msg -} {0 .} -test filesystem-6.8 {empty file name} { - list [catch {file executable ""} msg] $msg -} {0 0} -test filesystem-6.9 {empty file name} { - list [catch {file exists ""} msg] $msg -} {0 0} -test filesystem-6.10 {empty file name} { - list [catch {file extension ""} msg] $msg -} {0 {}} -test filesystem-6.11 {empty file name} { - list [catch {file isdirectory ""} msg] $msg -} {0 0} -test filesystem-6.12 {empty file name} { - list [catch {file isfile ""} msg] $msg -} {0 0} -test filesystem-6.13 {empty file name} { - list [catch {file join ""} msg] $msg -} {0 {}} -test filesystem-6.14 {empty file name} { - list [catch {file link ""} msg] $msg -} {1 {could not read link "": no such file or directory}} -test filesystem-6.15 {empty file name} { - list [catch {file lstat "" arr} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.16 {empty file name} { - list [catch {file mtime ""} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.17 {empty file name} { - list [catch {file mtime "" 0} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.18 {empty file name} { - list [catch {file mkdir ""} msg] $msg -} {1 {can't create directory "": no such file or directory}} -test filesystem-6.19 {empty file name} { - list [catch {file nativename ""} msg] $msg -} {0 {}} -test filesystem-6.20 {empty file name} { - list [catch {file normalize ""} msg] $msg -} {0 {}} -test filesystem-6.21 {empty file name} { - list [catch {file owned ""} msg] $msg -} {0 0} -test filesystem-6.22 {empty file name} { - list [catch {file pathtype ""} msg] $msg -} {0 relative} -test filesystem-6.23 {empty file name} { - list [catch {file readable ""} msg] $msg -} {0 0} -test filesystem-6.24 {empty file name} { - list [catch {file readlink ""} msg] $msg -} {1 {could not readlink "": no such file or directory}} -test filesystem-6.25 {empty file name} { - list [catch {file rename "" ""} msg] $msg -} {1 {error renaming "": no such file or directory}} -test filesystem-6.26 {empty file name} { - list [catch {file rootname ""} msg] $msg -} {0 {}} -test filesystem-6.27 {empty file name} { - list [catch {file separator ""} msg] $msg -} {1 {Unrecognised path}} -test filesystem-6.28 {empty file name} { - list [catch {file size ""} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.29 {empty file name} { - list [catch {file split ""} msg] $msg -} {0 {}} -test filesystem-6.30 {empty file name} { - list [catch {file system ""} msg] $msg -} {1 {Unrecognised path}} -test filesystem-6.31 {empty file name} { - list [catch {file tail ""} msg] $msg -} {0 {}} -test filesystem-6.32 {empty file name} { - list [catch {file type ""} msg] $msg -} {1 {could not read "": no such file or directory}} -test filesystem-6.33 {empty file name} { - list [catch {file writable ""} msg] $msg -} {0 0} +test filesystem-6.1 {empty file name} -returnCodes error -body { + open "" +} -result {couldn't open "": no such file or directory} +test filesystem-6.2 {empty file name} -returnCodes error -body { + file stat "" arr +} -result {could not read "": no such file or directory} +test filesystem-6.3 {empty file name} -returnCodes error -body { + file atime "" +} -result {could not read "": no such file or directory} +test filesystem-6.4 {empty file name} -returnCodes error -body { + file attributes "" +} -result {could not read "": no such file or directory} +test filesystem-6.5 {empty file name} -returnCodes error -body { + file copy "" "" +} -result {error copying "": no such file or directory} +test filesystem-6.6 {empty file name} {file delete ""} {} +test filesystem-6.7 {empty file name} {file dirname ""} . +test filesystem-6.8 {empty file name} {file executable ""} 0 +test filesystem-6.9 {empty file name} {file exists ""} 0 +test filesystem-6.10 {empty file name} {file extension ""} {} +test filesystem-6.11 {empty file name} {file isdirectory ""} 0 +test filesystem-6.12 {empty file name} {file isfile ""} 0 +test filesystem-6.13 {empty file name} {file join ""} {} +test filesystem-6.14 {empty file name} -returnCodes error -body { + file link "" +} -result {could not read link "": no such file or directory} +test filesystem-6.15 {empty file name} -returnCodes error -body { + file lstat "" arr +} -result {could not read "": no such file or directory} +test filesystem-6.16 {empty file name} -returnCodes error -body { + file mtime "" +} -result {could not read "": no such file or directory} +test filesystem-6.17 {empty file name} -returnCodes error -body { + file mtime "" 0 +} -result {could not read "": no such file or directory} +test filesystem-6.18 {empty file name} -returnCodes error -body { + file mkdir "" +} -result {can't create directory "": no such file or directory} +test filesystem-6.19 {empty file name} {file nativename ""} {} +test filesystem-6.20 {empty file name} {file normalize ""} {} +test filesystem-6.21 {empty file name} {file owned ""} 0 +test filesystem-6.22 {empty file name} {file pathtype ""} relative +test filesystem-6.23 {empty file name} {file readable ""} 0 +test filesystem-6.24 {empty file name} -returnCodes error -body { + file readlink "" +} -result {could not readlink "": no such file or directory} +test filesystem-6.25 {empty file name} -returnCodes error -body { + file rename "" "" +} -result {error renaming "": no such file or directory} +test filesystem-6.26 {empty file name} {file rootname ""} {} +test filesystem-6.27 {empty file name} -returnCodes error -body { + file separator "" +} -result {Unrecognised path} +test filesystem-6.28 {empty file name} -returnCodes error -body { + file size "" +} -result {could not read "": no such file or directory} +test filesystem-6.29 {empty file name} {file split ""} {} +test filesystem-6.30 {empty file name} -returnCodes error -body { + file system "" +} -result {Unrecognised path} +test filesystem-6.31 {empty file name} {file tail ""} {} +test filesystem-6.32 {empty file name} -returnCodes error -body { + file type "" +} -result {could not read "": no such file or directory} +test filesystem-6.33 {empty file name} {file writable ""} 0 # Make sure the testfilesystem hasn't been registered. if {[testConstraint testfilesystem]} { while {![catch {testfilesystem 0}]} {} } -test filesystem-7.1 {load from vfs} {win testsimplefilesystem} { - # This may cause a crash on exit +test filesystem-7.1 {load from vfs} -setup { set dir [pwd] +} -constraints {win testsimplefilesystem} -body { + # This may cause a crash on exit cd [file dirname [info nameof]] set dde [lindex [glob *dde*[info sharedlib]] 0] testsimplefilesystem 1 # This loads dde via a complex copy-to-temp operation load simplefs:/$dde dde testsimplefilesystem 0 - cd $dir - set res "ok" + return ok # The real result of this test is what happens when Tcl exits. -} {ok} -test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} \ - {testsimplefilesystem} { +} -cleanup { + cd $dir +} -result ok +test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { # We created this file several tests ago. set origtime [file mtime gorp.file] set res [file exists gorp.file] - if {[catch { - testsimplefilesystem 1 - file delete -force theCopy - file copy simplefs:/gorp.file theCopy - testsimplefilesystem 0 - set newtime [file mtime theCopy] - file delete theCopy - } err]} { - lappend res $err - set newtime "" - } + testsimplefilesystem 1 + file delete -force theCopy + file copy simplefs:/gorp.file theCopy + testsimplefilesystem 0 + set newtime [file mtime theCopy] + lappend res [expr {$origtime == $newtime ? 1 : "$origtime != $newtime"}] +} -cleanup { + catch {file delete theCopy} cd $dir - lappend res [expr {$origtime == $newtime}] -} {1 1} -test filesystem-7.3 {glob in simplefs} testsimplefilesystem { +} -result {1 1} +test filesystem-7.3 {glob in simplefs} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { file mkdir simpledir close [open [file join simpledir simplefile] w] testsimplefilesystem 1 - set res [glob -nocomplain -dir simplefs:/simpledir *] - testsimplefilesystem 0 + glob -nocomplain -dir simplefs:/simpledir * +} -cleanup { + catch {testsimplefilesystem 0} file delete -force simpledir cd $dir - set res -} {simplefs:/simpledir/simplefile} -test filesystem-7.3.1 {glob in simplefs: no path/dir} testsimplefilesystem { +} -result {simplefs:/simpledir/simplefile} +test filesystem-7.3.1 {glob in simplefs: no path/dir} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { file mkdir simpledir close [open [file join simpledir simplefile] w] testsimplefilesystem 1 set res [glob -nocomplain simplefs:/simpledir/*] - eval lappend res [glob -nocomplain simplefs:/simpledir] - testsimplefilesystem 0 + lappend res {*}[glob -nocomplain simplefs:/simpledir] +} -cleanup { + catch {testsimplefilesystem 0} file delete -force simpledir cd $dir - set res -} {simplefs:/simpledir/simplefile simplefs:/simpledir} -test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} testsimplefilesystem { +} -result {simplefs:/simpledir/simplefile simplefs:/simpledir} +test filesystem-7.3.2 {glob in simplefs: no path/dir, no subdirectory} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { file mkdir simpledir close [open [file join simpledir simplefile] w] testsimplefilesystem 1 - set res [glob -nocomplain simplefs:/s*] - testsimplefilesystem 0 + glob -nocomplain simplefs:/s* +} -cleanup { + catch {testsimplefilesystem 0} file delete -force simpledir cd $dir - if {[llength $res] > 0} { - set res "ok" - } else { - set res "no files found with 'glob -nocomplain simplefs:/s*'" - } -} {ok} -test filesystem-7.3.3 {glob in simplefs: pattern is a volume} testsimplefilesystem { +} -match glob -result ?* +test filesystem-7.3.3 {glob in simplefs: pattern is a volume} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -constraints testsimplefilesystem -body { file mkdir simpledir close [open [file join simpledir simplefile] w] testsimplefilesystem 1 - set res [glob -nocomplain simplefs:/*] + glob -nocomplain simplefs:/* +} -cleanup { testsimplefilesystem 0 file delete -force simpledir cd $dir - if {[llength $res] > 0} { - set res "ok" - } else { - set res "no files found with 'glob -nocomplain simplefs:/*'" - } -} {ok} -test filesystem-7.4 {cross-filesystem file copy with -force} testsimplefilesystem { +} -match glob -result ?* +test filesystem-7.4 {cross-filesystem file copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] set fout [open [file join simplefile] w] puts -nonewline $fout "1234567890" close $fout testsimplefilesystem 1 +} -constraints testsimplefilesystem -body { # First copy should succeed set res [catch {file copy simplefs:/simplefile file2} err] lappend res $err @@ -809,19 +722,20 @@ test filesystem-7.4 {cross-filesystem file copy with -force} testsimplefilesyste lappend res [catch {file copy -force simplefs:/simplefile file2} err] lappend res $err lappend res [file exists file2] - testsimplefilesystem 0 +} -cleanup { + catch {testsimplefilesystem 0} file delete -force simplefile file delete -force file2 cd $dir - set res -} {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} -test filesystem-7.5 {cross-filesystem file copy with -force} {testsimplefilesystem unix} { +} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} +test filesystem-7.5 {cross-filesystem file copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] set fout [open [file join simplefile] w] puts -nonewline $fout "1234567890" close $fout testsimplefilesystem 1 +} -constraints {testsimplefilesystem unix} -body { # First copy should succeed set res [catch {file copy simplefs:/simplefile file2} err] lappend res $err @@ -833,13 +747,13 @@ test filesystem-7.5 {cross-filesystem file copy with -force} {testsimplefilesyst lappend res [catch {file copy -force simplefs:/simplefile file2} err] lappend res $err lappend res [file exists file2] +} -cleanup { testsimplefilesystem 0 file delete -force simplefile file delete -force file2 cd $dir - set res -} {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} -test filesystem-7.6 {cross-filesystem dir copy with -force} testsimplefilesystem { +} -result {0 10 1 {error copying "simplefs:/simplefile" to "file2": file already exists} 0 10 1} +test filesystem-7.6 {cross-filesystem dir copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] file delete -force simpledir @@ -849,6 +763,7 @@ test filesystem-7.6 {cross-filesystem dir copy with -force} testsimplefilesystem puts -nonewline $fout "1234567890" close $fout testsimplefilesystem 1 +} -constraints testsimplefilesystem -body { # First copy should succeed set res [catch {file copy simplefs:/simpledir dir2} err] lappend res $err @@ -860,13 +775,13 @@ test filesystem-7.6 {cross-filesystem dir copy with -force} testsimplefilesystem lappend res $err lappend res [file exists [file join dir2 simpledir]] \ [file exists [file join dir2 simpledir simplefile]] +} -cleanup { testsimplefilesystem 0 file delete -force simpledir file delete -force dir2 cd $dir - set res -} {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} -test filesystem-7.7 {cross-filesystem dir copy with -force} {testsimplefilesystem unix} { +} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} +test filesystem-7.7 {cross-filesystem dir copy with -force} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] file delete -force simpledir @@ -876,6 +791,7 @@ test filesystem-7.7 {cross-filesystem dir copy with -force} {testsimplefilesyste puts -nonewline $fout "1234567890" close $fout testsimplefilesystem 1 +} -constraints {testsimplefilesystem unix} -body { # First copy should succeed set res [catch {file copy simplefs:/simpledir dir2} err] lappend res $err @@ -883,40 +799,41 @@ test filesystem-7.7 {cross-filesystem dir copy with -force} {testsimplefilesyste lappend res [catch {file copy simplefs:/simpledir dir2} err] lappend res $err # Third copy should succeed (-force) - # I've noticed on some Unices that this only succeeds - # intermittently (some runs work, some fail). This needs - # examining further. + # I've noticed on some Unices that this only succeeds intermittently (some + # runs work, some fail). This needs examining further. lappend res [catch {file copy -force simplefs:/simpledir dir2} err] lappend res $err lappend res [file exists [file join dir2 simpledir]] \ [file exists [file join dir2 simpledir simplefile]] +} -cleanup { testsimplefilesystem 0 file delete -force simpledir file delete -force dir2 cd $dir - set res -} {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} +} -result {0 {} 1 {error copying "simplefs:/simpledir" to "dir2/simpledir": file already exists} 0 {} 1 1} removeFile gorp.file -test filesystem-7.8 {vfs cd} testsimplefilesystem { +test filesystem-7.8 {vfs cd} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] file delete -force simpledir file mkdir simpledir testsimplefilesystem 1 - # This can variously cause an infinite loop or simply have - # no effect at all (before certain bugs were fixed, of course). +} -constraints testsimplefilesystem -body { + # This can variously cause an infinite loop or simply have no effect at + # all (before certain bugs were fixed, of course). cd simplefs:/simpledir - set res [pwd] + pwd +} -cleanup { cd [tcltest::temporaryDirectory] testsimplefilesystem 0 file delete -force simpledir cd $dir - set res -} {simplefs:/simpledir} +} -result {simplefs:/simpledir} -test filesystem-8.1 {relative path objects and caching of pwd} { +test filesystem-8.1 {relative path objects and caching of pwd} -setup { set dir [pwd] cd [tcltest::temporaryDirectory] +} -body { makeDirectory abc makeDirectory def makeFile "contents" [file join abc foo] @@ -927,30 +844,31 @@ test filesystem-8.1 {relative path objects and caching of pwd} { lappend res [file exists $f] cd .. cd def - # If we haven't cleared the object's cwd cache, Tcl - # will think it still exists. + # If we haven't cleared the object's cwd cache, Tcl will think it still + # exists. lappend res [file exists $f] lappend res [file exists $f] +} -cleanup { removeFile [file join abc foo] removeDirectory abc removeDirectory def cd $dir - set res -} {1 1 0 0} -test filesystem-8.2 {relative path objects and use of pwd} { +} -result {1 1 0 0} +test filesystem-8.2 {relative path objects and use of pwd} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { set dir "abc" makeDirectory $dir makeFile "contents" [file join abc foo] cd $dir - set res [file exists [lindex [glob *] 0]] - cd .. + file exists [lindex [glob *] 0] +} -cleanup { + cd [tcltest::temporaryDirectory] removeFile [file join abc foo] removeDirectory abc cd $origdir - set res -} {1} +} -result 1 test filesystem-8.3 {path objects and empty string} { set anchor "" set dst foo @@ -966,7 +884,7 @@ proc TestFind1 {d f} { lappend res "is dir a dir? [file isdirectory $d]" set r2 [file exists [file join $d $f]] lappend res "[file join $d $f] found: $r2" - set res + return $res } proc TestFind2 {d f} { set r1 [file exists [file join $d $f]] @@ -974,67 +892,74 @@ proc TestFind2 {d f} { lappend res "is dir a dir? [file isdirectory [file join $d]]" set r2 [file exists [file join $d $f]] lappend res "[file join $d $f] found: $r2" - set res + return $res } -test filesystem-9.1 {path objects and join and object rep} { +test filesystem-9.1 {path objects and join and object rep} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir [file join a b c] - set res [TestFind1 a [file join b . c]] + TestFind1 a [file join b . c] +} -cleanup { file delete -force a cd $origdir - set res -} {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}} -test filesystem-9.2 {path objects and join and object rep} { +} -result {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}} +test filesystem-9.2 {path objects and join and object rep} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir [file join a b c] - set res [TestFind2 a [file join b . c]] + TestFind2 a [file join b . c] +} -cleanup { file delete -force a cd $origdir - set res -} {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}} -test filesystem-9.2.1 {path objects and join and object rep} { +} -result {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}} +test filesystem-9.2.1 {path objects and join and object rep} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir [file join a b c] - set res [TestFind2 a [file join b .]] + TestFind2 a [file join b .] +} -cleanup { file delete -force a cd $origdir - set res -} {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}} -test filesystem-9.3 {path objects and join and object rep} { +} -result {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}} +test filesystem-9.3 {path objects and join and object rep} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir [file join a b c] - set res [TestFind1 a [file join b .. b c]] + TestFind1 a [file join b .. b c] +} -cleanup { file delete -force a cd $origdir - set res -} {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}} -test filesystem-9.4 {path objects and join and object rep} { +} -result {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}} +test filesystem-9.4 {path objects and join and object rep} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir [file join a b c] - set res [TestFind2 a [file join b .. b c]] + TestFind2 a [file join b .. b c] +} -cleanup { file delete -force a cd $origdir - set res -} {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}} -test filesystem-9.5 {path objects and file tail and object rep} { +} -result {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}} +test filesystem-9.5 {path objects and file tail and object rep} -setup { set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir dgp close [open dgp/test w] foreach relative [glob -nocomplain [file join * test]] { set absolute [file join [pwd] $relative] set res [list [file tail $absolute] "test"] } + return $res +} -cleanup { file delete -force dgp cd $origdir - set res -} {test test} +} -result {test test} test filesystem-9.6 {path objects and file tail and object rep} win { set res {} set p "C:\\toto" @@ -1042,10 +967,11 @@ test filesystem-9.6 {path objects and file tail and object rep} win { file isdirectory $p lappend res [file join $p toto] } {C:/toto/toto C:/toto/toto} -test filesystem-9.7 {path objects and glob and file tail and tilde} { +test filesystem-9.7 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir tilde close [open tilde/~testNotExist w] cd tilde @@ -1054,15 +980,16 @@ test filesystem-9.7 {path objects and glob and file tail and tilde} { lappend res $file lappend res [file exists $file] [catch {file tail $file} r] $r lappend res [catch {file tail $file} r] $r - cd .. +} -cleanup { + cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir - set res -} {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} -test filesystem-9.8 {path objects and glob and file tail and tilde} { +} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir tilde close [open tilde/~testNotExist w] cd tilde @@ -1071,15 +998,16 @@ test filesystem-9.8 {path objects and glob and file tail and tilde} { lappend res $file1 $file2 lappend res [catch {file tail $file1} r] $r lappend res [catch {file tail $file2} r] $r - cd .. +} -cleanup { + cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir - set res -} {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} -test filesystem-9.9 {path objects and glob and file tail and tilde} { +} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] cd [tcltest::temporaryDirectory] +} -body { file mkdir tilde close [open tilde/~testNotExist w] cd tilde @@ -1088,14 +1016,20 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} { lappend res [catch {file exists $file1} r] $r lappend res [catch {file exists $file2} r] $r lappend res [string equal $file1 $file2] - cd .. +} -cleanup { + cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir - set res -} {0 0 0 0 1} +} -result {0 0 0 0 1} + +# ---------------------------------------------------------------------- cleanupTests unset -nocomplain drive } namespace delete ::tcl::test::fileSystem return + +# Local Variables: +# mode: tcl +# End: |