3 FreezeThaw - converting Perl structures to strings and back.
7 use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
8 $string = freeze $data1, $data2, $data3;
10 ($olddata1, $olddata2, $olddata3) = thaw $string;
11 if (cmpStr($olddata2,$data2) == 0) {print "OK!"}
15 Converts data to/from stringified form, appropriate for
16 saving-to/reading-from permanent storage.
18 Deals with objects, circular lists, repeated appearence of the same
19 refence. Does not deal with overloaded I<stringify> operator yet.
31 C<freeze thaw cmpStr cmpStrHard safeFreeze>.
41 analogue of C<cmp> for data. Takes two arguments and compares them as
46 analogue of C<cmp> for data. Takes two arguments and compares them
47 considered as a group.
51 returns a string that encupsulates its arguments (considered as a
52 group). C<thaw>ing this string leads to a fatal error if arguments to
53 C<freeze> contained references to C<GLOB>s and C<CODE>s.
57 returns a string that encupsulates its arguments (considered as a
58 group). The result is C<thaw>able in the same process. C<thaw>ing the
59 result in a different process should result in a fatal error if
60 arguments to C<safeFreeze> contained references to C<GLOB>s and
65 takes one string argument and returns an array. The elements of the
66 array are "equivalent" to arguments of the C<freeze> command that
67 created the string. Can result in a fatal error (see above).
73 C<FreezeThaw> C<freeze>s and C<thaw>s data blessed in some package by
74 calling methods C<Freeze> and C<Thaw> in the package. The fallback
75 methods are provided by the C<FreezeThaw> itself. The fallback
76 C<Freeze> freezes the "content" of blessed object (from Perl point of
77 view). The fallback C<Thaw> blesses the C<thaw>ed data back into the package.
79 So the package needs to define its own methods only if the fallback
80 methods will fail (for example, for a lot of data the "content" of an
81 object is an address of some B<C> data). The methods are called like
83 $newcooky = $obj->Freeze($cooky);
84 $obj = Package->Thaw($content,$cooky);
86 To save and restore the data the following method are applicable:
88 $cooky->FreezeScalar($data,$ignorePackage,$noduplicate);
90 during Freeze()ing, and
92 $data = $cooky->ThawScalar;
94 Two optional arguments $ignorePackage and $noduplicate regulate
95 whether the freezing should not call the methods even if $data is a
96 reference to a blessed object, and whether the data should not be
97 marked as seen already even if it was seen before. The default methods
99 sub UNIVERSAL::Freeze {
100 my ($obj, $cooky) = (shift, shift);
101 $cooky->FreezeScalar($obj,1,1);
104 sub UNIVERSAL::Thaw {
105 my ($package, $cooky) = (shift, shift);
106 my $obj = $cooky->ThawScalar;
107 bless $obj, $package;
110 call the C<FreezeScalar> method of the $cooky since the freezing
111 engine will see the data the second time during this call. Indeed, it
112 is the freezing engine who calls UNIVERSAL::Freeze(), and it calls it
113 because it needs to freeze $obj. The above call to
114 $cooky->FreezeScalar() handles the same data back to engine, but
115 because flags are different, the code does not cycle.
117 Freezing and thawing $cooky also allows the following additional methods:
121 to find out whether the current freeze was initiated by C<freeze> or
122 C<safeFreeze> command. Analogous method for thaw $cooky returns
123 whether the current thaw operation is considered safe (i.e., either
124 does not contain cached elsewhere data, or comes from the same
125 application). You can use
129 to prohibit cached data for the duration of the rest of freezing or
130 thawing of current object.
134 $value = $cooky->repeatedOK;
135 $cooky->noRepeated; # Now repeated are prohibited
137 allow to find out/change the current setting for allowing repeated
140 If you want to flush the cache of saved objects you can use
142 FreezeThaw->flushCache;
144 this can invalidate some frozen string, so that thawing them will
145 result in fatal error.
149 Sometimes, when an object from a package is recreated in presense of
150 repeated references, it is not safe to recreate the internal structure
151 of an object in one step. In such a situation recreation of an object
152 is carried out in two steps: in the first the object is C<allocate>d,
153 in the second it is C<instantiate>d.
155 The restriction is that during the I<allocation> step you cannot use any
156 reference to any Perl object that can be referenced from any other
157 place. This restriction is applied since that object may not exist yet.
159 Correspondingly, during I<instantiation> step the previosly I<allocated>
160 object should be C<filled>, i.e., it can be changed in any way such
161 that the references to this object remain valid.
163 The methods are called like this:
165 $pre_object_ref = Package->Allocate($pre_pre_object_ref);
167 Package->Instantiate($pre_object_ref,$cooky);
168 # Converts into reference to blessed object
170 The reverse operations are
172 $object_ref->FreezeEmpty($cooky);
173 $object_ref->FreezeInstance($cooky);
175 during these calls object can C<freezeScalar> some information (in a
176 usual way) that will be used during C<Allocate> and C<Instantiate>
177 calls (via C<thawScalar>). Note that the return value of
178 C<FreezeEmpty> is cached during the phase of creation of uninialized
179 objects. This B<must> be used like this: the return value is the
180 reference to the created object, so it is not destructed until other
181 objects are created, thus the frozen values of the different objects
182 will not share the same references. Example of bad result:
184 $o1->FreezeEmpty($cooky)
186 freezes C<{}>, and C<$o2-E<gt>FreezeEmpty($cooky)> makes the same. Now
187 nobody guaranties that that these two copies of C<{}> are different,
188 unless a reference to the first one is preserved during the call to
189 C<$o2-E<gt>FreezeEmpty($cooky)>. If C<$o1-E<gt>FreezeEmpty($cooky)>
190 returns the value of C<{}> it uses, it will be preserved by the
193 The helper function C<FreezeThaw::copyContents> is provided for
194 simplification of instantiation. The syntax is
196 FreezeThaw::copyContents $to, $from;
198 The function copies contents the object $from point to into what the
199 object $to points to (including package for blessed references). Both
200 arguments should be references.
202 The default methods are provided. They do the following:
208 Freezes an I<empty> object of underlying type.
210 =item C<FreezeInstance>
216 Thaws what was frozen by C<FreezeEmpty>.
220 Thaws what was frozen by C<FreezeInstance>, uses C<copyContents> to
221 transfer this to the $pre_object.
225 =head1 BUGS and LIMITATIONS
227 A lot of objects are blessed in some obscure packages by XSUB
228 typemaps. It is not clear how to (automatically) prevent the
229 C<UNIVERSAL> methods to be called for objects in these packages.
231 The objects which can survive freeze()/thaw() cycle must also survive a
232 change of a "member" to an equal member. Say, after
241 This property will be broken by freeze()/thaw(), but it is also broken by
243 $a->{a} = delete $a->{a};
247 require 5.002; # defined ref stuff...
249 # Different line noise chars:
251 # $567| next 567 chars form a scalar
253 # @34| next 34 scalars form an array
255 # %34| next 34 scalars form a hash
257 # ? next scalar is a safe-stamp at beginning
259 # ? next scalar is a stringified data
261 # ! repeated array follows (after a scalar denoting array $#),
262 # (possibly?) followed by instantiation array. At beginning
264 # <45| ordinal of element in repeated array
266 # * stringified glob follows
268 # & stringified coderef follows
270 # \\ stringified defererenced data follows
272 # / stringified REx follows
274 # > stringified package name follows, then frozen data
276 # { stringified package name follows, then allocation data
278 # } stringified package name follows, then instantiation data
280 # _ frozen form of undef
289 @EXPORT_OK = qw(freeze thaw cmpStr cmpStrHard safeFreeze);
294 my $lock = (reverse time) ^ $$ ^ \&freezeString; # To distingush processes
296 use vars qw( @multiple
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()
313 BEGIN { # 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
318 sub haveIsRex () {$haveIsRex}
319 sub RexIsREGEXP () {$RexIsREGEXP}
326 my %Empty = ( ARRAY => sub {[]}, HASH => sub {{}},
327 SCALAR => sub {my $undef; \$undef},
328 REF => sub {my $undef; \$undef},
329 CODE => 1, # 1 means atomic
332 ? (Regexp => sub {my $qr = qr//})
336 # This should better be done via pos() and \G, but apparently \G is not
337 # optimized (bug in the REx optimizer???)
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;
350 sub flushCache {$lock ^= rand; undef %saved;}
354 return $ref if not $ref or defined $Empty{$ref}; # Optimization _and_ Regexp
356 if (defined &overload::StrVal) {
357 $str = overload::StrVal($_[0]);
361 $ref = $1 if $str =~ /=(\w+)/;
365 sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]}
367 sub freezeNumber {$string .= $_[0] . '|'}
369 sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]}
371 sub 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);
380 sub 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);
387 if (eval 'ref qr/1/') {
388 eval 'sub _2rex ($) {my $r = shift; qr/$r/} 1' or die;
390 eval 'sub _2rex ($) { shift } 1' or die;
393 sub 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);
404 $string .= '@' . @{$_[0]} . '|';
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]";
414 my $off = $_[0] + 2 + length $count;
416 while ($count and length $string > $off) {
417 ($res,$off) = thawScalar($off);
421 confess "Wrong length of data in thawing Array: $count left" if $count;
426 my @arr = sort keys %{$_[0]};
427 $string .= '%' . (2*@arr) . '|';
428 for (@arr, @{$_[0]}{@arr}) {
434 my ($arr, $rest) = &thawArray;
437 foreach (0 .. $l - 1) {
438 $hash{$arr->[$_]} = $arr->[$l + $_];
443 # Second optional argument: ignore the package
444 # Third optional one: do not check for duplicates on outer level
447 $string .= '_', return unless defined $_[0];
448 return &freezeString unless ref $_[0];
451 if ($_[1] and $ref) { # Similar to getref()
452 if (defined &overload::StrVal) {
453 $str = overload::StrVal($_[0]);
457 $ref = $1 if $str =~ /=(\w+)/;
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;
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};
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";
490 if ($safe and (($ref eq 'CODE') or $ref eq 'GLOB')) {
492 $saved{$str} = $_[0] unless defined $saved{$str};
494 return &freezeString;
497 local $norepeated = $norepeated;
498 local $noCache = $noCache;
499 freezePackage(ref $_[0]);
500 $_[0]->Freeze($cooky);
504 my $packageid = $seen_packages{$_[0]};
505 if (defined $packageid) {
507 &freezeNumber( $packageid );
510 &freezeNumber( $seen_packages );
511 &freezeScalar( $_[0] );
512 $seen_packages{ $_[0] } = $seen_packages++;
516 sub thawPackage { # First argument: offset
517 my $key = substr($string,$_[0],1);
518 my ($get, $rest, $id);
519 ($id, $rest) = &thawNumber($_[0] + 1);
521 $get = $seen_packages{$id};
523 ($get, $rest) = &thawString($rest);
524 $seen_packages{$id} = $get;
529 # First argument: offset; Optional other: index in the @uninit array
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 ) ;
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;
560 my $res = $package->Allocate($cooky);
562 } elsif ($key eq '}') {
563 warn "Here it is undef!" unless defined $_[1];
564 $package->Instantiate($uninit[$_[1]],$cooky);
567 ($package->Thaw($cooky),$rest);
570 confess "Do not know how to thaw data with code `$key'";
574 sub freezeEmpty { # Takes a type, freezes ref to empty object
575 my $e = $Empty{ref $_[0]};
582 freezeScalar($cache,1,1); # Atomic
586 freezePackage ref $_[0];
587 $_[0]->FreezeEmpty($cooky);
593 local %seen_packages;
594 local $seen_packages = 0;
595 local %seen_packages;
599 local $string = 'FrT;';
602 local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake
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
612 #### for (keys %count) {
613 #### $count{$_} = undef if $count{$_} <= 1; # As at start
614 #### $count{$_} = 0 if $count{$_}; # As at start
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
624 %seen_packages = (); # XXXX We reshuffle parts of the
625 # string, so the order of packages may
627 freezeNumber($#multiple);
629 my @cache; # Force different values for different
631 foreach (@multiple) {
632 push @cache, freezeEmpty $_;
635 # for (keys %count) {
637 # if !(defined $count{$_}) or $count{$_} <= 1; # As at start
639 # $string .= '@' . @multiple . '|';
642 freezeScalar($_,0,1,1), next if $Empty{ref $_};
644 freezePackage ref $_;
645 $_->FreezeInstance($cooky);
647 #### $string .= $oldstring;
650 return "FrT;?\$" . length($lock) . "|" . $lock . substr $string, 4
660 sub 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') {
667 } elsif ($ref eq 'ARRAY') {
669 } elsif ($ref eq 'HASH') {
671 } elsif (haveIsRex ? re::is_regexp($second)
672 : ($ref eq 'Regexp' and not defined $$second)) {
673 $first = qr/$second/;
675 croak "Don't know how to copyContents of type `$ref'";
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;
686 confess "thaw requires one argument" unless @_ ==1;
687 local $string = shift;
688 local %seen_packages;
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;
696 local $unsafe = $initoff + (substr($string, $initoff, 1) eq "?" ? 1 : 0);
697 if ($unsafe != $initoff) {
699 ($key,$unsafe) = thawScalar($unsafe);
700 confess "The lock in frozen data does not match the key"
701 unless $key eq $lock;
704 local $uninitOK = 1; # The methods can change it.
705 my $repeated = substr($string,$unsafe,1) eq '!' ? 1 : 0;
708 ($res, $off) = thawNumber($repeated + $unsafe);
710 ($res, $off) = thawScalar($repeated + $unsafe);
712 my $cooky = bless \$off, 'FreezeThaw::TCooky';
717 ($res, $off) = thawScalar($off, $_);
722 ($res, $off) = thawScalar($off, $_);
725 #($init, $off) = thawScalar($off);
726 #print "Instantiating...\n";
729 copyContents $uninit[$_], $init[$_] if ref $init[$_];
731 ($res, $off) = thawScalar($off);
733 croak "Extra elements in frozen structure: `" . substr($string,$off) . "'"
734 if $off != length $string;
739 confess "Compare requires two arguments" unless @_ == 2;
740 freeze(shift) cmp freeze(shift);
744 confess "Compare requires two arguments" unless @_ == 2;
749 local $string = 'FrT;';
752 local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake
758 # Now all the caches are filled, delete the entries for guys which
759 # are in one argument only.
761 while (($elt, $val) = each %cnt1) {
762 $count{$elt}++ if $cnt2{$elt} > $cnt1{$elt};
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;
781 # foreach (0..$len) {
782 # ($uninit,$off) = thawScalar $off, $_;
784 # $off += 3; # Hardwired offset after @2|
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;
790 # ($first,$off3) = thawScalar $off2;
791 # substr($string, $off, $off2-$off) cmp substr($string,$off2,$off3-$off2);
794 sub FreezeThaw::FCooky::FreezeScalar {
799 sub FreezeThaw::FCooky::isSafe {
803 sub FreezeThaw::FCooky::makeSafe {
807 sub FreezeThaw::FCooky::repeatedOK {
811 sub FreezeThaw::FCooky::noRepeated {
815 sub FreezeThaw::TCooky::repeatedOK {
819 sub FreezeThaw::TCooky::noRepeated {
823 sub FreezeThaw::TCooky::isSafe {
827 sub FreezeThaw::TCooky::makeSafe {
831 sub FreezeThaw::TCooky::ThawScalar {
833 my ($res,$off) = &thawScalar($$self);
838 sub UNIVERSAL::Freeze {
839 my ($obj, $cooky) = (shift, shift);
840 $cooky->FreezeScalar($obj,1,1);
843 sub UNIVERSAL::Thaw {
844 my ($package, $cooky) = (shift, shift);
845 my $obj = $cooky->ThawScalar;
846 bless $obj, $package;
849 sub 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);
857 sub 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;
866 sub UNIVERSAL::Allocate {
867 my($package,$cooky) = @_;
871 sub UNIVERSAL::FreezeEmpty {
873 my $type = getref $obj;
874 my $e = $Empty{$type};
878 $ref; # Put into cache.
880 freezeScalar($obj,1,1); # Atomic
882 } elsif (!RexIsREGEXP and defined $e and not defined $$obj) { # REx pre-5.11
886 die "Do not know how to FreezeEmpty $type";