This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Support Unicode properties Identifier_(Status|Type)
[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 our @ISA = qw( Tie::Scalar );
13
14 sub new { 'Fooled you.' }
15
16 package main;
17
18 our $flag;
19 use Test::More tests => 16;
20
21 use_ok( 'Tie::Scalar' );
22
23 # these are "abstract virtual" parent methods
24 for my $method (qw( TIESCALAR FETCH STORE )) {
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 }
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
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 };
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";