Commit | Line | Data |
3fea05b9 |
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; |