1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8# this must come before main, or tests will fail 9package TieTest; 10 11use Tie::Scalar; 12our @ISA = qw( Tie::Scalar ); 13 14sub new { 'Fooled you.' } 15 16package main; 17 18our $flag; 19use Test::More; 20 21use_ok( 'Tie::Scalar' ); 22 23# these are "abstract virtual" parent methods 24for my $method (qw( TIESCALAR FETCH STORE )) { 25 eval { Tie::Scalar->$method() }; 26 like( $@, qr/doesn't define a $method/, "croaks on inherited $method()" ); 27} 28 29# the default value is undef 30my $scalar = Tie::StdScalar->TIESCALAR(); 31is( $$scalar, undef, 'used TIESCALAR, default value is still undef' ); 32 33# Tie::StdScalar redirects to TIESCALAR 34$scalar = Tie::StdScalar->new(); 35is( $$scalar, undef, 'used new(), default value is still undef' ); 36 37# this approach should work as well 38tie $scalar, 'Tie::StdScalar'; 39is( $$scalar, undef, 'tied a scalar, default value is undef' ); 40 41# first set, then read 42$scalar = 'fetch me'; 43is( $scalar, 'fetch me', 'STORE() and FETCH() verified with one test!' ); 44 45# test DESTROY with an object that signals its destruction 46{ 47 my $scalar = 'foo'; 48 tie $scalar, 'Tie::StdScalar', DestroyAction->new(); 49 ok( $scalar, 'tied once more' ); 50 is( $flag, undef, 'destroy flag not set' ); 51} 52 53# $scalar out of scope, Tie::StdScalar::DESTROY() called, DestroyAction set flag 54is( $flag, 1, 'and DESTROY() works' ); 55 56# we want some noise, and some way to capture it 57use warnings; 58my $warn; 59local $SIG{__WARN__} = sub { 60 $warn = $_[0]; 61}; 62 63# Tie::Scalar::TIEHANDLE should find and call TieTest::new and complain 64is( tie( my $foo, 'TieTest'), 'Fooled you.', 'delegated to new()' ); 65like( $warn, qr/WARNING: calling TieTest->new/, 'caught warning fine' ); 66 67package DestroyAction; 68 69sub new { 70 bless( \(my $self), $_[0] ); 71} 72 73sub DESTROY { 74 $main::flag = 1; 75} 76 77 78# 79# Bug #72878: don't recurse forever if both new and TIESCALAR are missing. 80# 81package main; 82 83@NoMethods::ISA = qw [Tie::Scalar]; 84 85{ 86 # 87 # Without the fix for #72878, the code runs forever. 88 # Trap this, and die if with an appropriate message if this happens. 89 # 90 local $SIG {__WARN__} = sub { 91 die "Called NoMethods->new" 92 if $_ [0] =~ /^WARNING: calling NoMethods->new/; 93 }; 94 95 eval {tie my $foo => "NoMethods";}; 96 97 like $@ => 98 qr /\QNoMethods must define either a TIESCALAR() or a new() method/, 99 "croaks if both new() and TIESCALAR() are missing"; 100}; 101 102# 103# Don't croak on missing new/TIESCALAR if you're inheriting one. 104# 105my $called1 = 0; 106my $called2 = 0; 107 108sub HasMethod1::new {$called1 ++} 109 @HasMethod1::ISA = qw [Tie::Scalar]; 110 @InheritHasMethod1::ISA = qw [HasMethod1]; 111 112sub HasMethod2::TIESCALAR {$called2 ++} 113 @HasMethod2::ISA = qw [Tie::Scalar]; 114 @InheritHasMethod2::ISA = qw [HasMethod2]; 115 116my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1}; 117my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1}; 118 119ok $r1 && $called1, "inheriting new() does not croak"; 120ok $r2 && $called2, "inheriting TIESCALAR() does not croak"; 121 122done_testing(); 123