dist/Storable/t/store.t

   1 #!./perl
   2 #
   3 #  Copyright (c) 1995-2000, Raphael Manfredi
   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     unshift @INC, 't';
  11     unshift @INC, 't/compat' if $] < 5.006002;
  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     require 'st-dump.pl';
  18 }
  19
  20 use Storable qw(store retrieve store_fd nstore_fd fd_retrieve);
  21
  22 use Test::More tests => 21;
  23
  24 $a = 'toto';
  25 $b = \$a;
  26 $c = bless {}, CLASS;
  27 $c->{attribute} = 'attrval';
  28 %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c);
  29 @a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
  30         $b, \$a, $a, $c, \$c, \%a);
  31
  32 isnt(store(\@a, 'store'), undef);
  33
  34 $dumped = &dump(\@a);
  35 isnt($dumped, undef);
  36
  37 $root = retrieve('store');
  38 isnt($root, undef);
  39
  40 $got = &dump($root);
  41 isnt($got, undef);
  42
  43 is($got, $dumped);
  44
  45 1 while unlink 'store';
  46
  47 package FOO; @ISA = qw(Storable);
  48
  49 sub make {
  50         my $self = bless {};
  51         $self->{key} = \%main::a;
  52         return $self;
  53 };
  54
  55 package main;
  56
  57 $foo = FOO->make;
  58 isnt($foo->store('store'), undef);
  59
  60 isnt(open(OUT, '>>store'), undef);
  61 binmode OUT;
  62
  63 isnt(store_fd(\@a, ::OUT), undef);
  64 isnt(nstore_fd($foo, ::OUT), undef);
  65 isnt(nstore_fd(\%a, ::OUT), undef);
  66
  67 isnt(close(OUT), undef);
  68
  69 isnt(open(OUT, 'store'), undef);
  70
  71 $r = fd_retrieve(::OUT);
  72 isnt($r, undef);
  73 is(&dump($r), &dump($foo));
  74
  75 $r = fd_retrieve(::OUT);
  76 isnt($r, undef);
  77 is(&dump($r), &dump(\@a));
  78
  79 $r = fd_retrieve(main::OUT);
  80 isnt($r, undef);
  81 is(&dump($r), &dump($foo));
  82
  83 $r = fd_retrieve(::OUT);
  84 isnt($r, undef);
  85 is(&dump($r), &dump(\%a));
  86
  87 eval { $r = fd_retrieve(::OUT); };
  88 isnt($@, '');
  89
  90 close OUT or die "Could not close: $!";
  91 END { 1 while unlink 'store' }