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 24sub ok; 25 26use Storable qw(freeze thaw); 27 28%::immortals 29 = (u => \undef, 30 'y' => \(1 == 1), 31 n => \(1 == 0) 32); 33 34my $test = 12; 35my $tests = $test + 6 + 2 * 6 * keys %::immortals; 36print "1..$tests\n"; 37 38package SHORT_NAME; 39 40sub make { bless [], shift } 41 42package SHORT_NAME_WITH_HOOK; 43 44sub make { bless [], shift } 45 46sub STORABLE_freeze { 47 my $self = shift; 48 return ("", $self); 49} 50 51sub STORABLE_thaw { 52 my $self = shift; 53 my $cloning = shift; 54 my ($x, $obj) = @_; 55 die "STORABLE_thaw" unless $obj eq $self; 56} 57 58package main; 59 60# Still less than 256 bytes, so long classname logic not fully exercised 61# Wait until Perl removes the restriction on identifier lengths. 62my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final"; 63 64eval <<EOC; 65package $name; 66 67\@ISA = ("SHORT_NAME"); 68EOC 69die $@ if $@; 70ok 1, $@ eq ''; 71 72eval <<EOC; 73package ${name}_WITH_HOOK; 74 75\@ISA = ("SHORT_NAME_WITH_HOOK"); 76EOC 77ok 2, $@ eq ''; 78 79# Construct a pool of objects 80my @pool; 81 82for (my $i = 0; $i < 10; $i++) { 83 push(@pool, SHORT_NAME->make); 84 push(@pool, SHORT_NAME_WITH_HOOK->make); 85 push(@pool, $name->make); 86 push(@pool, "${name}_WITH_HOOK"->make); 87} 88 89my $x = freeze \@pool; 90ok 3, 1; 91 92my $y = thaw $x; 93ok 4, ref $y eq 'ARRAY'; 94ok 5, @{$y} == @pool; 95 96ok 6, ref $y->[0] eq 'SHORT_NAME'; 97ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK'; 98ok 8, ref $y->[2] eq $name; 99ok 9, ref $y->[3] eq "${name}_WITH_HOOK"; 100 101my $good = 1; 102for (my $i = 0; $i < 10; $i++) { 103 do { $good = 0; last } unless ref $y->[4*$i] eq 'SHORT_NAME'; 104 do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK'; 105 do { $good = 0; last } unless ref $y->[4*$i+2] eq $name; 106 do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK"; 107} 108ok 10, $good; 109 110{ 111 my $blessed_ref = bless \\[1,2,3], 'Foobar'; 112 my $x = freeze $blessed_ref; 113 my $y = thaw $x; 114 ok 11, ref $y eq 'Foobar'; 115 ok 12, $$$y->[0] == 1; 116} 117 118package RETURNS_IMMORTALS; 119 120sub make { my $self = shift; bless [@_], $self } 121 122sub STORABLE_freeze { 123 # Some reference some number of times. 124 my $self = shift; 125 my ($what, $times) = @$self; 126 return ("$what$times", ($::immortals{$what}) x $times); 127} 128 129sub STORABLE_thaw { 130 my $self = shift; 131 my $cloning = shift; 132 my ($x, @refs) = @_; 133 my ($what, $times) = $x =~ /(.)(\d+)/; 134 die "'$x' didn't match" unless defined $times; 135 main::ok ++$test, @refs == $times; 136 my $expect = $::immortals{$what}; 137 die "'$x' did not give a reference" unless ref $expect; 138 my $fail; 139 foreach (@refs) { 140 $fail++ if $_ != $expect; 141 } 142 main::ok ++$test, !$fail; 143} 144 145package main; 146 147# $Storable::DEBUGME = 1; 148my $count; 149foreach $count (1..3) { 150 my $immortal; 151 foreach $immortal (keys %::immortals) { 152 print "# $immortal x $count\n"; 153 my $i = RETURNS_IMMORTALS->make ($immortal, $count); 154 155 my $f = freeze ($i); 156 ok ++$test, $f; 157 my $t = thaw $f; 158 ok ++$test, 1; 159 } 160} 161 162# Test automatic require of packages to find thaw hook. 163 164package HAS_HOOK; 165 166$loaded_count = 0; 167$thawed_count = 0; 168 169sub make { 170 bless []; 171} 172 173sub STORABLE_freeze { 174 my $self = shift; 175 return ''; 176} 177 178package main; 179 180my $f = freeze (HAS_HOOK->make); 181 182ok ++$test, $HAS_HOOK::loaded_count == 0; 183ok ++$test, $HAS_HOOK::thawed_count == 0; 184 185my $t = thaw $f; 186ok ++$test, $HAS_HOOK::loaded_count == 1; 187ok ++$test, $HAS_HOOK::thawed_count == 1; 188ok ++$test, $t; 189ok ++$test, ref $t eq 'HAS_HOOK'; 190 191# Can't do this because the method is still cached by UNIVERSAL::can 192# delete $INC{"HAS_HOOK.pm"}; 193# undef &HAS_HOOK::STORABLE_thaw; 194# 195# warn HAS_HOOK->can('STORABLE_thaw'); 196# $t = thaw $f; 197# ok ++$test, $HAS_HOOK::loaded_count == 2; 198# ok ++$test, $HAS_HOOK::thawed_count == 2; 199# ok ++$test, $t; 200# ok ++$test, ref $t eq 'HAS_HOOK'; 201