local-lib5/lib/perl5/FreezeThaw.pm

   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.5001';
 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
 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
 317   eval <<EOE or die;
 318 sub haveIsRex () {$haveIsRex}
 319 sub RexIsREGEXP () {$RexIsREGEXP}
 320 1
 321 EOE
 322 }
 323
 324 my (%saved);
 325
 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
 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???)
 338 BEGIN {
 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
 350 sub flushCache {$lock ^= rand; undef %saved;}
 351
 352 sub 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
 365 sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]}
 366
 367 sub freezeNumber {$string .= $_[0] . '|'}
 368
 369 sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]}
 370
 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);
 378 }
 379
 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);
 384 }
 385
 386 sub _2rex ($);
 387 if (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
 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);
 401 }
 402
 403 sub freezeArray {
 404   $string .= '@' . @{$_[0]} . '|';
 405   for (@{$_[0]}) {
 406     freezeScalar($_);
 407   }
 408 }
 409
 410 sub 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
 425 sub freezeHash {
 426   my @arr = sort keys %{$_[0]};
 427   $string .= '%' . (2*@arr) . '|';
 428   for (@arr, @{$_[0]}{@arr}) {
 429     freezeScalar($_);
 430   }
 431 }
 432
 433 sub 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
 446 sub 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
 503 sub 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
 516 sub 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
 531 sub 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
 574 sub 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
 591 sub 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
 655 sub safeFreeze {
 656   local $safe = 1;
 657   &freeze;
 658 }
 659
 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') {
 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
 685 sub 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
 738 sub cmpStr {
 739   confess "Compare requires two arguments" unless @_ == 2;
 740   freeze(shift) cmp freeze(shift);
 741 }
 742
 743 sub 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
 794 sub FreezeThaw::FCooky::FreezeScalar {
 795   shift;
 796   &freezeScalar;
 797 }
 798
 799 sub FreezeThaw::FCooky::isSafe {
 800   $safe || $noCache;
 801 }
 802
 803 sub FreezeThaw::FCooky::makeSafe {
 804   $noCache = 1;
 805 }
 806
 807 sub FreezeThaw::FCooky::repeatedOK {
 808   !$norepeated;
 809 }
 810
 811 sub FreezeThaw::FCooky::noRepeated {
 812   $norepeated = 1;
 813 }
 814
 815 sub FreezeThaw::TCooky::repeatedOK {
 816   $uninitOK;
 817 }
 818
 819 sub FreezeThaw::TCooky::noRepeated {
 820   undef $uninitOK;
 821 }
 822
 823 sub FreezeThaw::TCooky::isSafe {
 824   !$unsafe;
 825 }
 826
 827 sub FreezeThaw::TCooky::makeSafe {
 828   undef $unsafe;
 829 }
 830
 831 sub FreezeThaw::TCooky::ThawScalar {
 832   my $self = shift;
 833   my ($res,$off) = &thawScalar($$self);
 834   $$self = $off;
 835   $res;
 836 }
 837
 838 sub UNIVERSAL::Freeze {
 839   my ($obj, $cooky) = (shift, shift);
 840   $cooky->FreezeScalar($obj,1,1);
 841 }
 842
 843 sub UNIVERSAL::Thaw {
 844   my ($package, $cooky) = (shift, shift);
 845   my $obj = $cooky->ThawScalar;
 846   bless $obj, $package;
 847 }
 848
 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);
 855 }
 856
 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;
 864 }
 865
 866 sub UNIVERSAL::Allocate {
 867   my($package,$cooky) = @_;
 868   $cooky->ThawScalar;
 869 }
 870
 871 sub 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
 890 1;