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