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 9sub BEGIN { 10 if ($ENV{PERL_CORE}){ 11 chdir('t') if -d 't'; 12 @INC = ('.', '../lib', '../ext/Storable/t'); 13 } else { 14 unshift @INC, 't'; 15 } 16 require Config; import Config; 17 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 18 print "1..0 # Skip: Storable was not built\n"; 19 exit 0; 20 } 21 require 'st-dump.pl'; 22} 23 24use Storable qw(store retrieve store_fd nstore_fd fd_retrieve); 25 26print "1..20\n"; 27 28$a = 'toto'; 29$b = \$a; 30$c = bless {}, CLASS; 31$c->{attribute} = 'attrval'; 32%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); 33@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, 34 $b, \$a, $a, $c, \$c, \%a); 35 36print "not " unless defined store(\@a, 'store'); 37print "ok 1\n"; 38 39$dumped = &dump(\@a); 40print "ok 2\n"; 41 42$root = retrieve('store'); 43print "not " unless defined $root; 44print "ok 3\n"; 45 46$got = &dump($root); 47print "ok 4\n"; 48 49print "not " unless $got eq $dumped; 50print "ok 5\n"; 51 521 while unlink 'store'; 53 54package FOO; @ISA = qw(Storable); 55 56sub make { 57 my $self = bless {}; 58 $self->{key} = \%main::a; 59 return $self; 60}; 61 62package main; 63 64$foo = FOO->make; 65print "not " unless $foo->store('store'); 66print "ok 6\n"; 67 68print "not " unless open(OUT, '>>store'); 69print "ok 7\n"; 70binmode OUT; 71 72print "not " unless defined store_fd(\@a, ::OUT); 73print "ok 8\n"; 74print "not " unless defined nstore_fd($foo, ::OUT); 75print "ok 9\n"; 76print "not " unless defined nstore_fd(\%a, ::OUT); 77print "ok 10\n"; 78 79print "not " unless close(OUT); 80print "ok 11\n"; 81 82print "not " unless open(OUT, 'store'); 83binmode OUT; 84 85$r = fd_retrieve(::OUT); 86print "not " unless defined $r; 87print "ok 12\n"; 88print "not " unless &dump($foo) eq &dump($r); 89print "ok 13\n"; 90 91$r = fd_retrieve(::OUT); 92print "not " unless defined $r; 93print "ok 14\n"; 94print "not " unless &dump(\@a) eq &dump($r); 95print "ok 15\n"; 96 97$r = fd_retrieve(main::OUT); 98print "not " unless defined $r; 99print "ok 16\n"; 100print "not " unless &dump($foo) eq &dump($r); 101print "ok 17\n"; 102 103$r = fd_retrieve(::OUT); 104print "not " unless defined $r; 105print "ok 18\n"; 106print "not " unless &dump(\%a) eq &dump($r); 107print "ok 19\n"; 108 109eval { $r = fd_retrieve(::OUT); }; 110print "not " unless $@; 111print "ok 20\n"; 112 113close OUT or die "Could not close: $!"; 114END { 1 while unlink 'store' } 115