Commit | Line | Data |
---|---|---|
8d063cd8 LW |
1 | #!./perl |
2 | ||
53305cf1 NC |
3 | # tests 51 onwards aren't all warnings clean. (intentionally) |
4 | ||
5 | print "1..69\n"; | |
6 | ||
7 | my $test = 1; | |
8 | ||
9 | sub test ($$$) { | |
10 | my ($act, $string, $value) = @_; | |
11 | my $result; | |
12 | if ($act eq 'oct') { | |
13 | $result = oct $string; | |
14 | } elsif ($act eq 'hex') { | |
15 | $result = hex $string; | |
16 | } else { | |
17 | die "Unknown action 'act'"; | |
18 | } | |
19 | if ($value == $result) { | |
20 | if ($^O eq 'VMS' && length $string > 256) { | |
21 | $string = ''; | |
22 | } else { | |
23 | $string = "\"$string\""; | |
24 | } | |
25 | print "ok $test # $act $string\n"; | |
26 | } else { | |
27 | my ($valstr, $resstr); | |
28 | if ($act eq 'hex' or $string =~ /x/) { | |
29 | $valstr = sprintf "0x%X", $value; | |
30 | $resstr = sprintf "0x%X", $result; | |
31 | } elsif ($string =~ /b/) { | |
32 | $valstr = sprintf "0b%b", $value; | |
33 | $resstr = sprintf "0b%b", $result; | |
34 | } else { | |
35 | $valstr = sprintf "0%o", $value; | |
36 | $resstr = sprintf "0%o", $result; | |
37 | } | |
38 | print "not ok $test # $act \"$string\" gives \"$result\" ($resstr), not $value ($valstr)\n"; | |
39 | } | |
40 | $test++; | |
41 | } | |
42 | ||
43 | test ('oct', '0b1_0101', 0b101_01); | |
44 | test ('oct', '0b10_101', 0_2_5); | |
45 | test ('oct', '0b101_01', 2_1); | |
46 | test ('oct', '0b1010_1', 0x1_5); | |
47 | ||
48 | test ('oct', 'b1_0101', 0b10101); | |
49 | test ('oct', 'b10_101', 025); | |
50 | test ('oct', 'b101_01', 21); | |
51 | test ('oct', 'b1010_1', 0x15); | |
52 | ||
53 | test ('oct', '01_234', 0b10_1001_1100); | |
54 | test ('oct', '012_34', 01234); | |
55 | test ('oct', '0123_4', 668); | |
56 | test ('oct', '01234', 0x29c); | |
57 | ||
58 | test ('oct', '0x1_234', 0b10010_00110100); | |
59 | test ('oct', '0x12_34', 01_1064); | |
60 | test ('oct', '0x123_4', 4660); | |
61 | test ('oct', '0x1234', 0x12_34); | |
62 | ||
63 | test ('oct', 'x1_234', 0b100100011010_0); | |
64 | test ('oct', 'x12_34', 0_11064); | |
65 | test ('oct', 'x123_4', 4660); | |
66 | test ('oct', 'x1234', 0x_1234); | |
67 | ||
68 | test ('hex', '01_234', 0b_1001000110100); | |
69 | test ('hex', '012_34', 011064); | |
70 | test ('hex', '0123_4', 4660); | |
71 | test ('hex', '01234_', 0x1234); | |
72 | ||
73 | test ('hex', '0x_1234', 0b1001000110100); | |
74 | test ('hex', '0x1_234', 011064); | |
75 | test ('hex', '0x12_34', 4660); | |
76 | test ('hex', '0x1234_', 0x1234); | |
77 | ||
78 | test ('hex', 'x_1234', 0b1001000110100); | |
79 | test ('hex', 'x12_34', 011064); | |
80 | test ('hex', 'x123_4', 4660); | |
81 | test ('hex', 'x1234_', 0x1234); | |
82 | ||
83 | test ('oct', '0b1111_1111_1111_1111_1111_1111_1111_1111', 4294967295); | |
84 | test ('oct', '037_777_777_777', 4294967295); | |
85 | test ('oct', '0xffff_ffff', 4294967295); | |
86 | test ('hex', '0xff_ff_ff_ff', 4294967295); | |
b21ed0a9 GS |
87 | |
88 | $_ = "\0_7_7"; | |
89 | print length eq 5 ? "ok" : "not ok", " 37\n"; | |
90 | print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 38\n"; | |
91 | chop, chop, chop, chop; | |
92 | print $_ eq "\0" ? "ok" : "not ok", " 39\n"; | |
2f2d036a PP |
93 | if (ord("\t") != 9) { |
94 | # question mark is 111 in 1047, 037, && POSIX-BC | |
95 | print "\157_" eq "?_" ? "ok" : "not ok", " 40\n"; | |
96 | } | |
97 | else { | |
98 | print "\077_" eq "?_" ? "ok" : "not ok", " 40\n"; | |
99 | } | |
b21ed0a9 GS |
100 | |
101 | $_ = "\x_7_7"; | |
102 | print length eq 5 ? "ok" : "not ok", " 41\n"; | |
103 | print $_ eq "\0"."_"."7"."_"."7" ? "ok" : "not ok", " 42\n"; | |
104 | chop, chop, chop, chop; | |
105 | print $_ eq "\0" ? "ok" : "not ok", " 43\n"; | |
2f2d036a PP |
106 | if (ord("\t") != 9) { |
107 | # / is 97 in 1047, 037, && POSIX-BC | |
108 | print "\x61_" eq "/_" ? "ok" : "not ok", " 44\n"; | |
109 | } | |
110 | else { | |
111 | print "\x2F_" eq "/_" ? "ok" : "not ok", " 44\n"; | |
112 | } | |
93312bbf | 113 | |
53305cf1 NC |
114 | $test = 45; |
115 | test ('oct', '0b'.( '0'x10).'1_0101', 0b101_01); | |
116 | test ('oct', '0b'.( '0'x100).'1_0101', 0b101_01); | |
117 | test ('oct', '0b'.('0'x1000).'1_0101', 0b101_01); | |
118 | ||
119 | test ('hex', ( '0'x10).'01234', 0x1234); | |
120 | test ('hex', ( '0'x100).'01234', 0x1234); | |
121 | test ('hex', ('0'x1000).'01234', 0x1234); | |
122 | ||
123 | # Things that perl 5.6.1 and 5.7.2 did wrong (plus some they got right) | |
124 | test ('oct', "b00b0101", 0); | |
125 | test ('oct', "bb0101", 0); | |
126 | test ('oct', "0bb0101", 0); | |
127 | ||
128 | test ('oct', "0x0x3A", 0); | |
129 | test ('oct', "0xx3A", 0); | |
130 | test ('oct', "x0x3A", 0); | |
131 | test ('oct', "xx3A", 0); | |
132 | test ('oct', "0x3A", 0x3A); | |
133 | test ('oct', "x3A", 0x3A); | |
134 | ||
135 | test ('oct', "0x0x4", 0); | |
136 | test ('oct', "0xx4", 0); | |
137 | test ('oct', "x0x4", 0); | |
138 | test ('oct', "xx4", 0); | |
139 | test ('oct', "0x4", 4); | |
140 | test ('oct', "x4", 4); | |
141 | ||
142 | test ('hex', "0x3A", 0x3A); | |
143 | test ('hex', "x3A", 0x3A); | |
144 | ||
145 | test ('hex', "0x4", 4); | |
146 | test ('hex', "x4", 4); | |
93312bbf | 147 |