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