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; | |
cc01160e | 12 | our @ISA = qw( Tie::Scalar ); |
c6c73c78 | 13 | |
14 | sub new { 'Fooled you.' } | |
15 | ||
16 | package main; | |
17 | ||
cc01160e | 18 | our $flag; |
bc370711 | 19 | use Test::More tests => 16; |
c6c73c78 | 20 | |
21 | use_ok( 'Tie::Scalar' ); | |
22 | ||
23 | # these are "abstract virtual" parent methods | |
ea25a9b2 | 24 | for my $method (qw( TIESCALAR FETCH STORE )) { |
c6c73c78 | 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 | |
30 | my $scalar = Tie::StdScalar->TIESCALAR(); | |
31 | is( $$scalar, undef, 'used TIESCALAR, default value is still undef' ); | |
32 | ||
33 | # Tie::StdScalar redirects to TIESCALAR | |
34 | $scalar = Tie::StdScalar->new(); | |
35 | is( $$scalar, undef, 'used new(), default value is still undef' ); | |
36 | ||
37 | # this approach should work as well | |
38 | tie $scalar, 'Tie::StdScalar'; | |
39 | is( $$scalar, undef, 'tied a scalar, default value is undef' ); | |
40 | ||
41 | # first set, then read | |
42 | $scalar = 'fetch me'; | |
43 | is( $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 | |
54 | is( $flag, 1, 'and DESTROY() works' ); | |
55 | ||
56 | # we want some noise, and some way to capture it | |
57 | use warnings; | |
58 | my $warn; | |
59 | local $SIG{__WARN__} = sub { | |
60 | $warn = $_[0]; | |
61 | }; | |
62 | ||
63 | # Tie::Scalar::TIEHANDLE should find and call TieTest::new and complain | |
64 | is( tie( my $foo, 'TieTest'), 'Fooled you.', 'delegated to new()' ); | |
65 | like( $warn, qr/WARNING: calling TieTest->new/, 'caught warning fine' ); | |
66 | ||
67 | package DestroyAction; | |
68 | ||
69 | sub new { | |
70 | bless( \(my $self), $_[0] ); | |
71 | } | |
72 | ||
73 | sub DESTROY { | |
74 | $main::flag = 1; | |
75 | } | |
bc370711 A |
76 | |
77 | ||
78 | # | |
79 | # Bug #72878: don't recurse forever if both new and TIESCALAR are missing. | |
80 | # | |
81 | package main; | |
82 | ||
83 | @NoMethods::ISA = qw [Tie::Scalar]; | |
84 | ||
915f085e A |
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 | }; | |
bc370711 A |
101 | |
102 | # | |
103 | # Don't croak on missing new/TIESCALAR if you're inheriting one. | |
104 | # | |
105 | my $called1 = 0; | |
106 | my $called2 = 0; | |
107 | ||
108 | sub HasMethod1::new {$called1 ++} | |
109 | @HasMethod1::ISA = qw [Tie::Scalar]; | |
110 | @InheritHasMethod1::ISA = qw [HasMethod1]; | |
111 | ||
112 | sub HasMethod2::TIESCALAR {$called2 ++} | |
113 | @HasMethod2::ISA = qw [Tie::Scalar]; | |
114 | @InheritHasMethod2::ISA = qw [HasMethod2]; | |
115 | ||
116 | my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1}; | |
117 | my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1}; | |
118 | ||
119 | ok $r1 && $called1, "inheriting new() does not croak"; | |
120 | ok $r2 && $called2, "inheriting TIESCALAR() does not croak"; |