1 =head1 NAME

     2 

     3 FreezeThaw - 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 

    15 Converts data to/from stringified form, appropriate for

    16 saving-to/reading-from permanent storage.

    17 

    18 Deals with objects, circular lists, repeated appearence of the same

    19 refence. Does not deal with overloaded I<stringify> operator yet.

    20 

    21 =head1 EXPORT

    22 

    23 =over 12

    24 

    25 =item Default

    26 

    27 None.

    28 

    29 =item Exportable

    30 

    31 C<freeze thaw cmpStr cmpStrHard safeFreeze>.

    32 

    33 =back

    34 

    35 =head1 User API

    36 

    37 =over 12

    38 

    39 =item C<cmpStr>

    40 

    41 analogue of C<cmp> for data. Takes two arguments and compares them as

    42 separate entities.

    43 

    44 =item C<cmpStrHard>

    45 

    46 analogue of C<cmp> for data. Takes two arguments and compares them

    47 considered as a group.

    48 

    49 =item C<freeze>

    50 

    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.

    54 

    55 =item C<safeFreeze>

    56 

    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

    61 C<CODE>s.

    62 

    63 =item C<thaw>

    64 

    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).

    68 

    69 =back

    70 

    71 =head1 Developer API

    72 

    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.

    78 

    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

    82 

    83   $newcooky = $obj->Freeze($cooky);

    84   $obj = Package->Thaw($content,$cooky);

    85 

    86 To save and restore the data the following method are applicable:

    87 

    88   $cooky->FreezeScalar($data,$ignorePackage,$noduplicate);

    89 

    90 during Freeze()ing, and

    91 

    92   $data = $cooky->ThawScalar;

    93 

    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

    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 

   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.

   116 

   117 Freezing and thawing $cooky also allows the following additional methods:

   118 

   119   $cooky->isSafe;

   120 

   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

   126 

   127   $cooky->makeSafe;

   128 

   129 to prohibit cached data for the duration of the rest of freezing or

   130 thawing of current object.

   131 

   132 Two methods

   133 

   134   $value = $cooky->repeatedOK;

   135   $cooky->noRepeated;		# Now repeated are prohibited

   136 

   137 allow to find out/change the current setting for allowing repeated

   138 references.

   139 

   140 If you want to flush the cache of saved objects you can use

   141 

   142   FreezeThaw->flushCache;

   143 

   144 this can invalidate some frozen string, so that thawing them will

   145 result in fatal error.

   146 

   147 =head2 Instantiating

   148 

   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.

   154 

   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.

   158 

   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.

   162 

   163 The 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 

   170 The reverse operations are

   171 

   172   $object_ref->FreezeEmpty($cooky);

   173   $object_ref->FreezeInstance($cooky);

   174 

   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:

   183 

   184   $o1->FreezeEmpty($cooky)

   185 

   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

   191 engine.

   192 

   193 The helper function C<FreezeThaw::copyContents> is provided for

   194 simplification of instantiation. The syntax is

   195 

   196   FreezeThaw::copyContents $to, $from;

   197 

   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.

   201 

   202 The default methods are provided. They do the following:

   203 

   204 =over 12

   205 

   206 =item C<FreezeEmpty>

   207 

   208 Freezes an I<empty> object of underlying type.

   209 

   210 =item C<FreezeInstance>

   211 

   212 Calls C<Freeze>.

   213 

   214 =item C<Allocate>

   215 

   216 Thaws what was frozen by C<FreezeEmpty>.

   217 

   218 =item C<Instantiate>

   219 

   220 Thaws what was frozen by C<FreezeInstance>, uses C<copyContents> to

   221 transfer this to the $pre_object.

   222 

   223 =back

   224 

   225 =head1 BUGS and LIMITATIONS

   226 

   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.

   230 

   231 The objects which can survive freeze()/thaw() cycle must also survive a

   232 change 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 

   241 This property will be broken by freeze()/thaw(), but it is also broken by

   242 

   243   $a->{a} = delete $a->{a};

   244 

   245 =cut

   246 

   247 require 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 

   283 package FreezeThaw;

   284 

   285 use Exporter;

   286 

   287 @ISA = qw(Exporter);

   288 $VERSION = '0.43';

   289 @EXPORT_OK = qw(freeze thaw cmpStr cmpStrHard safeFreeze);

   290 

   291 use strict;

   292 use Carp;

   293 

   294 my $lock = (reverse time) ^ $$ ^ \&freezeString; # To distingush processes

   295 

   296 use 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 my (%saved);

   313 

   314 my %Empty = ( ARRAY   => sub {[]}, HASH => sub {{}},

   315 	      SCALAR  => sub {my $undef; \$undef},

   316 	      REF     => sub {my $undef; \$undef},

   317 	      CODE    => 1,		# 1 means atomic

   318 	      GLOB    => 1,

   319 	      Regexp  => 0,

   320 	 );

   321 

   322 

   323 sub flushCache {$lock ^= rand; undef %saved;}

   324 

   325 sub getref ($) {

   326   my $ref = ref $_[0];

   327   return $ref if not $ref or defined $Empty{$ref}; # Optimization _and_ Regexp

   328   my $str;

   329   if (defined &overload::StrVal) {

   330     $str = overload::StrVal($_[0]);

   331   } else {

   332     $str = "$_[0]";

   333   }

   334   $ref = $1 if $str =~ /=(\w+)/;

   335   $ref;

   336 }

   337 

   338 sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]}

   339 

   340 sub freezeNumber {$string .= $_[0] . '|'}

   341 

   342 sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]}

   343 

   344 sub thawString {	# Returns list: a string and offset of rest

   345   substr($string, $_[0]) =~ /^\$(\d+)\|/

   346     or confess "Wrong format of frozen string: " . substr($string, $_[0]);

   347   length($string) - $_[0] > length($1) + 1 + $1

   348     or confess "Frozen string too short: `" .

   349       substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1);

   350   (substr($string, $_[0] + length($1) + 2, $1), $_[0] + length($1) + 2 + $1);

   351 }

   352 

   353 sub thawNumber {	# Returns list: a number and offset of rest

   354   substr($string, $_[0]) =~ /^(\d+)\|/

   355     or confess "Wrong format of frozen string: " . substr($string, $_[0]);

   356   ($1, $_[0] + length($1) + 1);

   357 }

   358 

   359 sub _2rex ($);

   360 if (eval '"Regexp" eq ref qr/1/') {

   361   eval 'sub _2rex ($) {my $r = shift; qr/$r/} 1' or die;

   362 } else {

   363   eval 'sub _2rex ($) { shift } 1' or die;

   364 }

   365 

   366 sub thawREx {	# Returns list: a REx and offset of rest

   367   substr($string, $_[0]) =~ m,^/(\d+)\|,

   368     or confess "Wrong format of frozen REx: " . substr($string, $_[0]);

   369   length($string) - $_[0] > length($1) + 1 + $1

   370     or confess "Frozen string too short: `" .

   371       substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1);

   372   (_2rex substr($string, $_[0] + length($1) + 2, $1),

   373    $_[0] + length($1) + 2 + $1);

   374 }

   375 

   376 sub freezeArray {

   377   $string .= '@' . @{$_[0]} . '|';

   378   for (@{$_[0]}) {

   379     freezeScalar($_);

   380   }

   381 }

   382 

   383 sub thawArray {

   384   substr($string, $_[0]) =~ /^[\@%](\d+)\|/ # % To make it possible thaw hashes

   385     or confess "Wrong format of frozen array: \n$_[0]";

   386   my $count = $1;

   387   my $off = $_[0] + 2 + length $count;

   388   my (@res, $res);

   389   while ($count and length $string > $off) {

   390     ($res,$off) = thawScalar($off);

   391     push(@res,$res);

   392     --$count;

   393   }

   394   confess "Wrong length of data in thawing Array: $count left" if $count;

   395   (\@res, $off);

   396 }

   397 

   398 sub freezeHash {

   399   my @arr = sort keys %{$_[0]};

   400   $string .= '%' . (2*@arr) . '|';

   401   for (@arr, @{$_[0]}{@arr}) {

   402     freezeScalar($_);

   403   }

   404 }

   405 

   406 sub thawHash {

   407   my ($arr, $rest) = &thawArray;

   408   my %hash;

   409   my $l = @$arr/2;

   410   foreach (0 .. $l - 1) {

   411     $hash{$arr->[$_]} = $arr->[$l + $_];

   412   }

   413   (\%hash,$rest);

   414 }

   415 

   416 # Second optional argument: ignore the package

   417 # Third optional one: do not check for duplicates on outer level

   418 

   419 sub freezeScalar {

   420   $string .= '_', return unless defined $_[0];

   421   return &freezeString unless ref $_[0];

   422   my $ref = ref $_[0];

   423   my $str;

   424   if ($_[1] and $ref) {			# Similar to getref()

   425     if (defined &overload::StrVal) {

   426       $str = overload::StrVal($_[0]);

   427     } else {

   428       $str = "$_[0]";

   429     }

   430     $ref = $1 if $str =~ /=(\w+)/;

   431   } else {

   432     $str = "$_[0]";

   433   }

   434   # Die if a) repeated prohibited, b) met, c) not explicitely requested to ingore.

   435   confess "Repeated reference met when prohibited"

   436     if $norepeated && !$_[2] && defined $count{$str};

   437   if ($secondpass and !$_[2]) {

   438     $string .= "<$address{$str}|", return

   439       if defined $count{$str} and $count{$str} > 1;

   440   } elsif (!$_[2]) {

   441     # $count{$str} is defined if we have seen it on this pass.

   442     $address{$str} = @multiple, push(@multiple, $_[0])

   443       if defined $count{$str} and not exists $address{$str};

   444     # This is for debugging and shortening thrown-away output (also

   445     # internal data in arrays and hashes is not duplicated).

   446     $string .= "<$address{$str}|", ++$count{$str}, return

   447       if defined $count{$str};

   448     ++$count{$str};

   449   }

   450   return &freezeArray if $ref eq 'ARRAY';

   451   return &freezeHash if $ref eq 'HASH';

   452   return &freezeREx if $ref eq 'Regexp' and not defined ${$_[0]};

   453   $string .= "*", return &freezeString

   454     if $ref eq 'GLOB' and !$safe;

   455   $string .= "&", return &freezeString

   456     if $ref eq 'CODE' and !$safe;

   457   $string .= '\\', return &freezeScalar( $ {shift()} )

   458     if $ref eq 'REF' or $ref eq 'SCALAR';

   459   if ($noCache and (($ref eq 'CODE') or $ref eq 'GLOB')) {

   460     confess "CODE and GLOB references prohibited now";

   461   }

   462   if ($safe and (($ref eq 'CODE') or $ref eq 'GLOB')) {

   463     $unsafe = 1;

   464     $saved{$str} = $_[0] unless defined $saved{$str};

   465     $string .= "?";

   466     return &freezeString;

   467   }

   468   $string .= '>';

   469   local $norepeated = $norepeated;

   470   local $noCache = $noCache;

   471   freezePackage(ref $_[0]);

   472   $_[0]->Freeze($cooky);

   473 }

   474 

   475 sub freezePackage {

   476   my $packageid = $seen_packages{$_[0]};

   477   if (defined $packageid) {

   478     $string .= ')';

   479     &freezeNumber( $packageid );

   480   } else {

   481     $string .= '>';

   482     &freezeNumber( $seen_packages );

   483     &freezeScalar( $_[0] );

   484     $seen_packages{ $_[0] } = $seen_packages++;

   485   }

   486 }

   487 

   488 sub thawPackage {		# First argument: offset

   489   my $key = substr($string,$_[0],1);

   490   my ($get, $rest, $id);

   491   ($id, $rest) = &thawNumber($_[0] + 1);

   492   if ($key eq ')') {

   493     $get = $seen_packages{$id};

   494   } else {

   495     ($get, $rest) = &thawString($rest);

   496     $seen_packages{$id} = $get;

   497   }

   498   ($get, $rest);

   499 }

   500 

   501 # First argument: offset; Optional other: index in the @uninit array

   502 

   503 sub thawScalar {

   504   my $key = substr($string,$_[0],1);

   505   if ($key eq "\$") {&thawString}

   506   elsif ($key eq '@') {&thawArray}

   507   elsif ($key eq '%') {&thawHash}

   508   elsif ($key eq '/') {&thawREx}

   509   elsif ($key eq '\\') {

   510     my ($out,$rest) = &thawScalar( $_[0]+1 ) ;

   511     (\$out,$rest);

   512   }

   513   elsif ($key eq '_') { (undef, $_[0]+1) }

   514   elsif ($key eq '&') {confess "Do not know how to thaw CODE"}

   515   elsif ($key eq '*') {confess "Do not know how to thaw GLOB"}

   516   elsif ($key eq '?') {

   517     my ($address,$rest) = &thawScalar( $_[0]+1 ) ;

   518     confess "The saved data accessed in unprotected thaw" unless $unsafe;

   519     confess "The saved data disappeared somewhere"

   520       unless defined $saved{$address};

   521     ($saved{$address},$rest);

   522   } elsif ($key eq '<') {

   523     confess "Repeated data prohibited at this moment" unless $uninitOK;

   524     my ($off,$end) = &thawNumber ($_[0]+1);

   525     ($uninit[$off],$end);

   526   } elsif ($key eq '>' or $key eq '{' or $key eq '}') {

   527     my ($package,$rest) = &thawPackage( $_[0]+1 );

   528     my $cooky = bless \$rest, 'FreezeThaw::TCooky';

   529     local $uninitOK = $uninitOK;

   530     local $unsafe = $unsafe;

   531     if ($key eq '{') {

   532       my $res = $package->Allocate($cooky);

   533       ($res, $rest);

   534     } elsif ($key eq '}') {

   535       warn "Here it is undef!" unless defined $_[1];

   536       $package->Instantiate($uninit[$_[1]],$cooky);

   537       (undef, $rest);

   538     } else {

   539       ($package->Thaw($cooky),$rest);

   540     }

   541   } else {

   542     confess "Do not know how to thaw data with code `$key'";

   543   }

   544 }

   545 

   546 sub freezeEmpty {		# Takes a type, freezes ref to empty object

   547   my $e = $Empty{ref $_[0]};

   548   if (ref $e) {

   549     my $cache = &$e;

   550     freezeScalar $cache;

   551     $cache;

   552   } elsif ($e) {

   553     my $cache = shift;

   554     freezeScalar($cache,1,1);	# Atomic

   555     $cache;

   556   } else {

   557     $string .= "{";

   558     freezePackage ref $_[0];

   559     $_[0]->FreezeEmpty($cooky);

   560   }

   561 }

   562 

   563 sub freeze {

   564   local @multiple;

   565   local %seen_packages;

   566   local $seen_packages = 0;

   567   local %seen_packages;

   568 #  local @seentypes;

   569   local %count;

   570   local %address;

   571   local $string = 'FrT;';

   572   local $unsafe;

   573   local $noCache;

   574   local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake

   575   local $secondpass;

   576   freezeScalar(\@_);

   577   if (@multiple) {

   578     # Now repeated structures are enumerated with order of *second* time

   579     # they appear in the what we freeze.

   580     # What we want is to have them enumerated with respect to the first time

   581 ####    $string = '';		# Start again

   582 ####    @multiple = ();

   583 ####    %address = ();

   584 ####    for (keys %count) {

   585 ####      $count{$_} = undef if $count{$_} <= 1; # As at start

   586 ####      $count{$_} = 0 if $count{$_}; # As at start

   587 ####    }

   588 ####    $seen_packages = 0;

   589 ####    %seen_packages = ();

   590 ####    freezeScalar(\@_);

   591     # Now repeated structures are enumerated with order of first time

   592     # they appear in the what we freeze

   593 ####    my $oldstring = substr $string, 4;

   594     $string = 'FrT;!'; # Start again

   595     $seen_packages = 0;

   596     %seen_packages = ();	# XXXX We reshuffle parts of the

   597                                 # string, so the order of packages may

   598                                 # be wrong...

   599     freezeNumber($#multiple);

   600     {

   601       my @cache;		# Force different values for different

   602                                 # empty objects.

   603       foreach (@multiple) {

   604 	push @cache, freezeEmpty $_;

   605       }

   606     }

   607 #    for (keys %count) {

   608 #      $count{$_} = undef

   609 #	if !(defined $count{$_}) or $count{$_} <= 1; # As at start

   610 #    }

   611     # $string .= '@' . @multiple . '|';

   612     $secondpass = 1;

   613     for (@multiple) {

   614       freezeScalar($_,0,1,1), next if $Empty{ref $_};

   615       $string .= "}";

   616       freezePackage ref $_;

   617       $_->FreezeInstance($cooky);

   618     }

   619 ####    $string .= $oldstring;

   620     freezeScalar(\@_);

   621   }

   622   return "FrT;?\$" . length($lock) . "|" . $lock . substr $string, 4

   623     if $unsafe;

   624   $string;

   625 }

   626 

   627 sub safeFreeze {

   628   local $safe = 1;

   629   &freeze;

   630 }

   631 

   632 sub copyContents {  # Given two references, copies contents of the

   633                     # second one to the first one, provided they have

   634 		    # the same basic type. The package is copied too.

   635   my($first,$second) = @_;

   636   my $ref = getref $second;

   637   if ($ref eq 'SCALAR' or $ref eq 'REF') {

   638     $$first = $$second;

   639   } elsif ($ref eq 'ARRAY') {

   640     @$first = @$second;

   641   } elsif ($ref eq 'HASH') {

   642     %$first = %$second;

   643   } else {

   644     croak "Don't know how to copyContents of type `$ref'";

   645   }

   646   if (ref $second ne ref $first) { # Rebless

   647     # SvAMAGIC() is a property of a reference, not of a referent!

   648     # Thus we cannot use $first here if $second was overloaded...

   649     bless $_[0], ref $second;

   650   }

   651   $first;

   652 }

   653 

   654 sub thaw {

   655   confess "thaw requires one argument" unless @_ ==1;

   656   local $string = shift;

   657   local %seen_packages;

   658   my $initoff = 0;

   659   #print STDERR "Thawing `$string'", substr ($string, 0, 4), "\n";

   660   if (substr($string, 0, 4) ne 'FrT;') {

   661     warn "Signature not present, continuing anyway" if $^W;

   662   } else {

   663     $initoff = 4;

   664   }

   665   local $unsafe = $initoff + (substr($string, $initoff, 1) eq "?" ? 1 : 0);

   666   if ($unsafe != $initoff) {

   667     my $key;

   668     ($key,$unsafe) = thawScalar($unsafe);

   669     confess "The lock in frozen data does not match the key"

   670       unless $key eq $lock;

   671   }

   672   local @multiple;

   673   local $uninitOK = 1;		# The methods can change it.

   674   my $repeated = substr($string,$unsafe,1) eq '!' ? 1 : 0;

   675   my ($res, $off);

   676   if ($repeated) {

   677     ($res, $off) = thawNumber($repeated + $unsafe);

   678   } else {

   679     ($res, $off) = thawScalar($repeated + $unsafe);

   680   }

   681   my $cooky = bless \$off, 'FreezeThaw::TCooky';

   682   if ($repeated) {

   683     local @uninit;

   684     my $lst = $res;

   685     foreach (0..$lst) {

   686       ($res, $off) = thawScalar($off, $_);

   687       push(@uninit, $res);

   688     }

   689     my @init;

   690     foreach (0..$lst) {

   691       ($res, $off) = thawScalar($off, $_);

   692       push(@init, $res);

   693     }

   694     #($init, $off)  = thawScalar($off);

   695     #print "Instantiating...\n";

   696     #my $ref;

   697     for (0..$#uninit) {

   698       copyContents $uninit[$_], $init[$_] if ref $init[$_];

   699     }

   700     ($res, $off) = thawScalar($off);

   701   }

   702   croak "Extra elements in frozen structure: `" . substr($string,$off) . "'"

   703     if $off != length $string;

   704   return @$res;

   705 }

   706 

   707 sub cmpStr {

   708   confess "Compare requires two arguments" unless @_ == 2;

   709   freeze(shift) cmp freeze(shift);

   710 }

   711 

   712 sub cmpStrHard {

   713   confess "Compare requires two arguments" unless @_ == 2;

   714   local @multiple;

   715 #  local @seentypes;

   716   local %count;

   717   local %address;

   718   local $string = 'FrT;';

   719   local $unsafe;

   720   local $noCache;

   721   local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake

   722   freezeScalar($_[0]);

   723   my %cnt1 = %count;

   724   freezeScalar($_[1]);

   725   my %cnt2 = %count;

   726   %count = ();

   727   # Now all the caches are filled, delete the entries for guys which

   728   # are in one argument only.

   729   my ($elt, $val);

   730   while (($elt, $val) = each %cnt1) {

   731     $count{$elt}++ if $cnt2{$elt} > $cnt1{$elt};

   732   }

   733   $string = '';

   734   freezeScalar($_[0]);

   735   my $str1 = $string;

   736   $string = '';

   737   freezeScalar($_[1]);

   738   $str1 cmp $string;

   739 }

   740 

   741 #   local $string = freeze(shift,shift);

   742 #   local $uninitOK = 1;

   743 #   #print "$string\n";

   744 #   my $off = 7;			# Hardwired offset after @2|

   745 #   if (substr($string,4,1) eq '!') {

   746 #     $off = 5;			# Hardwired offset after !

   747 #     my ($uninit, $len);

   748 #     ($len,$off) = thawScalar $off;

   749 #     local @uninit;

   750 #     foreach (0..$len) {

   751 #       ($uninit,$off) = thawScalar $off, $_;

   752 #     }

   753 #     $off += 3;			# Hardwired offset after @2|

   754 #   }

   755 #   croak "Unknown format of frozen array: " . substr($string,$off-3)

   756 #     unless substr($string,$off-3,1) eq '@';

   757 #   my ($first,$off2) = thawScalar $off;

   758 #   my $off3;

   759 #   ($first,$off3) = thawScalar $off2;

   760 #   substr($string, $off, $off2-$off) cmp substr($string,$off2,$off3-$off2);

   761 # }

   762 

   763 sub FreezeThaw::FCooky::FreezeScalar {

   764   shift;

   765   &freezeScalar;

   766 }

   767 

   768 sub FreezeThaw::FCooky::isSafe {

   769   $safe || $noCache;

   770 }

   771 

   772 sub FreezeThaw::FCooky::makeSafe {

   773   $noCache = 1;

   774 }

   775 

   776 sub FreezeThaw::FCooky::repeatedOK {

   777   !$norepeated;

   778 }

   779 

   780 sub FreezeThaw::FCooky::noRepeated {

   781   $norepeated = 1;

   782 }

   783 

   784 sub FreezeThaw::TCooky::repeatedOK {

   785   $uninitOK;

   786 }

   787 

   788 sub FreezeThaw::TCooky::noRepeated {

   789   undef $uninitOK;

   790 }

   791 

   792 sub FreezeThaw::TCooky::isSafe {

   793   !$unsafe;

   794 }

   795 

   796 sub FreezeThaw::TCooky::makeSafe {

   797   undef $unsafe;

   798 }

   799 

   800 sub FreezeThaw::TCooky::ThawScalar {

   801   my $self = shift;

   802   my ($res,$off) = &thawScalar($$self);

   803   $$self = $off;

   804   $res;

   805 }

   806 

   807 sub UNIVERSAL::Freeze {

   808   my ($obj, $cooky) = (shift, shift);

   809   $cooky->FreezeScalar($obj,1,1);

   810 }

   811 

   812 sub UNIVERSAL::Thaw {

   813   my ($package, $cooky) = (shift, shift);

   814   my $obj = $cooky->ThawScalar;

   815   bless $obj, $package;

   816 }

   817 

   818 sub UNIVERSAL::FreezeInstance {

   819   my($obj,$cooky) = @_;

   820   return if (ref $obj and ref $obj eq 'Regexp' and not defined $$obj); # Regexp

   821   $obj->Freeze($cooky);

   822 }

   823 

   824 sub UNIVERSAL::Instantiate {

   825   my($package,$pre,$cooky) = @_;

   826   return if $package eq 'Regexp';

   827   my $obj = $package->Thaw($cooky);

   828   # SvAMAGIC() is a property of a reference, not of a referent!

   829   # Thus we cannot use $pre here if $obj was overloaded...

   830   copyContents $_[1], $obj;

   831 }

   832 

   833 sub UNIVERSAL::Allocate {

   834   my($package,$cooky) = @_;

   835   $cooky->ThawScalar;

   836 }

   837 

   838 sub UNIVERSAL::FreezeEmpty {

   839   my $obj = shift;

   840   my $type = getref $obj;

   841   my $e = $Empty{$type};

   842   if (ref $e) {

   843     my $ref = &$e;

   844     freezeScalar $ref;

   845     $ref;			# Put into cache.

   846   } elsif ($e) {

   847     freezeScalar($obj,1,1);	# Atomic

   848     undef;

   849   } elsif (defined $e and not defined $$obj) {	# Regexp

   850     freezeREx($obj);

   851     undef;

   852   } else {

   853     die "Do not know how to FreezeEmpty $type";

   854   }

   855 }

   856 

   857 1;