[PATCH lib/overload.t] TODO tests for bug #24313.

From: Abigail <abigail@abigail.nl>
Date: Mon, 27 Oct 2003 13:05:37 +0100
Message-ID: <20031027120536.GA24608@abigail.nl>

Subject: [PATCH bleadperl] [perl #24313] (was Re: [PATCH lib/overload.t] TODO tests for bug #24313.)
From: Rick Delaney <rick@bort.ca>
Date: Mon, 27 Oct 2003 12:17:49 -0500
Message-ID: <20031027121749.E2233@biff.bort.ca>

p4raw-id: //depot/perl@21566

2 files changed, 31 insertions, 9 deletions

diff --git a/lib/overload.t b/lib/overload.t
index 3490b5bf6a..669b4bc78a 100644
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,10 +48,13 @@ print "1..",&last,"\n";
 sub test {
   $test++; 
   if (@_ > 1) {
+    my $comment = "";
+    $comment = " # " . $_ [2] if @_ > 2;
     if ($_[0] eq $_[1]) {
-      print "ok $test\n";
+      print "ok $test$comment\n";
     } else {
-      print "not ok $test: '$_[0]' ne '$_[1]'\n";
+      $comment .= ": '$_[0]' ne '$_[1]'";
+      print "not ok $test$comment\n";
     }
   } else {
     if (shift) {
@@ -1081,11 +1084,11 @@ sub xet { @_ == 2 ? $_[0]->{$_[1]} :
 package main;
 my $a = Foo->new;
 $a->xet('b', 42);
-print $a->xet('b') == 42 ? "ok 225\n" : "not ok 225\n";
-print defined eval { $a->{b} } ? "not ok 226\n" : "ok 226\n";
-print $@ =~ /zap/ ? "ok 227\n" : "not ok 227\n";
+test ($a->xet('b'), 42);
+test (!defined eval { $a->{b} });
+test ($@ =~ /zap/);
 
-print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" : "not ok 228\n";
+test (overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
 
 {
    package t229;
@@ -1100,8 +1103,20 @@ print overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/ ? "ok 228\n" :
       my $y = $x;
       eval { $y++ };
    }
-   print $warn ? "not ok 229\n" : "ok 229\n";
+   main::test (!$warn);
+}
+
+{
+    my ($int, $out1, $out2);
+    {
+        BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; }
+        $out1 = 0;
+        $out2 = 1;
+    }
+    test($int,  2,  "#24313");	# 230
+    test($out1, 17, "#24313");	# 231
+    test($out2, 17, "#24313");	# 232
 }
 
 # Last test is:
-sub last {229}
+sub last {232}
diff --git a/toke.c b/toke.c
index b6b81d244b..3b010ec2a2 100644
--- a/toke.c
+++ b/toke.c
@@ -7252,6 +7252,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 	    UV u = 0;
 	    I32 shift;
 	    bool overflowed = FALSE;
+	    bool just_zero  = TRUE;	/* just plain 0 or binary number? */
 	    static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
 	    static char* bases[5] = { "", "binary", "", "octal",
 				      "hexadecimal" };
@@ -7268,9 +7269,11 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 	    if (s[1] == 'x') {
 		shift = 4;
 		s += 2;
+		just_zero = FALSE;
 	    } else if (s[1] == 'b') {
 		shift = 1;
 		s += 2;
+		just_zero = FALSE;
 	    }
 	    /* check for a decimal in disguise */
 	    else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
@@ -7342,6 +7345,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 		    */
 
 		  digit:
+		    just_zero = FALSE;
 		    if (!overflowed) {
 			x = u << shift;	/* make room for the digit */
 
@@ -7400,7 +7404,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 #endif
 		sv_setuv(sv, u);
 	    }
-	    if (PL_hints & HINT_NEW_BINARY)
+	    if (just_zero && (PL_hints & HINT_NEW_INTEGER))
+		sv = new_constant(start, s - start, "integer", 
+				  sv, Nullsv, NULL);
+	    else if (PL_hints & HINT_NEW_BINARY)
 		sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
 	}
 	break;