dummy_foundation/lib/freezethaw/FreezeThaw.pm
changeset 4 60053dab7e2a
parent 3 8b87ea768cb8
child 5 c34a018f3291
equal deleted inserted replaced
3:8b87ea768cb8 4:60053dab7e2a
     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;