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