ext/Storable/t/weak.t

   1 #!./perl -w
   2 #
   3 #  Copyright 2004, Larry Wall.
   4 #
   5 #  You may redistribute only under the same terms as Perl 5, as specified
   6 #  in the README file that comes with the distribution.
   7 #
   8
   9 sub BEGIN {
  10   if ($ENV{PERL_CORE}){
  11     chdir('t') if -d 't';
  12     @INC = ('.', '../lib', '../ext/Storable/t');
  13   } else {
  14     # This lets us distribute Test::More in t/
  15     unshift @INC, 't';
  16   }
  17   require Config; import Config;
  18   if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
  19     print "1..0 # Skip: Storable was not built\n";
  20     exit 0;
  21   }
  22   if ($Config{extensions} !~ /\bList\/Util\b/) {
  23     print "1..0 # Skip: List::Util was not built\n";
  24     exit 0;
  25   }
  26
  27   require Scalar::Util;
  28   Scalar::Util->import(qw(weaken isweak));
  29   if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
  30     print("1..0 # Skip: No support for weaken in Scalar::Util\n");
  31     exit 0;
  32   }
  33 }
  34
  35 use Test::More 'no_plan';
  36 use Storable qw (store retrieve freeze thaw nstore nfreeze);
  37 require 'testlib.pl';
  38 use vars '$file';
  39 use strict;
  40
  41 sub tester {
  42   my ($contents, $sub, $testersub, $what) = @_;
  43   # Test that if we re-write it, everything still works:
  44   my $clone = &$sub ($contents);
  45   is ($@, "", "There should be no error extracting for $what");
  46   &$testersub ($clone, $what);
  47 }
  48
  49 my $r = {};
  50 my $s1 = [$r, $r];
  51 weaken $s1->[1];
  52 ok (isweak($s1->[1]), "element 1 is a weak reference");
  53
  54 my $s0 = [$r, $r];
  55 weaken $s0->[0];
  56 ok (isweak($s0->[0]), "element 0 is a weak reference");
  57
  58 my $w = [$r];
  59 weaken $w->[0];
  60 ok (isweak($w->[0]), "element 0 is a weak reference");
  61
  62 package OVERLOADED;
  63
  64 use overload
  65         '""' => sub { $_[0][0] };
  66
  67 package main;
  68
  69 $a = bless [77], 'OVERLOADED';
  70
  71 my $o = [$a, $a];
  72 weaken $o->[0];
  73 ok (isweak($o->[0]), "element 0 is a weak reference");
  74
  75 my @tests = (
  76 [$s1,
  77  sub  {
  78   my ($clone, $what) = @_;
  79   isa_ok($clone,'ARRAY');
  80   isa_ok($clone->[0],'HASH');
  81   isa_ok($clone->[1],'HASH');
  82   ok(!isweak $clone->[0], "Element 0 isn't weak");
  83   ok(isweak $clone->[1], "Element 1 is weak");
  84 }
  85 ],
  86 # The weak reference needs to hang around long enough for other stuff to
  87 # be able to make references to it. So try it second.
  88 [$s0,
  89  sub  {
  90   my ($clone, $what) = @_;
  91   isa_ok($clone,'ARRAY');
  92   isa_ok($clone->[0],'HASH');
  93   isa_ok($clone->[1],'HASH');
  94   ok(isweak $clone->[0], "Element 0 is weak");
  95   ok(!isweak $clone->[1], "Element 1 isn't weak");
  96 }
  97 ],
  98 [$w,
  99  sub  {
 100   my ($clone, $what) = @_;
 101   isa_ok($clone,'ARRAY');
 102   if ($what eq 'nothing') {
 103     # We're the original, so we're still a weakref to a hash
 104     isa_ok($clone->[0],'HASH');
 105     ok(isweak $clone->[0], "Element 0 is weak");
 106   } else {
 107     is($clone->[0],undef);
 108   }
 109 }
 110 ],
 111 [$o,
 112 sub {
 113   my ($clone, $what) = @_;
 114   isa_ok($clone,'ARRAY');
 115   isa_ok($clone->[0],'OVERLOADED');
 116   isa_ok($clone->[1],'OVERLOADED');
 117   ok(isweak $clone->[0], "Element 0 is weak");
 118   ok(!isweak $clone->[1], "Element 1 isn't weak");
 119   is ("$clone->[0]", 77, "Element 0 stringifies to 77");
 120   is ("$clone->[1]", 77, "Element 1 stringifies to 77");
 121 }
 122 ],
 123 );
 124
 125 foreach (@tests) {
 126   my ($input, $testsub) = @$_;
 127
 128   tester($input, sub {return shift}, $testsub, 'nothing');
 129
 130   ok (defined store($input, $file));
 131
 132   # Read the contents into memory:
 133   my $contents = slurp ($file);
 134
 135   tester($contents, \&store_and_retrieve, $testsub, 'file');
 136
 137   # And now try almost everything again with a Storable string
 138   my $stored = freeze $input;
 139   tester($stored, \&freeze_and_thaw, $testsub, 'string');
 140
 141   ok (defined nstore($input, $file));
 142
 143   tester($contents, \&store_and_retrieve, $testsub, 'network file');
 144
 145   $stored = nfreeze $input;
 146   tester($stored, \&freeze_and_thaw, $testsub, 'network string');
 147 }