Don't recurse forever if both new() and TIESCALAR() are missing.

This should fix issue #72878. Before calling $pkg -> new in TIESCALAR,
we check whether $pkg -> new is actually the new defined in the Tie::Scalar
package; if true, croak instead of calling it.

2 files changed, 49 insertions, 4 deletions

diff --git a/lib/Tie/Scalar.pm b/lib/Tie/Scalar.pm
index 8048569729..329770a6a2 100644
--- a/lib/Tie/Scalar.pm
+++ b/lib/Tie/Scalar.pm
@@ -104,9 +104,20 @@ sub new {
 
 sub TIESCALAR {
     my $pkg = shift;
-	if ($pkg->can('new') and $pkg ne __PACKAGE__) {
-	warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIESCALAR is missing");
-	$pkg->new(@_);
+    my $pkg_new = $pkg -> can ('new');
+
+    if ($pkg_new and $pkg ne __PACKAGE__) {
+        my $my_new = __PACKAGE__ -> can ('new');
+        if ($pkg_new == $my_new) {  
+            #
+            # Prevent recursion
+            #
+            croak "$pkg must define either a TIESCALAR() or a new() method";
+        }
+
+	warnings::warnif ("WARNING: calling ${pkg}->new since " .
+                          "${pkg}->TIESCALAR is missing");
+	$pkg -> new (@_);
     }
     else {
 	croak "$pkg doesn't define a TIESCALAR method";
diff --git a/lib/Tie/Scalar.t b/lib/Tie/Scalar.t
index 3c5d9b6146..fb33ca13cb 100644
--- a/lib/Tie/Scalar.t
+++ b/lib/Tie/Scalar.t
@@ -17,7 +17,7 @@ sub new { 'Fooled you.' }
 package main;
 
 use vars qw( $flag );
-use Test::More tests => 13;
+use Test::More tests => 16;
 
 use_ok( 'Tie::Scalar' );
 
@@ -74,3 +74,37 @@ sub new {
 sub DESTROY {
 	$main::flag = 1;
 }
+
+
+#
+# Bug #72878: don't recurse forever if both new and TIESCALAR are missing.
+#
+package main;
+
+@NoMethods::ISA = qw [Tie::Scalar];
+
+eval {tie my $foo => "NoMethods"};
+
+like $@ =>
+    qr /\QNoMethods must define either a TIESCALAR() or a new() method/,
+    "croaks if both new() and TIESCALAR() are missing";
+
+#
+# Don't croak on missing new/TIESCALAR if you're inheriting one.
+#
+my $called1 = 0;
+my $called2 = 0;
+
+sub HasMethod1::new {$called1 ++}
+   @HasMethod1::ISA        = qw [Tie::Scalar];
+   @InheritHasMethod1::ISA = qw [HasMethod1];
+
+sub HasMethod2::TIESCALAR {$called2 ++}
+   @HasMethod2::ISA        = qw [Tie::Scalar];
+   @InheritHasMethod2::ISA = qw [HasMethod2];
+
+my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1};
+my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1};
+
+ok $r1 && $called1, "inheriting new() does not croak";
+ok $r2 && $called2, "inheriting TIESCALAR() does not croak";