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.

diff --git a/t/op/oct.t b/t/op/oct.t
index d71bbd1..f037db3 100644 (file)
--- a/t/op/oct.t
+++ b/t/op/oct.t
@@ -3,81 +3,106 @@
 # tests 51 onwards aren't all warnings clean. (intentionally)
 
 require './test.pl';
+use strict;
 
 plan(tests => 77);
 
-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'";
-  }
-  my $desc = ($^O ne 'VMS' || length $string <= 256) && "$act \"$string\"";
-
-  unless (cmp_ok($value, '==', $result, $desc)) {
-    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;
+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);
     }
-    diag("$act \"$string\" gives \"$result\" ($resstr), not $value ($valstr)\n");
-  }
 }
 
-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";
 is(length, 5);
@@ -105,50 +130,8 @@ else {
     is("\x2F_", "/_");
 }
 
-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}"';
 like($@, qr/Wide character/);
 
 eval '$a = hex "ab\x{100}"';
 like($@, qr/Wide character/);
-
-# 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);