1#!./perl 2 3# Tests 53 onwards are intentionally not all-warnings-clean 4 5chdir 't' if -d 't'; 6require './test.pl'; 7use strict; 8 9plan(tests => 79); 10 11foreach(['0b1_0101', 0b101_01], 12 ['0b10_101', 0_2_5], 13 ['0b101_01', 2_1], 14 ['0b1010_1', 0x1_5], 15 ['b1_0101', 0b10101], 16 ['b10_101', 025], 17 ['b101_01', 21], 18 ['b1010_1', 0x15], 19 ['01_234', 0b10_1001_1100], 20 ['012_34', 01234], 21 ['0123_4', 668], 22 ['01234', 0x29c], 23 ['0x1_234', 0b10010_00110100], 24 ['0x12_34', 01_1064], 25 ['0x123_4', 4660], 26 ['0x1234', 0x12_34], 27 ['x1_234', 0b100100011010_0], 28 ['x12_34', 0_11064], 29 ['x123_4', 4660], 30 ['x1234', 0x_1234], 31 ['0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295], 32 ['037_777_777_777', 4294967295], 33 ['0xffff_ffff', 4294967295], 34 ['0b'.( '0'x10).'1_0101', 0b101_01], 35 ['0b'.( '0'x100).'1_0101', 0b101_01], 36 ['0b'.('0'x1000).'1_0101', 0b101_01], 37 # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) 38 ["b00b0101", 0], 39 ["bb0101", 0], 40 ["0bb0101", 0], 41 ["0x0x3A", 0], 42 ["0xx3A", 0], 43 ["x0x3A", 0], 44 ["xx3A", 0], 45 ["0x3A", 0x3A], 46 ["x3A", 0x3A], 47 ["0x0x4", 0], 48 ["0xx4", 0], 49 ["x0x4", 0], 50 ["xx4", 0], 51 ["0x4", 4], 52 ["x4", 4], 53 # Allow uppercase base markers (#76296) 54 ["0XCAFE", 0xCAFE], 55 ["XCAFE", 0xCAFE], 56 ["0B101001", 0b101001], 57 ["B101001", 0b101001], 58 # Additional syntax for octals 59 ["0o7_654_321", 2054353], 60 ["O4567", 0o4_567], 61 ) { 62 my ($string, $value) = @$_; 63 my $result = oct $string; 64 65 my $desc = ($^O ne 'VMS' || length $string <= 256) && "oct \"$string\""; 66 67 unless (cmp_ok($value, '==', $result, $desc)) { 68 my $format = ($string =~ /([bx])/i) ? "0\L$1%\U$1": '0%o'; 69 diag(sprintf "oct '%s' gives '%s' ($format), not %s ($format)", 70 $string, $result, $result, $value, $value); 71 } 72} 73 74foreach(['01_234', 0b_1001000110100], 75 ['012_34', 011064], 76 ['0123_4', 4660], 77 ['01234_', 0x1234], 78 ['0x_1234', 0b1001000110100], 79 ['0x1_234', 011064], 80 ['0x12_34', 4660], 81 ['0x1234_', 0x1234], 82 ['x_1234', 0b1001000110100], 83 ['x12_34', 011064], 84 ['x123_4', 4660], 85 ['x1234_', 0x1234], 86 ['0xff_ff_ff_ff', 4294967295], 87 [( '0'x10).'01234', 0x1234], 88 [( '0'x100).'01234', 0x1234], 89 [('0'x1000).'01234', 0x1234], 90 # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) 91 ["0x3A", 0x3A], 92 ["x3A", 0x3A], 93 ["0x4",4], 94 ["x4", 4], 95 # Allow uppercase base markers (#76296) 96 ["0XCAFE", 0xCAFE], 97 ["XCAFE", 0xCAFE], 98 ) { 99 my ($string, $value) = @$_; 100 my $result = hex $string; 101 102 my $desc = ($^O ne 'VMS' || length $string <= 256) && "hex \"$string\""; 103 104 unless (cmp_ok($value, '==', $result, $desc)) { 105 diag(sprintf "hex '%s' gives '%s' (0x%X), not %s (0x%X)", 106 $string, $result, $result, $value, $value); 107 } 108} 109 110 111$_ = "\0_7_7"; 112is(length, 5, 113 "length() correctly calculated string with nul character in octal"); 114is($_, "\0"."_"."7"."_"."7", "string concatenation with nul character"); 115chop, chop, chop, chop; 116is($_, "\0", "repeated chop() eliminated all but nul character"); 117if ($::IS_EBCDIC) { 118 is("\157_", "?_", 119 "question mark is 111 in 1047, 037, && POSIX-BC"); 120} 121else { 122 is("\077_", "?_", 123 "question mark is 077 in other than 1047, 037, && POSIX-BC"); 124} 125 126$_ = "\x_7_7"; 127is(length, 5, 128 "length() correctly calculated string with nul character in hex"); 129is($_, "\0"."_"."7"."_"."7", "string concatenation with nul character"); 130chop, chop, chop, chop; 131is($_, "\0", "repeated chop() eliminated all but nul character"); 132if ($::IS_EBCDIC) { 133 is("\x61_", "/_", 134 "/ is 97 in 1047, 037, && POSIX-BC"); 135} 136else { 137 is("\x2F_", "/_", 138 "/ is 79 in other than 1047, 037, && POSIX-BC"); 139} 140 141eval '$a = oct "10\x{100}"'; 142like($@, qr/Wide character/, "wide character - oct"); 143 144eval '$a = hex "ab\x{100}"'; 145like($@, qr/Wide character/, "wide character - hex"); 146