Commit | Line | Data |
c6c73c78 |
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 ); |
bc370711 |
20 | use Test::More tests => 16; |
c6c73c78 |
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 | } |
bc370711 |
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 | |
915f085e |
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 | }; |
bc370711 |
102 | |
103 | # |
104 | # Don't croak on missing new/TIESCALAR if you're inheriting one. |
105 | # |
106 | my $called1 = 0; |
107 | my $called2 = 0; |
108 | |
109 | sub HasMethod1::new {$called1 ++} |
110 | @HasMethod1::ISA = qw [Tie::Scalar]; |
111 | @InheritHasMethod1::ISA = qw [HasMethod1]; |
112 | |
113 | sub HasMethod2::TIESCALAR {$called2 ++} |
114 | @HasMethod2::ISA = qw [Tie::Scalar]; |
115 | @InheritHasMethod2::ISA = qw [HasMethod2]; |
116 | |
117 | my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1}; |
118 | my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1}; |
119 | |
120 | ok $r1 && $called1, "inheriting new() does not croak"; |
121 | ok $r2 && $called2, "inheriting TIESCALAR() does not croak"; |