This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Don't recurse forever if both new() and TIESCALAR() are missing.
[perl5.git] / lib / Tie / Scalar.t
1 #!./perl
2
3 BEGIN {
4         chdir 't' if -d 't';
5         @INC = '../lib';
6 }
7
8 # this must come before main, or tests will fail
9 package TieTest;
10
11 use Tie::Scalar;
12 use vars qw( @ISA );
13 @ISA = qw( Tie::Scalar );
14
15 sub new { 'Fooled you.' }
16
17 package main;
18
19 use vars qw( $flag );
20 use Test::More tests => 16;
21
22 use_ok( 'Tie::Scalar' );
23
24 # these are "abstract virtual" parent methods
25 for 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
31 my $scalar = Tie::StdScalar->TIESCALAR();
32 is( $$scalar, undef, 'used TIESCALAR, default value is still undef' );
33
34 # Tie::StdScalar redirects to TIESCALAR
35 $scalar = Tie::StdScalar->new();
36 is( $$scalar, undef, 'used new(), default value is still undef' );
37
38 # this approach should work as well
39 tie $scalar, 'Tie::StdScalar';
40 is( $$scalar, undef, 'tied a scalar, default value is undef' );
41
42 # first set, then read
43 $scalar = 'fetch me';
44 is( $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
55 is( $flag, 1, 'and DESTROY() works' );
56
57 # we want some noise, and some way to capture it
58 use warnings;
59 my $warn;
60 local $SIG{__WARN__} = sub {
61         $warn = $_[0];
62 };
63
64 # Tie::Scalar::TIEHANDLE should find and call TieTest::new and complain
65 is( tie( my $foo, 'TieTest'), 'Fooled you.', 'delegated to new()' );
66 like( $warn, qr/WARNING: calling TieTest->new/, 'caught warning fine' );
67
68 package DestroyAction;
69
70 sub new {
71         bless( \(my $self), $_[0] );
72 }
73
74 sub DESTROY {
75         $main::flag = 1;
76 }
77
78
79 #
80 # Bug #72878: don't recurse forever if both new and TIESCALAR are missing.
81 #
82 package main;
83
84 @NoMethods::ISA = qw [Tie::Scalar];
85
86 eval {tie my $foo => "NoMethods"};
87
88 like $@ =>
89     qr /\QNoMethods must define either a TIESCALAR() or a new() method/,
90     "croaks if both new() and TIESCALAR() are missing";
91
92 #
93 # Don't croak on missing new/TIESCALAR if you're inheriting one.
94 #
95 my $called1 = 0;
96 my $called2 = 0;
97
98 sub HasMethod1::new {$called1 ++}
99    @HasMethod1::ISA        = qw [Tie::Scalar];
100    @InheritHasMethod1::ISA = qw [HasMethod1];
101
102 sub HasMethod2::TIESCALAR {$called2 ++}
103    @HasMethod2::ISA        = qw [Tie::Scalar];
104    @InheritHasMethod2::ISA = qw [HasMethod2];
105
106 my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1};
107 my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1};
108
109 ok $r1 && $called1, "inheriting new() does not croak";
110 ok $r2 && $called2, "inheriting TIESCALAR() does not croak";