t/op/oct.t

   1 #!./perl
   2
   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);
  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";
  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 }
 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";
 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 }
 113
 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);
 147