1=head1 NAME 2 3FreezeThaw - converting Perl structures to strings and back. 4 5=head1 SYNOPSIS 6 7 use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard); 8 $string = freeze $data1, $data2, $data3; 9 ... 10 ($olddata1, $olddata2, $olddata3) = thaw $string; 11 if (cmpStr($olddata2,$data2) == 0) {print "OK!"} 12 13=head1 DESCRIPTION 14 15Converts data to/from stringified form, appropriate for 16saving-to/reading-from permanent storage. 17 18Deals with objects, circular lists, repeated appearence of the same 19refence. Does not deal with overloaded I<stringify> operator yet. 20 21=head1 EXPORT 22 23=over 12 24 25=item Default 26 27None. 28 29=item Exportable 30 31C<freeze thaw cmpStr cmpStrHard safeFreeze>. 32 33=back 34 35=head1 User API 36 37=over 12 38 39=item C<cmpStr> 40 41analogue of C<cmp> for data. Takes two arguments and compares them as 42separate entities. 43 44=item C<cmpStrHard> 45 46analogue of C<cmp> for data. Takes two arguments and compares them 47considered as a group. 48 49=item C<freeze> 50 51returns a string that encupsulates its arguments (considered as a 52group). C<thaw>ing this string leads to a fatal error if arguments to 53C<freeze> contained references to C<GLOB>s and C<CODE>s. 54 55=item C<safeFreeze> 56 57returns a string that encupsulates its arguments (considered as a 58group). The result is C<thaw>able in the same process. C<thaw>ing the 59result in a different process should result in a fatal error if 60arguments to C<safeFreeze> contained references to C<GLOB>s and 61C<CODE>s. 62 63=item C<thaw> 64 65takes one string argument and returns an array. The elements of the 66array are "equivalent" to arguments of the C<freeze> command that 67created the string. Can result in a fatal error (see above). 68 69=back 70 71=head1 Developer API 72 73C<FreezeThaw> C<freeze>s and C<thaw>s data blessed in some package by 74calling methods C<Freeze> and C<Thaw> in the package. The fallback 75methods are provided by the C<FreezeThaw> itself. The fallback 76C<Freeze> freezes the "content" of blessed object (from Perl point of 77view). The fallback C<Thaw> blesses the C<thaw>ed data back into the package. 78 79So the package needs to define its own methods only if the fallback 80methods will fail (for example, for a lot of data the "content" of an 81object is an address of some B<C> data). The methods are called like 82 83 $newcooky = $obj->Freeze($cooky); 84 $obj = Package->Thaw($content,$cooky); 85 86To save and restore the data the following method are applicable: 87 88 $cooky->FreezeScalar($data,$ignorePackage,$noduplicate); 89 90during Freeze()ing, and 91 92 $data = $cooky->ThawScalar; 93 94Two optional arguments $ignorePackage and $noduplicate regulate 95whether the freezing should not call the methods even if $data is a 96reference to a blessed object, and whether the data should not be 97marked as seen already even if it was seen before. The default methods 98 99 sub UNIVERSAL::Freeze { 100 my ($obj, $cooky) = (shift, shift); 101 $cooky->FreezeScalar($obj,1,1); 102 } 103 104 sub UNIVERSAL::Thaw { 105 my ($package, $cooky) = (shift, shift); 106 my $obj = $cooky->ThawScalar; 107 bless $obj, $package; 108 } 109 110call the C<FreezeScalar> method of the $cooky since the freezing 111engine will see the data the second time during this call. Indeed, it 112is the freezing engine who calls UNIVERSAL::Freeze(), and it calls it 113because it needs to freeze $obj. The above call to 114$cooky->FreezeScalar() handles the same data back to engine, but 115because flags are different, the code does not cycle. 116 117Freezing and thawing $cooky also allows the following additional methods: 118 119 $cooky->isSafe; 120 121to find out whether the current freeze was initiated by C<freeze> or 122C<safeFreeze> command. Analogous method for thaw $cooky returns 123whether the current thaw operation is considered safe (i.e., either 124does not contain cached elsewhere data, or comes from the same 125application). You can use 126 127 $cooky->makeSafe; 128 129to prohibit cached data for the duration of the rest of freezing or 130thawing of current object. 131 132Two methods 133 134 $value = $cooky->repeatedOK; 135 $cooky->noRepeated; # Now repeated are prohibited 136 137allow to find out/change the current setting for allowing repeated 138references. 139 140If you want to flush the cache of saved objects you can use 141 142 FreezeThaw->flushCache; 143 144this can invalidate some frozen string, so that thawing them will 145result in fatal error. 146 147=head2 Instantiating 148 149Sometimes, when an object from a package is recreated in presense of 150repeated references, it is not safe to recreate the internal structure 151of an object in one step. In such a situation recreation of an object 152is carried out in two steps: in the first the object is C<allocate>d, 153in the second it is C<instantiate>d. 154 155The restriction is that during the I<allocation> step you cannot use any 156reference to any Perl object that can be referenced from any other 157place. This restriction is applied since that object may not exist yet. 158 159Correspondingly, during I<instantiation> step the previosly I<allocated> 160object should be C<filled>, i.e., it can be changed in any way such 161that the references to this object remain valid. 162 163The methods are called like this: 164 165 $pre_object_ref = Package->Allocate($pre_pre_object_ref); 166 # Returns reference 167 Package->Instantiate($pre_object_ref,$cooky); 168 # Converts into reference to blessed object 169 170The reverse operations are 171 172 $object_ref->FreezeEmpty($cooky); 173 $object_ref->FreezeInstance($cooky); 174 175during these calls object can C<freezeScalar> some information (in a 176usual way) that will be used during C<Allocate> and C<Instantiate> 177calls (via C<thawScalar>). Note that the return value of 178C<FreezeEmpty> is cached during the phase of creation of uninialized 179objects. This B<must> be used like this: the return value is the 180reference to the created object, so it is not destructed until other 181objects are created, thus the frozen values of the different objects 182will not share the same references. Example of bad result: 183 184 $o1->FreezeEmpty($cooky) 185 186freezes C<{}>, and C<$o2-E<gt>FreezeEmpty($cooky)> makes the same. Now 187nobody guaranties that that these two copies of C<{}> are different, 188unless a reference to the first one is preserved during the call to 189C<$o2-E<gt>FreezeEmpty($cooky)>. If C<$o1-E<gt>FreezeEmpty($cooky)> 190returns the value of C<{}> it uses, it will be preserved by the 191engine. 192 193The helper function C<FreezeThaw::copyContents> is provided for 194simplification of instantiation. The syntax is 195 196 FreezeThaw::copyContents $to, $from; 197 198The function copies contents the object $from point to into what the 199object $to points to (including package for blessed references). Both 200arguments should be references. 201 202The default methods are provided. They do the following: 203 204=over 12 205 206=item C<FreezeEmpty> 207 208Freezes an I<empty> object of underlying type. 209 210=item C<FreezeInstance> 211 212Calls C<Freeze>. 213 214=item C<Allocate> 215 216Thaws what was frozen by C<FreezeEmpty>. 217 218=item C<Instantiate> 219 220Thaws what was frozen by C<FreezeInstance>, uses C<copyContents> to 221transfer this to the $pre_object. 222 223=back 224 225=head1 BUGS and LIMITATIONS 226 227A lot of objects are blessed in some obscure packages by XSUB 228typemaps. It is not clear how to (automatically) prevent the 229C<UNIVERSAL> methods to be called for objects in these packages. 230 231The objects which can survive freeze()/thaw() cycle must also survive a 232change of a "member" to an equal member. Say, after 233 234 $a = [a => 3]; 235 $a->{b} = \ $a->{a}; 236 237$a satisfies 238 239 $a->{b} == \ $a->{a} 240 241This property will be broken by freeze()/thaw(), but it is also broken by 242 243 $a->{a} = delete $a->{a}; 244 245=cut 246 247require 5.002; # defined ref stuff... 248 249# Different line noise chars: 250# 251# $567| next 567 chars form a scalar 252# 253# @34| next 34 scalars form an array 254# 255# %34| next 34 scalars form a hash 256# 257# ? next scalar is a safe-stamp at beginning 258# 259# ? next scalar is a stringified data 260# 261# ! repeated array follows (after a scalar denoting array $#), 262# (possibly?) followed by instantiation array. At beginning 263# 264# <45| ordinal of element in repeated array 265# 266# * stringified glob follows 267# 268# & stringified coderef follows 269# 270# \\ stringified defererenced data follows 271# 272# / stringified REx follows 273# 274# > stringified package name follows, then frozen data 275# 276# { stringified package name follows, then allocation data 277# 278# } stringified package name follows, then instantiation data 279# 280# _ frozen form of undef 281 282 283package FreezeThaw; 284 285use Exporter; 286 287@ISA = qw(Exporter); 288$VERSION = '0.5001'; 289@EXPORT_OK = qw(freeze thaw cmpStr cmpStrHard safeFreeze); 290 291use strict; 292use Carp; 293 294my $lock = (reverse time) ^ $$ ^ \&freezeString; # To distingush processes 295 296use vars qw( @multiple 297 %seen_packages 298 $seen_packages 299 %seen_packages 300 %count 301 %address 302 $string 303 $unsafe 304 $noCache 305 $cooky 306 $secondpass 307 ), # Localized in freeze() 308 qw( $norepeated ), # Localized in freezeScalar() 309 qw( $uninitOK ), # Localized in thawScalar() 310 qw( @uninit ), # Localized in thaw() 311 qw($safe); # Localized in safeFreeze() 312 313BEGIN { # allow optimization away 314 my $haveIsRex = defined &re::is_regexp; 315 my $RexIsREGEXP = ($haveIsRex and # 'REGEXP' eq ref qr/1/); # First-class REX 316 $] >= 5.011); # Code like above requires Scalar::Utils::reftype 317 eval <<EOE or die; 318sub haveIsRex () {$haveIsRex} 319sub RexIsREGEXP () {$RexIsREGEXP} 3201 321EOE 322} 323 324my (%saved); 325 326my %Empty = ( ARRAY => sub {[]}, HASH => sub {{}}, 327 SCALAR => sub {my $undef; \$undef}, 328 REF => sub {my $undef; \$undef}, 329 CODE => 1, # 1 means atomic 330 GLOB => 1, 331 (RexIsREGEXP 332 ? (Regexp => sub {my $qr = qr//}) 333 : (Regexp => 0)), 334 ); 335 336# This should better be done via pos() and \G, but apparently \G is not 337# optimized (bug in the REx optimizer???) 338BEGIN { 339 my $pointer_size = length pack 'p', 0; 340 #my $max_dig0 = 3*$pointer_size; # 8bits take less than 3 decimals 341 # Now calculate the exact value: 342 #my $max_pointer = sprintf "%.${max_dig0}g", 0x100**$pointer_size; 343 my $max_pointer = sprintf "%.0f", 0x100**$pointer_size; 344 die "Panic" if $max_pointer =~ /\D/; 345 my $max_pointer_l = length $max_pointer; 346 warn "Max pointer_l=$max_pointer_l" if $ENV{FREEZE_THAW_WARN}; 347 eval "sub max_strlen_l () {$max_pointer_l}; 1" or die; 348} 349 350sub flushCache {$lock ^= rand; undef %saved;} 351 352sub getref ($) { 353 my $ref = ref $_[0]; 354 return $ref if not $ref or defined $Empty{$ref}; # Optimization _and_ Regexp 355 my $str; 356 if (defined &overload::StrVal) { 357 $str = overload::StrVal($_[0]); 358 } else { 359 $str = "$_[0]"; 360 } 361 $ref = $1 if $str =~ /=(\w+)/; 362 $ref; 363} 364 365sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]} 366 367sub freezeNumber {$string .= $_[0] . '|'} 368 369sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]} 370 371sub thawString { # Returns list: a string and offset of rest 372 substr($string, $_[0], 2+max_strlen_l) =~ /^\$(\d+)\|/ 373 or confess "Wrong format of frozen string: " . substr($string, $_[0]); 374 length($string) - $_[0] > length($1) + 1 + $1 375 or confess "Frozen string too short: `" . 376 substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1); 377 (substr($string, $_[0] + length($1) + 2, $1), $_[0] + length($1) + 2 + $1); 378} 379 380sub thawNumber { # Returns list: a number and offset of rest 381 substr($string, $_[0], 1+max_strlen_l) =~ /^(\d+)\|/ 382 or confess "Wrong format of frozen string: " . substr($string, $_[0]); 383 ($1, $_[0] + length($1) + 1); 384} 385 386sub _2rex ($); 387if (eval 'ref qr/1/') { 388 eval 'sub _2rex ($) {my $r = shift; qr/$r/} 1' or die; 389} else { 390 eval 'sub _2rex ($) { shift } 1' or die; 391} 392 393sub thawREx { # Returns list: a REx and offset of rest 394 substr($string, $_[0], 2+max_strlen_l) =~ m,^/(\d+)\|, 395 or confess "Wrong format of frozen REx: " . substr($string, $_[0]); 396 length($string) - $_[0] > length($1) + 1 + $1 397 or confess "Frozen string too short: `" . 398 substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1); 399 (_2rex substr($string, $_[0] + length($1) + 2, $1), 400 $_[0] + length($1) + 2 + $1); 401} 402 403sub freezeArray { 404 $string .= '@' . @{$_[0]} . '|'; 405 for (@{$_[0]}) { 406 freezeScalar($_); 407 } 408} 409 410sub thawArray { 411 substr($string, $_[0], 2+max_strlen_l) =~ /^[\@%](\d+)\|/ # % To make it possible thaw hashes 412 or confess "Wrong format of frozen array: \n$_[0]"; 413 my $count = $1; 414 my $off = $_[0] + 2 + length $count; 415 my (@res, $res); 416 while ($count and length $string > $off) { 417 ($res,$off) = thawScalar($off); 418 push(@res,$res); 419 --$count; 420 } 421 confess "Wrong length of data in thawing Array: $count left" if $count; 422 (\@res, $off); 423} 424 425sub freezeHash { 426 my @arr = sort keys %{$_[0]}; 427 $string .= '%' . (2*@arr) . '|'; 428 for (@arr, @{$_[0]}{@arr}) { 429 freezeScalar($_); 430 } 431} 432 433sub thawHash { 434 my ($arr, $rest) = &thawArray; 435 my %hash; 436 my $l = @$arr/2; 437 foreach (0 .. $l - 1) { 438 $hash{$arr->[$_]} = $arr->[$l + $_]; 439 } 440 (\%hash,$rest); 441} 442 443# Second optional argument: ignore the package 444# Third optional one: do not check for duplicates on outer level 445 446sub freezeScalar { 447 $string .= '_', return unless defined $_[0]; 448 return &freezeString unless ref $_[0]; 449 my $ref = ref $_[0]; 450 my $str; 451 if ($_[1] and $ref) { # Similar to getref() 452 if (defined &overload::StrVal) { 453 $str = overload::StrVal($_[0]); 454 } else { 455 $str = "$_[0]"; 456 } 457 $ref = $1 if $str =~ /=(\w+)/; 458 } else { 459 $str = "$_[0]"; 460 } 461 # Die if a) repeated prohibited, b) met, c) not explicitely requested to ingore. 462 confess "Repeated reference met when prohibited" 463 if $norepeated && !$_[2] && defined $count{$str}; 464 if ($secondpass and !$_[2]) { 465 $string .= "<$address{$str}|", return 466 if defined $count{$str} and $count{$str} > 1; 467 } elsif (!$_[2]) { 468 # $count{$str} is defined if we have seen it on this pass. 469 $address{$str} = @multiple, push(@multiple, $_[0]) 470 if defined $count{$str} and not exists $address{$str}; 471 # This is for debugging and shortening thrown-away output (also 472 # internal data in arrays and hashes is not duplicated). 473 $string .= "<$address{$str}|", ++$count{$str}, return 474 if defined $count{$str}; 475 ++$count{$str}; 476 } 477 return &freezeArray if $ref eq 'ARRAY'; 478 return &freezeHash if $ref eq 'HASH'; 479 return &freezeREx if haveIsRex ? re::is_regexp($_[0]) 480 : ($ref eq 'Regexp' and not defined ${$_[0]}); 481 $string .= "*", return &freezeString 482 if $ref eq 'GLOB' and !$safe; 483 $string .= "&", return &freezeString 484 if $ref eq 'CODE' and !$safe; 485 $string .= '\\', return &freezeScalar( $ {shift()} ) 486 if $ref eq 'REF' or $ref eq 'SCALAR'; 487 if ($noCache and (($ref eq 'CODE') or $ref eq 'GLOB')) { 488 confess "CODE and GLOB references prohibited now"; 489 } 490 if ($safe and (($ref eq 'CODE') or $ref eq 'GLOB')) { 491 $unsafe = 1; 492 $saved{$str} = $_[0] unless defined $saved{$str}; 493 $string .= "?"; 494 return &freezeString; 495 } 496 $string .= '>'; 497 local $norepeated = $norepeated; 498 local $noCache = $noCache; 499 freezePackage(ref $_[0]); 500 $_[0]->Freeze($cooky); 501} 502 503sub freezePackage { 504 my $packageid = $seen_packages{$_[0]}; 505 if (defined $packageid) { 506 $string .= ')'; 507 &freezeNumber( $packageid ); 508 } else { 509 $string .= '>'; 510 &freezeNumber( $seen_packages ); 511 &freezeScalar( $_[0] ); 512 $seen_packages{ $_[0] } = $seen_packages++; 513 } 514} 515 516sub thawPackage { # First argument: offset 517 my $key = substr($string,$_[0],1); 518 my ($get, $rest, $id); 519 ($id, $rest) = &thawNumber($_[0] + 1); 520 if ($key eq ')') { 521 $get = $seen_packages{$id}; 522 } else { 523 ($get, $rest) = &thawString($rest); 524 $seen_packages{$id} = $get; 525 } 526 ($get, $rest); 527} 528 529# First argument: offset; Optional other: index in the @uninit array 530 531sub thawScalar { 532 my $key = substr($string,$_[0],1); 533 if ($key eq "\$") {&thawString} 534 elsif ($key eq '@') {&thawArray} 535 elsif ($key eq '%') {&thawHash} 536 elsif ($key eq '/') {&thawREx} 537 elsif ($key eq '\\') { 538 my ($out,$rest) = &thawScalar( $_[0]+1 ) ; 539 (\$out,$rest); 540 } 541 elsif ($key eq '_') { (undef, $_[0]+1) } 542 elsif ($key eq '&') {confess "Do not know how to thaw CODE"} 543 elsif ($key eq '*') {confess "Do not know how to thaw GLOB"} 544 elsif ($key eq '?') { 545 my ($address,$rest) = &thawScalar( $_[0]+1 ) ; 546 confess "The saved data accessed in unprotected thaw" unless $unsafe; 547 confess "The saved data disappeared somewhere" 548 unless defined $saved{$address}; 549 ($saved{$address},$rest); 550 } elsif ($key eq '<') { 551 confess "Repeated data prohibited at this moment" unless $uninitOK; 552 my ($off,$end) = &thawNumber ($_[0]+1); 553 ($uninit[$off],$end); 554 } elsif ($key eq '>' or $key eq '{' or $key eq '}') { 555 my ($package,$rest) = &thawPackage( $_[0]+1 ); 556 my $cooky = bless \$rest, 'FreezeThaw::TCooky'; 557 local $uninitOK = $uninitOK; 558 local $unsafe = $unsafe; 559 if ($key eq '{') { 560 my $res = $package->Allocate($cooky); 561 ($res, $rest); 562 } elsif ($key eq '}') { 563 warn "Here it is undef!" unless defined $_[1]; 564 $package->Instantiate($uninit[$_[1]],$cooky); 565 (undef, $rest); 566 } else { 567 ($package->Thaw($cooky),$rest); 568 } 569 } else { 570 confess "Do not know how to thaw data with code `$key'"; 571 } 572} 573 574sub freezeEmpty { # Takes a type, freezes ref to empty object 575 my $e = $Empty{ref $_[0]}; 576 if (ref $e) { 577 my $cache = &$e; 578 freezeScalar $cache; 579 $cache; 580 } elsif ($e) { 581 my $cache = shift; 582 freezeScalar($cache,1,1); # Atomic 583 $cache; 584 } else { 585 $string .= "{"; 586 freezePackage ref $_[0]; 587 $_[0]->FreezeEmpty($cooky); 588 } 589} 590 591sub freeze { 592 local @multiple; 593 local %seen_packages; 594 local $seen_packages = 0; 595 local %seen_packages; 596# local @seentypes; 597 local %count; 598 local %address; 599 local $string = 'FrT;'; 600 local $unsafe; 601 local $noCache; 602 local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake 603 local $secondpass; 604 freezeScalar(\@_); 605 if (@multiple) { 606 # Now repeated structures are enumerated with order of *second* time 607 # they appear in the what we freeze. 608 # What we want is to have them enumerated with respect to the first time 609#### $string = ''; # Start again 610#### @multiple = (); 611#### %address = (); 612#### for (keys %count) { 613#### $count{$_} = undef if $count{$_} <= 1; # As at start 614#### $count{$_} = 0 if $count{$_}; # As at start 615#### } 616#### $seen_packages = 0; 617#### %seen_packages = (); 618#### freezeScalar(\@_); 619 # Now repeated structures are enumerated with order of first time 620 # they appear in the what we freeze 621#### my $oldstring = substr $string, 4; 622 $string = 'FrT;!'; # Start again 623 $seen_packages = 0; 624 %seen_packages = (); # XXXX We reshuffle parts of the 625 # string, so the order of packages may 626 # be wrong... 627 freezeNumber($#multiple); 628 { 629 my @cache; # Force different values for different 630 # empty objects. 631 foreach (@multiple) { 632 push @cache, freezeEmpty $_; 633 } 634 } 635# for (keys %count) { 636# $count{$_} = undef 637# if !(defined $count{$_}) or $count{$_} <= 1; # As at start 638# } 639 # $string .= '@' . @multiple . '|'; 640 $secondpass = 1; 641 for (@multiple) { 642 freezeScalar($_,0,1,1), next if $Empty{ref $_}; 643 $string .= "}"; 644 freezePackage ref $_; 645 $_->FreezeInstance($cooky); 646 } 647#### $string .= $oldstring; 648 freezeScalar(\@_); 649 } 650 return "FrT;?\$" . length($lock) . "|" . $lock . substr $string, 4 651 if $unsafe; 652 $string; 653} 654 655sub safeFreeze { 656 local $safe = 1; 657 &freeze; 658} 659 660sub copyContents { # Given two references, copies contents of the 661 # second one to the first one, provided they have 662 # the same basic type. The package is copied too. 663 my($first,$second) = @_; 664 my $ref = getref $second; 665 if ($ref eq 'SCALAR' or $ref eq 'REF') { 666 $$first = $$second; 667 } elsif ($ref eq 'ARRAY') { 668 @$first = @$second; 669 } elsif ($ref eq 'HASH') { 670 %$first = %$second; 671 } elsif (haveIsRex ? re::is_regexp($second) 672 : ($ref eq 'Regexp' and not defined $$second)) { 673 $first = qr/$second/; 674 } else { 675 croak "Don't know how to copyContents of type `$ref'"; 676 } 677 if (ref $second ne ref $first) { # Rebless 678 # SvAMAGIC() is a property of a reference, not of a referent! 679 # Thus we cannot use $first here if $second was overloaded... 680 bless $_[0], ref $second; 681 } 682 $first; 683} 684 685sub thaw { 686 confess "thaw requires one argument" unless @_ ==1; 687 local $string = shift; 688 local %seen_packages; 689 my $initoff = 0; 690 #print STDERR "Thawing `$string'", substr ($string, 0, 4), "\n"; 691 if (substr($string, 0, 4) ne 'FrT;') { 692 warn "Signature not present, continuing anyway" if $^W; 693 } else { 694 $initoff = 4; 695 } 696 local $unsafe = $initoff + (substr($string, $initoff, 1) eq "?" ? 1 : 0); 697 if ($unsafe != $initoff) { 698 my $key; 699 ($key,$unsafe) = thawScalar($unsafe); 700 confess "The lock in frozen data does not match the key" 701 unless $key eq $lock; 702 } 703 local @multiple; 704 local $uninitOK = 1; # The methods can change it. 705 my $repeated = substr($string,$unsafe,1) eq '!' ? 1 : 0; 706 my ($res, $off); 707 if ($repeated) { 708 ($res, $off) = thawNumber($repeated + $unsafe); 709 } else { 710 ($res, $off) = thawScalar($repeated + $unsafe); 711 } 712 my $cooky = bless \$off, 'FreezeThaw::TCooky'; 713 if ($repeated) { 714 local @uninit; 715 my $lst = $res; 716 foreach (0..$lst) { 717 ($res, $off) = thawScalar($off, $_); 718 push(@uninit, $res); 719 } 720 my @init; 721 foreach (0..$lst) { 722 ($res, $off) = thawScalar($off, $_); 723 push(@init, $res); 724 } 725 #($init, $off) = thawScalar($off); 726 #print "Instantiating...\n"; 727 #my $ref; 728 for (0..$#uninit) { 729 copyContents $uninit[$_], $init[$_] if ref $init[$_]; 730 } 731 ($res, $off) = thawScalar($off); 732 } 733 croak "Extra elements in frozen structure: `" . substr($string,$off) . "'" 734 if $off != length $string; 735 return @$res; 736} 737 738sub cmpStr { 739 confess "Compare requires two arguments" unless @_ == 2; 740 freeze(shift) cmp freeze(shift); 741} 742 743sub cmpStrHard { 744 confess "Compare requires two arguments" unless @_ == 2; 745 local @multiple; 746# local @seentypes; 747 local %count; 748 local %address; 749 local $string = 'FrT;'; 750 local $unsafe; 751 local $noCache; 752 local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake 753 freezeScalar($_[0]); 754 my %cnt1 = %count; 755 freezeScalar($_[1]); 756 my %cnt2 = %count; 757 %count = (); 758 # Now all the caches are filled, delete the entries for guys which 759 # are in one argument only. 760 my ($elt, $val); 761 while (($elt, $val) = each %cnt1) { 762 $count{$elt}++ if $cnt2{$elt} > $cnt1{$elt}; 763 } 764 $string = ''; 765 freezeScalar($_[0]); 766 my $str1 = $string; 767 $string = ''; 768 freezeScalar($_[1]); 769 $str1 cmp $string; 770} 771 772# local $string = freeze(shift,shift); 773# local $uninitOK = 1; 774# #print "$string\n"; 775# my $off = 7; # Hardwired offset after @2| 776# if (substr($string,4,1) eq '!') { 777# $off = 5; # Hardwired offset after ! 778# my ($uninit, $len); 779# ($len,$off) = thawScalar $off; 780# local @uninit; 781# foreach (0..$len) { 782# ($uninit,$off) = thawScalar $off, $_; 783# } 784# $off += 3; # Hardwired offset after @2| 785# } 786# croak "Unknown format of frozen array: " . substr($string,$off-3) 787# unless substr($string,$off-3,1) eq '@'; 788# my ($first,$off2) = thawScalar $off; 789# my $off3; 790# ($first,$off3) = thawScalar $off2; 791# substr($string, $off, $off2-$off) cmp substr($string,$off2,$off3-$off2); 792# } 793 794sub FreezeThaw::FCooky::FreezeScalar { 795 shift; 796 &freezeScalar; 797} 798 799sub FreezeThaw::FCooky::isSafe { 800 $safe || $noCache; 801} 802 803sub FreezeThaw::FCooky::makeSafe { 804 $noCache = 1; 805} 806 807sub FreezeThaw::FCooky::repeatedOK { 808 !$norepeated; 809} 810 811sub FreezeThaw::FCooky::noRepeated { 812 $norepeated = 1; 813} 814 815sub FreezeThaw::TCooky::repeatedOK { 816 $uninitOK; 817} 818 819sub FreezeThaw::TCooky::noRepeated { 820 undef $uninitOK; 821} 822 823sub FreezeThaw::TCooky::isSafe { 824 !$unsafe; 825} 826 827sub FreezeThaw::TCooky::makeSafe { 828 undef $unsafe; 829} 830 831sub FreezeThaw::TCooky::ThawScalar { 832 my $self = shift; 833 my ($res,$off) = &thawScalar($$self); 834 $$self = $off; 835 $res; 836} 837 838sub UNIVERSAL::Freeze { 839 my ($obj, $cooky) = (shift, shift); 840 $cooky->FreezeScalar($obj,1,1); 841} 842 843sub UNIVERSAL::Thaw { 844 my ($package, $cooky) = (shift, shift); 845 my $obj = $cooky->ThawScalar; 846 bless $obj, $package; 847} 848 849sub UNIVERSAL::FreezeInstance { 850 my($obj,$cooky) = @_; 851 return if !RexIsREGEXP # Special-case non-1st-class RExes 852 and ref $obj and (haveIsRex ? re::is_regexp($obj) 853 : (ref $obj eq 'Regexp' and not defined $$obj)); # Regexp 854 $obj->Freeze($cooky); 855} 856 857sub UNIVERSAL::Instantiate { 858 my($package,$pre,$cooky) = @_; 859 return if !RexIsREGEXP and $package eq 'Regexp'; 860 my $obj = $package->Thaw($cooky); 861 # SvAMAGIC() is a property of a reference, not of a referent! 862 # Thus we cannot use $pre here if $obj was overloaded... 863 copyContents $_[1], $obj; 864} 865 866sub UNIVERSAL::Allocate { 867 my($package,$cooky) = @_; 868 $cooky->ThawScalar; 869} 870 871sub UNIVERSAL::FreezeEmpty { 872 my $obj = shift; 873 my $type = getref $obj; 874 my $e = $Empty{$type}; 875 if (ref $e) { 876 my $ref = &$e; 877 freezeScalar $ref; 878 $ref; # Put into cache. 879 } elsif ($e) { 880 freezeScalar($obj,1,1); # Atomic 881 undef; 882 } elsif (!RexIsREGEXP and defined $e and not defined $$obj) { # REx pre-5.11 883 freezeREx($obj); 884 undef; 885 } else { 886 die "Do not know how to FreezeEmpty $type"; 887 } 888} 889 8901; 891