In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0d160371061f6cce0d19afa2e5e94dc360c63a4d?hp=f87e8a9a055d5f9292e5e84134cb513786dad1aa>
- Log ----------------------------------------------------------------- commit 0d160371061f6cce0d19afa2e5e94dc360c63a4d Author: Nicholas Clark <[email protected]> Date: Tue Mar 15 15:14:28 2011 +0000 Convert t/op/oct.t's main tests to data structure and loops. This will make it easier to test that expected warnings are generated. However, parts of the existing perl code would generate warnings if warnings were enabled, as it seems that the source code literals used are also intended as tests for edge cases in the parser. M t/op/oct.t commit c91473c9ef91bf50f2b5337c625bc6b737985bb8 Author: Nicholas Clark <[email protected]> Date: Tue Mar 15 14:23:16 2011 +0000 Convert t/op/oct.t to using test.pl for comparisons and diagnostics. This eliminates the hard-coded test numbers, which will allow the tests to be re-ordered. M t/op/oct.t ----------------------------------------------------------------------- Summary of changes: t/op/oct.t | 242 +++++++++++++++++++++++++++--------------------------------- 1 files changed, 109 insertions(+), 133 deletions(-) diff --git a/t/op/oct.t b/t/op/oct.t index dcd2256..f037db3 100644 --- a/t/op/oct.t +++ b/t/op/oct.t @@ -2,160 +2,136 @@ # tests 51 onwards aren't all warnings clean. (intentionally) -print "1..77\n"; - -my $test = 1; - -sub test ($$$) { - my ($act, $string, $value) = @_; - my $result; - if ($act eq 'oct') { - $result = oct $string; - } elsif ($act eq 'hex') { - $result = hex $string; - } else { - die "Unknown action 'act'"; - } - if ($value == $result) { - if ($^O eq 'VMS' && length $string > 256) { - $string = ''; - } else { - $string = "\"$string\""; - } - print "ok $test # $act $string\n"; - } else { - my ($valstr, $resstr); - if ($act eq 'hex' or $string =~ /x/i) { - $valstr = sprintf "0x%X", $value; - $resstr = sprintf "0x%X", $result; - } elsif ($string =~ /b/i) { - $valstr = sprintf "0b%b", $value; - $resstr = sprintf "0b%b", $result; - } else { - $valstr = sprintf "0%o", $value; - $resstr = sprintf "0%o", $result; +require './test.pl'; +use strict; + +plan(tests => 77); + +foreach(['0b1_0101', 0b101_01], + ['0b10_101', 0_2_5], + ['0b101_01', 2_1], + ['0b1010_1', 0x1_5], + ['b1_0101', 0b10101], + ['b10_101', 025], + ['b101_01', 21], + ['b1010_1', 0x15], + ['01_234', 0b10_1001_1100], + ['012_34', 01234], + ['0123_4', 668], + ['01234', 0x29c], + ['0x1_234', 0b10010_00110100], + ['0x12_34', 01_1064], + ['0x123_4', 4660], + ['0x1234', 0x12_34], + ['x1_234', 0b100100011010_0], + ['x12_34', 0_11064], + ['x123_4', 4660], + ['x1234', 0x_1234], + ['0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295], + ['037_777_777_777', 4294967295], + ['0xffff_ffff', 4294967295], + ['0b'.( '0'x10).'1_0101', 0b101_01], + ['0b'.( '0'x100).'1_0101', 0b101_01], + ['0b'.('0'x1000).'1_0101', 0b101_01], + # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) + ["b00b0101", 0], + ["bb0101", 0], + ["0bb0101", 0], + ["0x0x3A", 0], + ["0xx3A", 0], + ["x0x3A", 0], + ["xx3A", 0], + ["0x3A", 0x3A], + ["x3A", 0x3A], + ["0x0x4", 0], + ["0xx4", 0], + ["x0x4", 0], + ["xx4", 0], + ["0x4", 4], + ["x4", 4], + # Allow uppercase base markers (#76296) + ["0XCAFE", 0xCAFE], + ["XCAFE", 0xCAFE], + ["0B101001", 0b101001], + ["B101001", 0b101001], + ) { + my ($string, $value) = @$_; + my $result = oct $string; + + my $desc = ($^O ne 'VMS' || length $string <= 256) && "oct \"$string\""; + + unless (cmp_ok($value, '==', $result, $desc)) { + my $format = ($string =~ /([bx])/i) ? "0\L$1%\U$1": '0%o'; + diag(sprintf "oct '%s' gives '%s' ($format), not %s ($format)", + $string, $result, $result, $value, $value); } - print "not ok $test # $act \"$string\" gives \"$result\" ($resstr), not $value ($valstr)\n"; - } - $test++; } -test ('oct', '0b1_0101', 0b101_01); -test ('oct', '0b10_101', 0_2_5); -test ('oct', '0b101_01', 2_1); -test ('oct', '0b1010_1', 0x1_5); - -test ('oct', 'b1_0101', 0b10101); -test ('oct', 'b10_101', 025); -test ('oct', 'b101_01', 21); -test ('oct', 'b1010_1', 0x15); - -test ('oct', '01_234', 0b10_1001_1100); -test ('oct', '012_34', 01234); -test ('oct', '0123_4', 668); -test ('oct', '01234', 0x29c); - -test ('oct', '0x1_234', 0b10010_00110100); -test ('oct', '0x12_34', 01_1064); -test ('oct', '0x123_4', 4660); -test ('oct', '0x1234', 0x12_34); - -test ('oct', 'x1_234', 0b100100011010_0); -test ('oct', 'x12_34', 0_11064); -test ('oct', 'x123_4', 4660); -test ('oct', 'x1234', 0x_1234); - -test ('hex', '01_234', 0b_1001000110100); -test ('hex', '012_34', 011064); -test ('hex', '0123_4', 4660); -test ('hex', '01234_', 0x1234); - -test ('hex', '0x_1234', 0b1001000110100); -test ('hex', '0x1_234', 011064); -test ('hex', '0x12_34', 4660); -test ('hex', '0x1234_', 0x1234); - -test ('hex', 'x_1234', 0b1001000110100); -test ('hex', 'x12_34', 011064); -test ('hex', 'x123_4', 4660); -test ('hex', 'x1234_', 0x1234); +foreach(['01_234', 0b_1001000110100], + ['012_34', 011064], + ['0123_4', 4660], + ['01234_', 0x1234], + ['0x_1234', 0b1001000110100], + ['0x1_234', 011064], + ['0x12_34', 4660], + ['0x1234_', 0x1234], + ['x_1234', 0b1001000110100], + ['x12_34', 011064], + ['x123_4', 4660], + ['x1234_', 0x1234], + ['0xff_ff_ff_ff', 4294967295], + [( '0'x10).'01234', 0x1234], + [( '0'x100).'01234', 0x1234], + [('0'x1000).'01234', 0x1234], + # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) + ["0x3A", 0x3A], + ["x3A", 0x3A], + ["0x4",4], + ["x4", 4], + # Allow uppercase base markers (#76296) + ["0XCAFE", 0xCAFE], + ["XCAFE", 0xCAFE], + ) { + my ($string, $value) = @$_; + my $result = hex $string; + + my $desc = ($^O ne 'VMS' || length $string <= 256) && "hex \"$string\""; + + unless (cmp_ok($value, '==', $result, $desc)) { + diag(sprintf "hex '%s' gives '%s' (0x%X), not %s (0x%X)", + $string, $result, $result, $value, $value); + } +} -test ('oct', '0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295); -test ('oct', '037_777_777_777', 4294967295); -test ('oct', '0xffff_ffff', 4294967295); -test ('hex', '0xff_ff_ff_ff', 4294967295); $_ = "\0_7_7"; -print length eq 5 ? "ok" : "not ok", " 37\n"; -print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; +is(length, 5); +is($_, "\0"."_"."7"."_"."7"); chop, chop, chop, chop; -print $_ eq "\0" ? "ok" : "not ok", " 39\n"; +is($_, "\0"); if (ord("\t") != 9) { # question mark is 111 in 1047, 037, && POSIX-BC - print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; + is("\157_", "?_"); } else { - print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; + is("\077_", "?_"); } $_ = "\x_7_7"; -print length eq 5 ? "ok" : "not ok", " 41\n"; -print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; +is(length, 5); +is($_, "\0"."_"."7"."_"."7"); chop, chop, chop, chop; -print $_ eq "\0" ? "ok" : "not ok", " 43\n"; +is($_, "\0"); if (ord("\t") != 9) { # / is 97 in 1047, 037, && POSIX-BC - print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; + is("\x61_", "/_"); } else { - print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; + is("\x2F_", "/_"); } -$test = 45; -test ('oct', '0b'.( '0'x10).'1_0101', 0b101_01); -test ('oct', '0b'.( '0'x100).'1_0101', 0b101_01); -test ('oct', '0b'.('0'x1000).'1_0101', 0b101_01); - -test ('hex', ( '0'x10).'01234', 0x1234); -test ('hex', ( '0'x100).'01234', 0x1234); -test ('hex', ('0'x1000).'01234', 0x1234); - -# Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) -test ('oct', "b00b0101", 0); -test ('oct', "bb0101", 0); -test ('oct', "0bb0101", 0); - -test ('oct', "0x0x3A", 0); -test ('oct', "0xx3A", 0); -test ('oct', "x0x3A", 0); -test ('oct', "xx3A", 0); -test ('oct', "0x3A", 0x3A); -test ('oct', "x3A", 0x3A); - -test ('oct', "0x0x4", 0); -test ('oct', "0xx4", 0); -test ('oct', "x0x4", 0); -test ('oct', "xx4", 0); -test ('oct', "0x4", 4); -test ('oct', "x4", 4); - -test ('hex', "0x3A", 0x3A); -test ('hex', "x3A", 0x3A); - -test ('hex', "0x4", 4); -test ('hex', "x4", 4); - eval '$a = oct "10\x{100}"'; -print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++; +like($@, qr/Wide character/); eval '$a = hex "ab\x{100}"'; -print $@ =~ /Wide character/ ? "ok $test\n" : "not ok $test\n"; $test++; - -# Allow uppercase base markers (#76296) - -test ('hex', "0XCAFE", 0xCAFE); -test ('hex', "XCAFE", 0xCAFE); -test ('oct', "0XCAFE", 0xCAFE); -test ('oct', "XCAFE", 0xCAFE); -test ('oct', "0B101001", 0b101001); -test ('oct', "B101001", 0b101001); +like($@, qr/Wide character/); -- Perl5 Master Repository
