diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Tie/Scalar.pm | 17 | ||||
| -rw-r--r-- | lib/Tie/Scalar.t | 36 |
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"; |