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 {
  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 };
 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";