oct and hex in glorious 64 bit (with less bugs) (was Re: hex and oct again (was Re: FreeBSD MD5 crypt? Re: crypt/hex/oct and Unicode?))

Message-ID: <20010904224250.P25120@plum.flirble.org>

p4raw-id: //depot/perl@11874

2 files changed, 153 insertions, 59 deletions

diff --git a/t/op/64bitint.t b/t/op/64bitint.t
index 5ea1f2dbdc..494f9fd14f 100644
--- a/t/op/64bitint.t
+++ b/t/op/64bitint.t
@@ -17,7 +17,7 @@ BEGIN {
 use warnings;
 no warnings qw(overflow portable);
 
-print "1..63\n";
+print "1..67\n";
 
 # as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last
 # digit of 16**n will always be six. Hence 16**n - 1 will always end in 5.
@@ -379,4 +379,39 @@ if ($q == -9223372036854775806) {
   print "not ok 63 # 0x8000000000000000 % -9223372036854775807 => $q\n";
 }
 
+{
+  use integer;
+  $q = hex "0x123456789abcdef0";
+  if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) {
+    print "ok 64\n";
+  } else {
+    printf "not ok 64 # hex \"0x123456789abcdef0\" = $q (%X)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+
+  $q = oct "0x123456789abcdef0";
+  if ($q == 0x123456789abcdef0 and $q != 0x123456789abcdef1) {
+    print "ok 65\n";
+  } else {
+    printf "not ok 65 # oct \"0x123456789abcdef0\" = $q (%X)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+
+  $q = oct "765432176543217654321";
+  if ($q == 0765432176543217654321 and $q != 0765432176543217654322) {
+    print "ok 66\n";
+  } else {
+    printf "not ok 66 # oct \"765432176543217654321\" = $q (%o)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+
+  $q = oct "0b0101010101010101010101010101010101010101010101010101010101010101";
+  if ($q == 0x5555555555555555 and $q != 0x5555555555555556) {
+    print "ok 67\n";
+  } else {
+    printf "not ok 67 # oct \"0b0101010101010101010101010101010101010101010101010101010101010101\" = $q (%b)\n", $q;
+    print "# Should not be floating point\n" if $q =~ tr/e.//;
+  }
+}
+
 # eof
diff --git a/t/op/oct.t b/t/op/oct.t
index fe155d3a2d..06bcf3e402 100755
--- a/t/op/oct.t
+++ b/t/op/oct.t
@@ -1,56 +1,89 @@
 #!./perl
 
-print "1..50\n";
-
-print +(oct('0b1_0101') ==        0b101_01) ? "ok" : "not ok", " 1\n";
-print +(oct('0b10_101') ==           0_2_5) ? "ok" : "not ok", " 2\n";
-print +(oct('0b101_01') ==             2_1) ? "ok" : "not ok", " 3\n";
-print +(oct('0b1010_1') ==           0x1_5) ? "ok" : "not ok", " 4\n";
-
-print +(oct('b1_0101') ==          0b10101) ? "ok" : "not ok", " 5\n";
-print +(oct('b10_101') ==              025) ? "ok" : "not ok", " 6\n";
-print +(oct('b101_01') ==               21) ? "ok" : "not ok", " 7\n";
-print +(oct('b1010_1') ==             0x15) ? "ok" : "not ok", " 8\n";
-
-print +(oct('01_234')  ==   0b10_1001_1100) ? "ok" : "not ok", " 9\n";
-print +(oct('012_34')  ==            01234) ? "ok" : "not ok", " 10\n";
-print +(oct('0123_4')  ==              668) ? "ok" : "not ok", " 11\n";
-print +(oct('01234')   ==            0x29c) ? "ok" : "not ok", " 12\n";
-
-print +(oct('0x1_234') == 0b10010_00110100) ? "ok" : "not ok", " 13\n";
-print +(oct('0x12_34') ==          01_1064) ? "ok" : "not ok", " 14\n";
-print +(oct('0x123_4') ==             4660) ? "ok" : "not ok", " 15\n";
-print +(oct('0x1234')  ==          0x12_34) ? "ok" : "not ok", " 16\n";
-
-print +(oct('x1_234')  == 0b100100011010_0) ? "ok" : "not ok", " 17\n";
-print +(oct('x12_34')  ==          0_11064) ? "ok" : "not ok", " 18\n";
-print +(oct('x123_4')  ==             4660) ? "ok" : "not ok", " 19\n";
-print +(oct('x1234')   ==          0x_1234) ? "ok" : "not ok", " 20\n";
-
-print +(hex('01_234')  == 0b_1001000110100) ? "ok" : "not ok", " 21\n";
-print +(hex('012_34')  ==           011064) ? "ok" : "not ok", " 22\n";
-print +(hex('0123_4')  ==             4660) ? "ok" : "not ok", " 23\n";
-print +(hex('01234_')  ==           0x1234) ? "ok" : "not ok", " 24\n";
-
-print +(hex('0x_1234') ==  0b1001000110100) ? "ok" : "not ok", " 25\n";
-print +(hex('0x1_234') ==           011064) ? "ok" : "not ok", " 26\n";
-print +(hex('0x12_34') ==             4660) ? "ok" : "not ok", " 27\n";
-print +(hex('0x1234_') ==           0x1234) ? "ok" : "not ok", " 28\n";
-
-print +(hex('x_1234')  ==  0b1001000110100) ? "ok" : "not ok", " 29\n";
-print +(hex('x12_34')  ==           011064) ? "ok" : "not ok", " 30\n";
-print +(hex('x123_4')  ==             4660) ? "ok" : "not ok", " 31\n";
-print +(hex('x1234_')  ==           0x1234) ? "ok" : "not ok", " 32\n";
-
-print +(oct('0b1111_1111_1111_1111_1111_1111_1111_1111') == 4294967295) ?
-    "ok" : "not ok", " 33\n";
-print +(oct('037_777_777_777')                       == 4294967295) ?
-    "ok" : "not ok", " 34\n";
-print +(oct('0xffff_ffff')                         == 4294967295) ?
-    "ok" : "not ok", " 35\n";
-
-print +(hex('0xff_ff_ff_ff')                         == 4294967295) ?
-    "ok" : "not ok", " 36\n";
+# tests 51 onwards aren't all warnings clean. (intentionally)
+
+print "1..69\n";
+
+my $test = 1;
+
+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'";
+  }
+  if ($value == $result) {
+    if ($^O eq 'VMS' && length $string > 256) {
+      $string = '';
+    } else {
+      $string = "\"$string\"";
+    }
+    print "ok $test # $act $string\n";
+  } else {
+    my ($valstr, $resstr);
+    if ($act eq 'hex' or $string =~ /x/) {
+      $valstr = sprintf "0x%X", $value;
+      $resstr = sprintf "0x%X", $result;
+    } elsif ($string =~ /b/) {
+      $valstr = sprintf "0b%b", $value;
+      $resstr = sprintf "0b%b", $result;
+    } else {
+      $valstr = sprintf "0%o", $value;
+      $resstr = sprintf "0%o", $result;
+    }
+    print "not ok $test # $act \"$string\" gives \"$result\" ($resstr), not $value ($valstr)\n";
+  }
+  $test++;
+}
+
+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);
+
+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";
 print length eq 5                      ? "ok" : "not ok", " 37\n";
@@ -78,11 +111,37 @@ else {
     print "\x2F_" eq "/_"                  ? "ok" : "not ok", " 44\n";
 }
 
-print +(oct('0b'.(  '0'x10).'1_0101') ==  0b101_01) ? "ok" : "not ok", " 45\n";
-print +(oct('0b'.( '0'x100).'1_0101') ==  0b101_01) ? "ok" : "not ok", " 46\n";
-print +(oct('0b'.('0'x1000).'1_0101') ==  0b101_01) ? "ok" : "not ok", " 47\n";
-
-print +(hex((  '0'x10).'01234') ==  0x1234) ? "ok" : "not ok", " 48\n";
-print +(hex(( '0'x100).'01234') ==  0x1234) ? "ok" : "not ok", " 49\n";
-print +(hex(('0'x1000).'01234') ==  0x1234) ? "ok" : "not ok", " 50\n";
+$test = 45;
+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);