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
CommitLineData
c6c73c78 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 );
bc370711 20use Test::More tests => 16;
c6c73c78 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}
bc370711
A
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
86eval {tie my $foo => "NoMethods"};
87
88like $@ =>
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#
95my $called1 = 0;
96my $called2 = 0;
97
98sub HasMethod1::new {$called1 ++}
99 @HasMethod1::ISA = qw [Tie::Scalar];
100 @InheritHasMethod1::ISA = qw [HasMethod1];
101
102sub HasMethod2::TIESCALAR {$called2 ++}
103 @HasMethod2::ISA = qw [Tie::Scalar];
104 @InheritHasMethod2::ISA = qw [HasMethod2];
105
106my $r1 = eval {tie my $foo => "InheritHasMethod1"; 1};
107my $r2 = eval {tie my $foo => "InheritHasMethod2"; 1};
108
109ok $r1 && $called1, "inheriting new() does not croak";
110ok $r2 && $called2, "inheriting TIESCALAR() does not croak";