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