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 BEGIN {
  10     # Do this as the very first thing, in order to avoid problems with the
  11     # PADTMP flag on pre-5.19.3 threaded Perls.  On those Perls, compiling
  12     # code that contains a constant-folded canonical truth value breaks
  13     # the ability to take a reference to that canonical truth value later.
  14     $::false = 0;
  15     %::immortals = (
  16         'u' => \undef,
  17         'y' => \!$::false,
  18         'n' => \!!$::false,
  19     );
  20 }
  21
  22 sub BEGIN {
  23     if ($ENV{PERL_CORE}) {
  24         chdir 'dist/Storable' if -d 'dist/Storable';
  25         @INC = ('../../lib', 't');
  26     } else {
  27         unshift @INC, 't';
  28         unshift @INC, 't/compat' if $] < 5.006002;
  29     }
  30     require Config; import Config;
  31     if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
  32         print "1..0 # Skip: Storable was not built\n";
  33         exit 0;
  34     }
  35 }
  36
  37 use Test::More;
  38
  39 use Storable qw(freeze thaw store retrieve fd_retrieve);
  40
  41 %::weird_refs =
  42   (REF            => \(my $aref    = []),
  43    VSTRING        => \(my $vstring = v1.2.3),
  44    'long VSTRING' => \(my $lvstring = eval "v" . 0 x 300),
  45    LVALUE         => \(my $substr  = substr((my $str = "foo"), 0, 3)));
  46
  47 my $test = 18;
  48 my $tests = $test + 41 + (2 * 6 * keys %::immortals) + (3 * keys %::weird_refs);
  49 plan(tests => $tests);
  50
  51 package SHORT_NAME;
  52
  53 sub make { bless [], shift }
  54
  55 package SHORT_NAME_WITH_HOOK;
  56
  57 sub make { bless [], shift }
  58
  59 sub STORABLE_freeze {
  60         my $self = shift;
  61         return ("", $self);
  62 }
  63
  64 sub STORABLE_thaw {
  65         my $self = shift;
  66         my $cloning = shift;
  67         my ($x, $obj) = @_;
  68         die "STORABLE_thaw" unless $obj eq $self;
  69 }
  70
  71 package main;
  72
  73 # Still less than 256 bytes, so long classname logic not fully exercised
  74 #   Identifier too long - 5.004
  75 #   parser.h: char      tokenbuf[256]: cperl5.24 => 1024
  76 my $m = ($Config{usecperl} and $] >= 5.024) ? 56 : 14;
  77 my $longname = "LONG_NAME_" . ('xxxxxxxxxxxxx::' x $m) . "final";
  78
  79 eval <<EOC;
  80 package $longname;
  81
  82 \@ISA = ("SHORT_NAME");
  83 EOC
  84 is($@, '');
  85
  86 eval <<EOC;
  87 package ${longname}_WITH_HOOK;
  88
  89 \@ISA = ("SHORT_NAME_WITH_HOOK");
  90 EOC
  91 is($@, '');
  92
  93 # Construct a pool of objects
  94 my @pool;
  95 for (my $i = 0; $i < 10; $i++) {
  96     push(@pool, SHORT_NAME->make);
  97     push(@pool, SHORT_NAME_WITH_HOOK->make);
  98     push(@pool, $longname->make);
  99     push(@pool, "${longname}_WITH_HOOK"->make);
 100 }
 101
 102 my $x = freeze \@pool;
 103 pass("Freeze didn't crash");
 104
 105 my $y = thaw $x;
 106 is(ref $y, 'ARRAY');
 107 is(scalar @{$y}, @pool);
 108
 109 is(ref $y->[0], 'SHORT_NAME');
 110 is(ref $y->[1], 'SHORT_NAME_WITH_HOOK');
 111 is(ref $y->[2], $longname);
 112 is(ref $y->[3], "${longname}_WITH_HOOK");
 113
 114 my $good = 1;
 115 for (my $i = 0; $i < 10; $i++) {
 116     do { $good = 0; last } unless ref $y->[4*$i]   eq 'SHORT_NAME';
 117     do { $good = 0; last } unless ref $y->[4*$i+1] eq 'SHORT_NAME_WITH_HOOK';
 118     do { $good = 0; last } unless ref $y->[4*$i+2] eq $longname;
 119     do { $good = 0; last } unless ref $y->[4*$i+3] eq "${longname}_WITH_HOOK";
 120 }
 121 is($good, 1);
 122
 123 {
 124     my $blessed_ref = bless \\[1,2,3], 'Foobar';
 125     my $x = freeze $blessed_ref;
 126     my $y = thaw $x;
 127     is(ref $y, 'Foobar');
 128     is($$$y->[0], 1);
 129 }
 130
 131 package RETURNS_IMMORTALS;
 132
 133 sub make { my $self = shift; bless [@_], $self }
 134
 135 sub STORABLE_freeze {
 136     # Some reference some number of times.
 137     my $self = shift;
 138     my ($what, $times) = @$self;
 139     return ("$what$times", ($::immortals{$what}) x $times);
 140 }
 141
 142 sub STORABLE_thaw {
 143     my $self = shift;
 144     my $cloning = shift;
 145     my ($x, @refs) = @_;
 146     my ($what, $times) = $x =~ /(.)(\d+)/;
 147     die "'$x' didn't match" unless defined $times;
 148     main::is(scalar @refs, $times);
 149     my $expect = $::immortals{$what};
 150     die "'$x' did not give a reference" unless ref $expect;
 151     my $fail;
 152     foreach (@refs) {
 153         $fail++ if $_ != $expect;
 154     }
 155     main::is($fail, undef);
 156 }
 157
 158 package main;
 159
 160 # XXX Failed tests:  15, 27, 39 with 5.12 and 5.10 threaded.
 161 # 15: 1 fail (y x 1), 27: 2 fail (y x 2), 39: 3 fail (y x 3)
 162 # $Storable::DEBUGME = 1;
 163 my $count;
 164 foreach $count (1..3) {
 165   my $immortal;
 166   foreach $immortal (keys %::immortals) {
 167     print "# $immortal x $count\n";
 168     my $i =  RETURNS_IMMORTALS->make ($immortal, $count);
 169
 170     my $f = freeze ($i);
 171   TODO: {
 172       # ref sv_true is not always sv_true, at least in older threaded perls.
 173       local $TODO = "Some 5.10/12 do not preserve ref identity with freeze \\(1 == 1)"
 174         if !defined($f) and $] < 5.013 and $] > 5.009 and $immortal eq 'y';
 175       isnt($f, undef);
 176     }
 177     my $t = thaw $f;
 178     pass("thaw didn't crash");
 179   }
 180 }
 181
 182 # Test automatic require of packages to find thaw hook.
 183
 184 package HAS_HOOK;
 185
 186 $loaded_count = 0;
 187 $thawed_count = 0;
 188
 189 sub make {
 190   bless [];
 191 }
 192
 193 sub STORABLE_freeze {
 194   my $self = shift;
 195   return '';
 196 }
 197
 198 package main;
 199
 200 my $f = freeze (HAS_HOOK->make);
 201
 202 is($HAS_HOOK::loaded_count, 0);
 203 is($HAS_HOOK::thawed_count, 0);
 204
 205 my $t = thaw $f;
 206 is($HAS_HOOK::loaded_count, 1);
 207 is($HAS_HOOK::thawed_count, 1);
 208 isnt($t, undef);
 209 is(ref $t, 'HAS_HOOK');
 210
 211 delete $INC{"HAS_HOOK.pm"};
 212 delete $HAS_HOOK::{STORABLE_thaw};
 213
 214 $t = thaw $f;
 215 is($HAS_HOOK::loaded_count, 2);
 216 is($HAS_HOOK::thawed_count, 2);
 217 isnt($t, undef);
 218 is(ref $t, 'HAS_HOOK');
 219
 220 {
 221     package STRESS_THE_STACK;
 222
 223     my $stress;
 224     sub make {
 225         bless [];
 226     }
 227
 228     sub no_op {
 229         0;
 230     }
 231
 232     sub STORABLE_freeze {
 233         my $self = shift;
 234         ++$freeze_count;
 235         return no_op(1..(++$stress * 2000)) ? die "can't happen" : '';
 236     }
 237
 238     sub STORABLE_thaw {
 239         my $self = shift;
 240         ++$thaw_count;
 241         no_op(1..(++$stress * 2000)) && die "can't happen";
 242         return;
 243     }
 244 }
 245
 246 $STRESS_THE_STACK::freeze_count = 0;
 247 $STRESS_THE_STACK::thaw_count = 0;
 248
 249 $f = freeze (STRESS_THE_STACK->make);
 250
 251 is($STRESS_THE_STACK::freeze_count, 1);
 252 is($STRESS_THE_STACK::thaw_count, 0);
 253
 254 $t = thaw $f;
 255 is($STRESS_THE_STACK::freeze_count, 1);
 256 is($STRESS_THE_STACK::thaw_count, 1);
 257 isnt($t, undef);
 258 is(ref $t, 'STRESS_THE_STACK');
 259
 260 my $file = "storable-testfile.$$";
 261 die "Temporary file '$file' already exists" if -e $file;
 262
 263 END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
 264
 265 $STRESS_THE_STACK::freeze_count = 0;
 266 $STRESS_THE_STACK::thaw_count = 0;
 267
 268 store (STRESS_THE_STACK->make, $file);
 269
 270 is($STRESS_THE_STACK::freeze_count, 1);
 271 is($STRESS_THE_STACK::thaw_count, 0);
 272
 273 $t = retrieve ($file);
 274 is($STRESS_THE_STACK::freeze_count, 1);
 275 is($STRESS_THE_STACK::thaw_count, 1);
 276 isnt($t, undef);
 277 is(ref $t, 'STRESS_THE_STACK');
 278
 279 {
 280     package ModifyARG112358;
 281     sub STORABLE_freeze { $_[0] = "foo"; }
 282     my $o= {str=>bless {}};
 283     my $f= ::freeze($o);
 284     ::is ref $o->{str}, __PACKAGE__,
 285         'assignment to $_[0] in STORABLE_freeze does not corrupt things';
 286 }
 287
 288 # [perl #113880]
 289 {
 290     {
 291         package WeirdRefHook;
 292         sub STORABLE_freeze { () }
 293         $INC{'WeirdRefHook.pm'} = __FILE__;
 294     }
 295
 296     for my $weird (keys %weird_refs) {
 297         my $obj = $weird_refs{$weird};
 298         bless $obj, 'WeirdRefHook';
 299         my $frozen;
 300         my $success = eval { $frozen = freeze($obj); 1 };
 301         ok($success, "can freeze $weird objects")
 302             || diag("freezing failed: $@");
 303         my $thawn = thaw($frozen);
 304         # is_deeply ignores blessings
 305         is ref $thawn, ref $obj, "get the right blessing back for $weird";
 306         if ($weird =~ 'VSTRING') {
 307             # It is not just Storable that did not support vstrings. :-)
 308             # See https://rt.cpan.org/Ticket/Display.html?id=78678
 309             my $newver = "version"->can("new")
 310                            ? sub { "version"->new(shift) }
 311                            : sub { "" };
 312             if (!ok
 313                   $$thawn eq $$obj && &$newver($$thawn) eq &$newver($$obj),
 314                  "get the right value back"
 315             ) {
 316                 diag "$$thawn vs $$obj";
 317                 diag &$newver($$thawn) eq &$newver($$obj) if &$newver(1);
 318              }
 319         }
 320         else {
 321             is_deeply($thawn, $obj, "get the right value back");
 322         }
 323     }
 324 }
 325
 326 {
 327     # [perl #118551]
 328     {
 329         package RT118551;
 330
 331         sub new {
 332             my $class = shift;
 333             my $string = shift;
 334             die 'Bad data' unless defined $string;
 335             my $self = { string => $string };
 336             return bless $self, $class;
 337         }
 338
 339         sub STORABLE_freeze {
 340             my $self = shift;
 341             my $cloning = shift;
 342             return if $cloning;
 343             return ($self->{string});
 344         }
 345
 346         sub STORABLE_attach {
 347             my $class = shift;
 348             my $cloning = shift;
 349             my $string = shift;
 350             return $class->new($string);
 351         }
 352     }
 353
 354     my $x = [ RT118551->new('a'), RT118551->new('') ];
 355
 356     $y = freeze($x);
 357
 358     ok(eval {thaw($y)}, "empty serialized") or diag $@; # <-- dies here with "Bad data"
 359 }
 360
 361 {
 362     {
 363         package FreezeHookDies;
 364         sub STORABLE_freeze {
 365             die ${$_[0]}
 366         }
 367
 368         package ThawHookDies;
 369         sub STORABLE_freeze {
 370             my ($self, $cloning) = @_;
 371             my $tmp = $$self;
 372             return "a", \$tmp;
 373         }
 374         sub STORABLE_thaw {
 375             my ($self, $cloning, $str, $obj) = @_;
 376             die $$obj;
 377         }
 378     }
 379     my $x = bless \(my $tmpx = "Foo"), "FreezeHookDies";
 380     my $y = bless \(my $tmpy = []), "FreezeHookDies";
 381
 382     ok(!eval { store($x, "store$$"); 1 }, "store of hook which throws no NL died");
 383     ok(!eval { store($y, "store$$"); 1 }, "store of hook which throws ref died");
 384
 385     ok(!eval { freeze($x); 1 }, "freeze of hook which throws no NL died");
 386     ok(!eval { freeze($y); 1 }, "freeze of hook which throws ref died");
 387
 388     ok(!eval { dclone($x); 1 }, "dclone of hook which throws no NL died");
 389     ok(!eval { dclone($y); 1 }, "dclone of hook which throws ref died");
 390
 391     my $ostr = bless \(my $tmpstr = "Foo"), "ThawHookDies";
 392     my $oref = bless \(my $tmpref = []), "ThawHookDies";
 393     ok(store($ostr, "store$$"), "save throw Foo on thaw");
 394     ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw Foo on thaw died");
 395     open FH, "<", "store$$" or die;
 396     binmode FH;
 397     ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw Foo on thaw died");
 398     ok(!ref $@, "right thing thrown");
 399     close FH;
 400     ok(store($oref, "store$$"), "save throw ref on thaw");
 401     ok(!eval { retrieve("store$$"); 1 }, "retrieve of throw ref on thaw died");
 402     open FH, "<", "store$$" or die;
 403     binmode FH;
 404     ok(!eval { fd_retrieve(*FH); 1 }, "fd_retrieve of throw [] on thaw died");
 405     ok(ref $@, "right thing thrown");
 406     close FH;
 407
 408     my $strdata = freeze($ostr);
 409     ok(!eval { thaw($strdata); 1 }, "thaw of throw Foo on thaw died");
 410     ok(!ref $@, "and a string thrown");
 411     my $refdata = freeze($oref);
 412     ok(!eval { thaw($refdata); 1 }, "thaw of throw [] on thaw died");
 413     ok(ref $@, "and a ref thrown");
 414
 415     unlink("store$$");
 416 }
 417
 418 {
 419     # trying to freeze a glob via STORABLE_freeze
 420     {
 421         package GlobHookedBase;
 422
 423         sub STORABLE_freeze {
 424             return \1;
 425         }
 426
 427         package GlobHooked;
 428         our @ISA = "GlobHookedBase";
 429     }
 430     use Symbol ();
 431     my $glob = bless Symbol::gensym(), "GlobHooked";
 432     eval {
 433         my $data = freeze($glob);
 434     };
 435     my $msg = $@;
 436     like($msg, qr/Unexpected object type \(GLOB\) of class 'GlobHooked' in store_hook\(\) calling GlobHookedBase::STORABLE_freeze/,
 437          "check we get the verbose message");
 438 }
 439
 440 SKIP:
 441 {
 442     $] < 5.012
 443       and skip "Can't assign regexps directly before 5.12", 4;
 444     my $hook_called;
 445     # store regexp via hook
 446     {
 447         package RegexpHooked;
 448         sub STORABLE_freeze {
 449             ++$hook_called;
 450             "$_[0]";
 451         }
 452         sub STORABLE_thaw {
 453             my ($obj, $cloning, $serialized) = @_;
 454             ++$hook_called;
 455             $$obj = ${ qr/$serialized/ };
 456         }
 457     }
 458
 459     my $obj = bless qr/abc/, "RegexpHooked";
 460     my $data = freeze($obj);
 461     ok($data, "froze regexp blessed into hooked class");
 462     ok($hook_called, "and the hook was actually called");
 463     $hook_called = 0;
 464     my $obj_thawed = thaw($data);
 465     ok($hook_called, "hook called for thaw");
 466     like("abc", $obj_thawed, "check the regexp");
 467 }