-#!./perl
+#!./perl -Tw
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
- require Config; import Config;
}
-print "1..165\n";
+use Config;
+
+$Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define');
+
+my $test = 1;
+sub ok {
+ my($ok) = @_;
+
+ # You have to do it this way or VMS will get confused.
+ my $out = '';
+ $out = "not " unless $ok;
+ $out .= "ok $test\n";
+ print $out;
+
+ printf "# Failed test at line %d\n", (caller)[2] unless $ok;
+
+ $test++;
+ return $ok;
+}
+
+
+print "1..161\n";
+
+# Note: All test numbers in comments are off by 1 after the comment below..
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
$foo = pack($format,@ary);
@ary2 = unpack($format,$foo);
-print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
+ok($#ary == $#ary2);
$out1=join(':',@ary);
$out2=join(':',@ary2);
# Using long double NVs may introduce greater accuracy than wanted.
$out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
$out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/;
-if ($out1 eq $out2) {
- print "ok 2\n";
-} else {
- print "# out1: $out1\n";
- print "# out2: $out2\n";
- print "not ok 2\n";
-}
+ok($out1 eq $out2);
-print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
+ok($foo =~ /def/);
# How about counting bits?
-print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16
- ? "ok 4\n" : "not ok 4 $x\n";
+ok( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 );
-print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
- ? "ok 5\n" : "not ok 5 $x\n";
+ok( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 );
-print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
- ? "ok 6\n" : "not ok 6 $x\n";
+ok( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 );
my $sum = 129; # ASCII
-$sum = 103 if ($Config{ebcdic} eq 'define');
+$sum = 103 if $Is_EBCDIC;
-print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum
- ? "ok 7\n" : "not ok 7 $x\n";
+ok( ($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum );
-open(BIN, "./perl") || open(BIN, "./perl.exe")
+open(BIN, "./perl") || open(BIN, "./perl.exe") || open(BIN, $^X)
|| die "Can't open ../perl or ../perl.exe: $!\n";
sysread BIN, $foo, 8192;
close BIN;
$sum = unpack("%32b*", $foo);
$longway = unpack("b*", $foo);
-print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
+ok( $sum == $longway =~ tr/1/1/ );
-print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
- ? "ok 9\n" : "not ok 9 $x\n";
+ok( ($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF );
# check 'w'
-my $test=10;
-my @x = (5,130,256,560,32000,3097152,268435455,1073741844,
+my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33,
'4503599627365785','23728385234614992549757750638446');
my $x = pack('w*', @x);
-my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
+my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A08080800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
-print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
+if ($x eq $y) {
+ print "ok $test\n";
+} else {
+ printf "not ok $test # %s\n", unpack 'H*', $x;
+}
+$test++;
@y = unpack('w*', $y);
my $a;
print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
}
+# XXX All test numbers in comments are off by 1 after this point.
+
@y = unpack('w2', $x);
print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
-print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
+print $y[1] == 130 ? "ok $test\n" : "not ok $test # $y[1]\n"; $test++;
# test exeptions
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
# 31..36: test the pack lengths of s S i I l L
print "not " unless length(pack("s", 0)) == 2;
print "ok ", $test++, "\n";
-
+
print "not " unless length(pack("S", 0)) == 2;
print "ok ", $test++, "\n";
-
+
print "not " unless length(pack("i", 0)) >= 4;
print "ok ", $test++, "\n";
# binary values of the uuencoded version would not be portable between
# character sets. Uuencoding is meant for encoding binary data, not
# text data.
-
+
$in = pack 'C*', 0 .. 255;
# just to be anal, we do some random tr/`/ /
$uu = <<'EOUU';
M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F
-&8%P:
+&8%P:
EOUU
print "not " unless unpack('u', $uu) eq $in;
# 144..152: /
+# Using Test considered bad plan in op/*.t ?
+
+sub report {
+ my ($pass, $test, $err, $wrong) = @_;
+ if ($pass) {
+ print "ok $test\n"
+ } else {
+ if ($err) {
+ chomp $err;
+ print "not ok $test # \$\@ = $err\n";
+ } else {
+ $wrong =~ s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge;
+ print "not ok $test # got $wrong\n";
+ }
+ }
+}
+
my $z;
eval { ($x) = unpack '/a*','hello' };
print 'not ' unless $@; print "ok $test\n"; $test++;
eval { ($x) = pack '/a*','hello' };
print 'not ' unless $@; print "ok $test\n"; $test++;
$z = pack 'n/a* N/Z* w/A*','string','hi there ','etc';
-print 'not ' unless $z eq "\000\006string\0\0\0\012hi there \000\003etc";
-print "ok $test\n"; $test++;
+my $expect = "\000\006string\0\0\0\012hi there \000\003etc";
+report ($z eq $expect, $test++, '', $z);
eval { ($x) = unpack 'a/a*/a*', '212ab345678901234567' };
print $@ eq '' && $x eq 'ab3456789012' ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
eval { ($x) = unpack 'a/a*/b*', '212ab' };
my $expected_x = '100001100100';
-if ($Config{ebcdic} eq 'define') { $expected_x = '100000010100'; }
+if ($Is_EBCDIC) { $expected_x = '100000010100'; }
print $@ eq '' && $x eq $expected_x ? "ok $test\n" : "#$x,$@\nnot ok $test\n";
$test++;
n/a* # Count as network short
w/A* # Count a BER integer
EOP
-print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+$expect = "\000\006string\003etc";
+report ($z eq $expect, $test++, '', $z);
-# 157..169: ???
-
-print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000);
+print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000);
print "ok $test\n"; $test++;
-print 'not ' unless "1.20.300.4000" eq
- sprintf "%vd", pack(" U*",1,20,300,4000);
+print 'not ' unless "1.20.300.4000" eq
+ sprintf "%vd", pack(" U*",1,20,300,4000);
print "ok $test\n"; $test++;
-print 'not ' unless v1.20.300.4000 ne
- sprintf "%vd", pack("C0U*",1,20,300,4000);
+print 'not ' unless v1.20.300.4000 ne
+ sprintf "%vd", pack("C0U*",1,20,300,4000);
print "ok $test\n"; $test++;
-# 160: unpack("C") and ord() equivalence for Unicode
-
-print "not " unless unpack("C", chr(0x100)) eq ord(chr(0x100)) &&
- ord(chr(0x100)) == 0x100;
+# 160
+print "not " unless join(" ", unpack("C*", chr(0x1e2)))
+ eq ((ord(A) == 193) ? "156 67" : "199 162");
print "ok $test\n"; $test++;
-
-# 161: use bytes + unpack C == UTF-8 unraveling
-
-{
- use bytes;
- my @bytes = unpack("C*", pack("U", 0x100));
- print "not " unless "@bytes" eq "196 128";
- print "ok $test\n"; $test++;
-}
-
-# 162: pack C > 255
-
-print "not " unless ord(pack("C", 0x100)) == 0x100;
-print "ok $test\n"; $test++;
-
-# 163: pack C > 255 + use bytes == wraparound
-
-{
- use bytes;
-
- print "not " unless ord(pack("C", 0x100 + 0xab)) == 0xab;
- print "ok $test\n"; $test++;
-}
-
-# 164: pack C and pack U equivalence
-
-print "not " unless pack("C", 0x100) eq pack("U", 0x100) &&
- chr(0x100) eq pack("U", 0x100);
-print "ok $test\n"; $test++;
-
-# 165: unpack C and unpack U equivalence
-
-print "not " unless "@{[unpack('C*', chr(0x100) . chr(0x200))]}" eq
- "@{[unpack('U*', chr(0x100) . chr(0x200))]}" &&
- "@{[unpack('U*', chr(0x100) . chr(0x200))]}" eq "256 512";
-print "ok $test\n"; $test++;
-
projects / p5sagit/p5-mst-13.2.git / blobdiff