dist/Storable/t/blessed.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 }
  18
  19 use Test::More;
  20
  21 use Storable qw(freeze thaw store retrieve);
  22
  23 %::immortals
  24   = (u => \undef,
  25      'y' => \(1 == 1),
  26      n => \(1 == 0)
  27 );
  28
  29 {
  30     %::weird_refs = (
  31         REF     => \(my $aref    = []),
  32         VSTRING => \(my $vstring = v1.2.3),
  33        'long VSTRING' => \(my $vstring = eval "v" . 0 x 300),
  34         LVALUE  => \(my $substr  = substr((my $str = "foo"), 0, 3)),
  35     );
  36 }
  37
  38 my $test = 12;
  39 my $tests = $test + 23 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs);
  40 plan(tests => $tests);
  41
  42 package SHORT_NAME;
  43
  44 sub make { bless [], shift }
  45
  46 package SHORT_NAME_WITH_HOOK;
  47
  48 sub make { bless [], shift }
  49
  50 sub STORABLE_freeze {
  51         my $self = shift;
  52         return ("", $self);
  53 }
  54
  55 sub STORABLE_thaw {
  56         my $self = shift;
  57         my $cloning = shift;
  58         my ($x, $obj) = @_;
  59         die "STORABLE_thaw" unless $obj eq $self;
  60 }
  61
  62 package main;
  63
  64 # Still less than 256 bytes, so long classname logic not fully exercised
  65 # Wait until Perl removes the restriction on identifier lengths.
  66 my $name = "LONG_NAME_" . 'xxxxxxxxxxxxx::' x 14 . "final";
  67
  68 eval <<EOC;
  69 package $name;
  70
  71 \@ISA = ("SHORT_NAME");
  72 EOC
  73 is($@, '');
  74
  75 eval <<EOC;
  76 package ${name}_WITH_HOOK;
  77
  78 \@ISA = ("SHORT_NAME_WITH_HOOK");
  79 EOC
  80 is($@, '');
  81
  82 # Construct a pool of objects
  83 my @pool;
  84
  85 for (my $i = 0; $i < 10; $i++) {
  86         push(@pool, SHORT_NAME->make);
  87         push(@pool, SHORT_NAME_WITH_HOOK->make);
  88         push(@pool, $name->make);
  89         push(@pool, "${name}_WITH_HOOK"->make);
  90 }
  91
  92 my $x = freeze \@pool;
  93 pass("Freeze didn't crash");
  94
  95 my $y = thaw $x;
  96 is(ref $y, 'ARRAY');
  97 is(scalar @{$y}, @pool);
  98
  99 is(ref $y->[0], 'SHORT_NAME');
 100 is(ref $y->[1], 'SHORT_NAME_WITH_HOOK');
 101 is(ref $y->[2], $name);
 102 is(ref $y->[3], "${name}_WITH_HOOK");
 103
 104 my $good = 1;
 105 for (my $i = 0; $i < 10; $i++) {
 106         do { $good = 0; last } unless ref $y->[4*$i]   eq 'SHORT_NAME';
 107         do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
 108         do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
 109         do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
 110 }
 111 is($good, 1);
 112
 113 {
 114         my $blessed_ref = bless \\[1,2,3], 'Foobar';
 115         my $x = freeze $blessed_ref;
 116         my $y = thaw $x;
 117         is(ref $y, 'Foobar');
 118         is($$$y->[0], 1);
 119 }
 120
 121 package RETURNS_IMMORTALS;
 122
 123 sub make { my $self = shift; bless [@_], $self }
 124
 125 sub STORABLE_freeze {
 126   # Some reference some number of times.
 127   my $self = shift;
 128   my ($what, $times) = @$self;
 129   return ("$what$times", ($::immortals{$what}) x $times);
 130 }
 131
 132 sub STORABLE_thaw {
 133         my $self = shift;
 134         my $cloning = shift;
 135         my ($x, @refs) = @_;
 136         my ($what, $times) = $x =~ /(.)(\d+)/;
 137         die "'$x' didn't match" unless defined $times;
 138         main::is(scalar @refs, $times);
 139         my $expect = $::immortals{$what};
 140         die "'$x' did not give a reference" unless ref $expect;
 141         my $fail;
 142         foreach (@refs) {
 143           $fail++ if $_ != $expect;
 144         }
 145         main::is($fail, undef);
 146 }
 147
 148 package main;
 149
 150 # $Storable::DEBUGME = 1;
 151 my $count;
 152 foreach $count (1..3) {
 153   my $immortal;
 154   foreach $immortal (keys %::immortals) {
 155     print "# $immortal x $count\n";
 156     my $i =  RETURNS_IMMORTALS->make ($immortal, $count);
 157
 158     my $f = freeze ($i);
 159     isnt($f, undef);
 160     my $t = thaw $f;
 161     pass("thaw didn't crash");
 162   }
 163 }
 164
 165 # Test automatic require of packages to find thaw hook.
 166
 167 package HAS_HOOK;
 168
 169 $loaded_count = 0;
 170 $thawed_count = 0;
 171
 172 sub make {
 173   bless [];
 174 }
 175
 176 sub STORABLE_freeze {
 177   my $self = shift;
 178   return '';
 179 }
 180
 181 package main;
 182
 183 my $f = freeze (HAS_HOOK->make);
 184
 185 is($HAS_HOOK::loaded_count, 0);
 186 is($HAS_HOOK::thawed_count, 0);
 187
 188 my $t = thaw $f;
 189 is($HAS_HOOK::loaded_count, 1);
 190 is($HAS_HOOK::thawed_count, 1);
 191 isnt($t, undef);
 192 is(ref $t, 'HAS_HOOK');
 193
 194 delete $INC{"HAS_HOOK.pm"};
 195 delete $HAS_HOOK::{STORABLE_thaw};
 196
 197 $t = thaw $f;
 198 is($HAS_HOOK::loaded_count, 2);
 199 is($HAS_HOOK::thawed_count, 2);
 200 isnt($t, undef);
 201 is(ref $t, 'HAS_HOOK');
 202
 203 {
 204     package STRESS_THE_STACK;
 205
 206     my $stress;
 207     sub make {
 208         bless [];
 209     }
 210
 211     sub no_op {
 212         0;
 213     }
 214
 215     sub STORABLE_freeze {
 216         my $self = shift;
 217         ++$freeze_count;
 218         return no_op(1..(++$stress * 2000)) ? die "can't happen" : '';
 219     }
 220
 221     sub STORABLE_thaw {
 222         my $self = shift;
 223         ++$thaw_count;
 224         no_op(1..(++$stress * 2000)) && die "can't happen";
 225         return;
 226     }
 227 }
 228
 229 $STRESS_THE_STACK::freeze_count = 0;
 230 $STRESS_THE_STACK::thaw_count = 0;
 231
 232 $f = freeze (STRESS_THE_STACK->make);
 233
 234 is($STRESS_THE_STACK::freeze_count, 1);
 235 is($STRESS_THE_STACK::thaw_count, 0);
 236
 237 $t = thaw $f;
 238 is($STRESS_THE_STACK::freeze_count, 1);
 239 is($STRESS_THE_STACK::thaw_count, 1);
 240 isnt($t, undef);
 241 is(ref $t, 'STRESS_THE_STACK');
 242
 243 my $file = "storable-testfile.$$";
 244 die "Temporary file '$file' already exists" if -e $file;
 245
 246 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
 247
 248 $STRESS_THE_STACK::freeze_count = 0;
 249 $STRESS_THE_STACK::thaw_count = 0;
 250
 251 store (STRESS_THE_STACK->make, $file);
 252
 253 is($STRESS_THE_STACK::freeze_count, 1);
 254 is($STRESS_THE_STACK::thaw_count, 0);
 255
 256 $t = retrieve ($file);
 257 is($STRESS_THE_STACK::freeze_count, 1);
 258 is($STRESS_THE_STACK::thaw_count, 1);
 259 isnt($t, undef);
 260 is(ref $t, 'STRESS_THE_STACK');
 261
 262 {
 263     package ModifyARG112358;
 264     sub STORABLE_freeze { $_[0] = "foo"; }
 265     my $o= {str=>bless {}};
 266     my $f= ::freeze($o);
 267     ::is ref $o->{str}, __PACKAGE__,
 268         'assignment to $_[0] in STORABLE_freeze does not corrupt things';
 269 }
 270
 271 # [perl #113880]
 272 {
 273     {
 274         package WeirdRefHook;
 275         sub STORABLE_freeze { () }
 276         $INC{'WeirdRefHook.pm'} = __FILE__;
 277     }
 278
 279     for my $weird (keys %weird_refs) {
 280         my $obj = $weird_refs{$weird};
 281         bless $obj, 'WeirdRefHook';
 282         my $frozen;
 283         my $success = eval { $frozen = freeze($obj); 1 };
 284         ok($success, "can freeze $weird objects")
 285             || diag("freezing failed: $@");
 286         my $thawn = thaw($frozen);
 287         # is_deeply ignores blessings
 288         is ref $thawn, ref $obj, "get the right blessing back for $weird";
 289         if ($weird =~ 'VSTRING') {
 290             # It is not just Storable that did not support vstrings. :-)
 291             # See https://rt.cpan.org/Ticket/Display.html?id=78678
 292             my $newver = "version"->can("new")
 293                            ? sub { "version"->new(shift) }
 294                            : sub { "" };
 295             if (!ok
 296                   $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj),
 297                  "get the right value back"
 298             ) {
 299                 diag "$$thawn vs $$obj";
 300                 diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1);
 301              }
 302         }
 303         else {
 304             is_deeply($thawn, $obj, "get the right value back");
 305         }
 306     }
 307 }