|
0 |
=head1 NAME
|
|
1 |
|
|
2 |
FreezeThaw - converting Perl structures to strings and back.
|
|
3 |
|
|
4 |
=head1 SYNOPSIS
|
|
5 |
|
|
6 |
use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
|
|
7 |
$string = freeze $data1, $data2, $data3;
|
|
8 |
...
|
|
9 |
($olddata1, $olddata2, $olddata3) = thaw $string;
|
|
10 |
if (cmpStr($olddata2,$data2) == 0) {print "OK!"}
|
|
11 |
|
|
12 |
=head1 DESCRIPTION
|
|
13 |
|
|
14 |
Converts data to/from stringified form, appropriate for
|
|
15 |
saving-to/reading-from permanent storage.
|
|
16 |
|
|
17 |
Deals with objects, circular lists, repeated appearence of the same
|
|
18 |
refence. Does not deal with overloaded I<stringify> operator yet.
|
|
19 |
|
|
20 |
=head1 EXPORT
|
|
21 |
|
|
22 |
=over 12
|
|
23 |
|
|
24 |
=item Default
|
|
25 |
|
|
26 |
None.
|
|
27 |
|
|
28 |
=item Exportable
|
|
29 |
|
|
30 |
C<freeze thaw cmpStr cmpStrHard safeFreeze>.
|
|
31 |
|
|
32 |
=back
|
|
33 |
|
|
34 |
=head1 User API
|
|
35 |
|
|
36 |
=over 12
|
|
37 |
|
|
38 |
=item C<cmpStr>
|
|
39 |
|
|
40 |
analogue of C<cmp> for data. Takes two arguments and compares them as
|
|
41 |
separate entities.
|
|
42 |
|
|
43 |
=item C<cmpStrHard>
|
|
44 |
|
|
45 |
analogue of C<cmp> for data. Takes two arguments and compares them
|
|
46 |
considered as a group.
|
|
47 |
|
|
48 |
=item C<freeze>
|
|
49 |
|
|
50 |
returns a string that encupsulates its arguments (considered as a
|
|
51 |
group). C<thaw>ing this string leads to a fatal error if arguments to
|
|
52 |
C<freeze> contained references to C<GLOB>s and C<CODE>s.
|
|
53 |
|
|
54 |
=item C<safeFreeze>
|
|
55 |
|
|
56 |
returns a string that encupsulates its arguments (considered as a
|
|
57 |
group). The result is C<thaw>able in the same process. C<thaw>ing the
|
|
58 |
result in a different process should result in a fatal error if
|
|
59 |
arguments to C<safeFreeze> contained references to C<GLOB>s and
|
|
60 |
C<CODE>s.
|
|
61 |
|
|
62 |
=item C<thaw>
|
|
63 |
|
|
64 |
takes one string argument and returns an array. The elements of the
|
|
65 |
array are "equivalent" to arguments of the C<freeze> command that
|
|
66 |
created the string. Can result in a fatal error (see above).
|
|
67 |
|
|
68 |
=back
|
|
69 |
|
|
70 |
=head1 Developer API
|
|
71 |
|
|
72 |
C<FreezeThaw> C<freeze>s and C<thaw>s data blessed in some package by
|
|
73 |
calling methods C<Freeze> and C<Thaw> in the package. The fallback
|
|
74 |
methods are provided by the C<FreezeThaw> itself. The fallback
|
|
75 |
C<Freeze> freezes the "content" of blessed object (from Perl point of
|
|
76 |
view). The fallback C<Thaw> blesses the C<thaw>ed data back into the package.
|
|
77 |
|
|
78 |
So the package needs to define its own methods only if the fallback
|
|
79 |
methods will fail (for example, for a lot of data the "content" of an
|
|
80 |
object is an address of some B<C> data). The methods are called like
|
|
81 |
|
|
82 |
$newcooky = $obj->Freeze($cooky);
|
|
83 |
$obj = Package->Thaw($content,$cooky);
|
|
84 |
|
|
85 |
To save and restore the data the following method are applicable:
|
|
86 |
|
|
87 |
$cooky->FreezeScalar($data,$ignorePackage,$noduplicate);
|
|
88 |
|
|
89 |
during Freeze()ing, and
|
|
90 |
|
|
91 |
$data = $cooky->ThawScalar;
|
|
92 |
|
|
93 |
Two optional arguments $ignorePackage and $noduplicate regulate
|
|
94 |
whether the freezing should not call the methods even if $data is a
|
|
95 |
reference to a blessed object, and whether the data should not be
|
|
96 |
marked as seen already even if it was seen before. The default methods
|
|
97 |
|
|
98 |
sub UNIVERSAL::Freeze {
|
|
99 |
my ($obj, $cooky) = (shift, shift);
|
|
100 |
$cooky->FreezeScalar($obj,1,1);
|
|
101 |
}
|
|
102 |
|
|
103 |
sub UNIVERSAL::Thaw {
|
|
104 |
my ($package, $cooky) = (shift, shift);
|
|
105 |
my $obj = $cooky->ThawScalar;
|
|
106 |
bless $obj, $package;
|
|
107 |
}
|
|
108 |
|
|
109 |
call the C<FreezeScalar> method of the $cooky since the freezing
|
|
110 |
engine will see the data the second time during this call. Indeed, it
|
|
111 |
is the freezing engine who calls UNIVERSAL::Freeze(), and it calls it
|
|
112 |
because it needs to freeze $obj. The above call to
|
|
113 |
$cooky->FreezeScalar() handles the same data back to engine, but
|
|
114 |
because flags are different, the code does not cycle.
|
|
115 |
|
|
116 |
Freezing and thawing $cooky also allows the following additional methods:
|
|
117 |
|
|
118 |
$cooky->isSafe;
|
|
119 |
|
|
120 |
to find out whether the current freeze was initiated by C<freeze> or
|
|
121 |
C<safeFreeze> command. Analogous method for thaw $cooky returns
|
|
122 |
whether the current thaw operation is considered safe (i.e., either
|
|
123 |
does not contain cached elsewhere data, or comes from the same
|
|
124 |
application). You can use
|
|
125 |
|
|
126 |
$cooky->makeSafe;
|
|
127 |
|
|
128 |
to prohibit cached data for the duration of the rest of freezing or
|
|
129 |
thawing of current object.
|
|
130 |
|
|
131 |
Two methods
|
|
132 |
|
|
133 |
$value = $cooky->repeatedOK;
|
|
134 |
$cooky->noRepeated; # Now repeated are prohibited
|
|
135 |
|
|
136 |
allow to find out/change the current setting for allowing repeated
|
|
137 |
references.
|
|
138 |
|
|
139 |
If you want to flush the cache of saved objects you can use
|
|
140 |
|
|
141 |
FreezeThaw->flushCache;
|
|
142 |
|
|
143 |
this can invalidate some frozen string, so that thawing them will
|
|
144 |
result in fatal error.
|
|
145 |
|
|
146 |
=head2 Instantiating
|
|
147 |
|
|
148 |
Sometimes, when an object from a package is recreated in presense of
|
|
149 |
repeated references, it is not safe to recreate the internal structure
|
|
150 |
of an object in one step. In such a situation recreation of an object
|
|
151 |
is carried out in two steps: in the first the object is C<allocate>d,
|
|
152 |
in the second it is C<instantiate>d.
|
|
153 |
|
|
154 |
The restriction is that during the I<allocation> step you cannot use any
|
|
155 |
reference to any Perl object that can be referenced from any other
|
|
156 |
place. This restriction is applied since that object may not exist yet.
|
|
157 |
|
|
158 |
Correspondingly, during I<instantiation> step the previosly I<allocated>
|
|
159 |
object should be C<filled>, i.e., it can be changed in any way such
|
|
160 |
that the references to this object remain valid.
|
|
161 |
|
|
162 |
The methods are called like this:
|
|
163 |
|
|
164 |
$pre_object_ref = Package->Allocate($pre_pre_object_ref);
|
|
165 |
# Returns reference
|
|
166 |
Package->Instantiate($pre_object_ref,$cooky);
|
|
167 |
# Converts into reference to blessed object
|
|
168 |
|
|
169 |
The reverse operations are
|
|
170 |
|
|
171 |
$object_ref->FreezeEmpty($cooky);
|
|
172 |
$object_ref->FreezeInstance($cooky);
|
|
173 |
|
|
174 |
during these calls object can C<freezeScalar> some information (in a
|
|
175 |
usual way) that will be used during C<Allocate> and C<Instantiate>
|
|
176 |
calls (via C<thawScalar>). Note that the return value of
|
|
177 |
C<FreezeEmpty> is cached during the phase of creation of uninialized
|
|
178 |
objects. This B<must> be used like this: the return value is the
|
|
179 |
reference to the created object, so it is not destructed until other
|
|
180 |
objects are created, thus the frozen values of the different objects
|
|
181 |
will not share the same references. Example of bad result:
|
|
182 |
|
|
183 |
$o1->FreezeEmpty($cooky)
|
|
184 |
|
|
185 |
freezes C<{}>, and C<$o2-E<gt>FreezeEmpty($cooky)> makes the same. Now
|
|
186 |
nobody guaranties that that these two copies of C<{}> are different,
|
|
187 |
unless a reference to the first one is preserved during the call to
|
|
188 |
C<$o2-E<gt>FreezeEmpty($cooky)>. If C<$o1-E<gt>FreezeEmpty($cooky)>
|
|
189 |
returns the value of C<{}> it uses, it will be preserved by the
|
|
190 |
engine.
|
|
191 |
|
|
192 |
The helper function C<FreezeThaw::copyContents> is provided for
|
|
193 |
simplification of instantiation. The syntax is
|
|
194 |
|
|
195 |
FreezeThaw::copyContents $to, $from;
|
|
196 |
|
|
197 |
The function copies contents the object $from point to into what the
|
|
198 |
object $to points to (including package for blessed references). Both
|
|
199 |
arguments should be references.
|
|
200 |
|
|
201 |
The default methods are provided. They do the following:
|
|
202 |
|
|
203 |
=over 12
|
|
204 |
|
|
205 |
=item C<FreezeEmpty>
|
|
206 |
|
|
207 |
Freezes an I<empty> object of underlying type.
|
|
208 |
|
|
209 |
=item C<FreezeInstance>
|
|
210 |
|
|
211 |
Calls C<Freeze>.
|
|
212 |
|
|
213 |
=item C<Allocate>
|
|
214 |
|
|
215 |
Thaws what was frozen by C<FreezeEmpty>.
|
|
216 |
|
|
217 |
=item C<Instantiate>
|
|
218 |
|
|
219 |
Thaws what was frozen by C<FreezeInstance>, uses C<copyContents> to
|
|
220 |
transfer this to the $pre_object.
|
|
221 |
|
|
222 |
=back
|
|
223 |
|
|
224 |
=head1 BUGS and LIMITATIONS
|
|
225 |
|
|
226 |
A lot of objects are blessed in some obscure packages by XSUB
|
|
227 |
typemaps. It is not clear how to (automatically) prevent the
|
|
228 |
C<UNIVERSAL> methods to be called for objects in these packages.
|
|
229 |
|
|
230 |
The objects which can survive freeze()/thaw() cycle must also survive a
|
|
231 |
change of a "member" to an equal member. Say, after
|
|
232 |
|
|
233 |
$a = [a => 3];
|
|
234 |
$a->{b} = \ $a->{a};
|
|
235 |
|
|
236 |
$a satisfies
|
|
237 |
|
|
238 |
$a->{b} == \ $a->{a}
|
|
239 |
|
|
240 |
This property will be broken by freeze()/thaw(), but it is also broken by
|
|
241 |
|
|
242 |
$a->{a} = delete $a->{a};
|
|
243 |
|
|
244 |
=cut
|
|
245 |
|
|
246 |
require 5.002; # defined ref stuff...
|
|
247 |
|
|
248 |
# Different line noise chars:
|
|
249 |
#
|
|
250 |
# $567| next 567 chars form a scalar
|
|
251 |
#
|
|
252 |
# @34| next 34 scalars form an array
|
|
253 |
#
|
|
254 |
# %34| next 34 scalars form a hash
|
|
255 |
#
|
|
256 |
# ? next scalar is a safe-stamp at beginning
|
|
257 |
#
|
|
258 |
# ? next scalar is a stringified data
|
|
259 |
#
|
|
260 |
# ! repeated array follows (after a scalar denoting array $#),
|
|
261 |
# (possibly?) followed by instantiation array. At beginning
|
|
262 |
#
|
|
263 |
# <45| ordinal of element in repeated array
|
|
264 |
#
|
|
265 |
# * stringified glob follows
|
|
266 |
#
|
|
267 |
# & stringified coderef follows
|
|
268 |
#
|
|
269 |
# \\ stringified defererenced data follows
|
|
270 |
#
|
|
271 |
# / stringified REx follows
|
|
272 |
#
|
|
273 |
# > stringified package name follows, then frozen data
|
|
274 |
#
|
|
275 |
# { stringified package name follows, then allocation data
|
|
276 |
#
|
|
277 |
# } stringified package name follows, then instantiation data
|
|
278 |
#
|
|
279 |
# _ frozen form of undef
|
|
280 |
|
|
281 |
|
|
282 |
package FreezeThaw;
|
|
283 |
|
|
284 |
use Exporter;
|
|
285 |
|
|
286 |
@ISA = qw(Exporter);
|
|
287 |
$VERSION = '0.43';
|
|
288 |
@EXPORT_OK = qw(freeze thaw cmpStr cmpStrHard safeFreeze);
|
|
289 |
|
|
290 |
use strict;
|
|
291 |
use Carp;
|
|
292 |
|
|
293 |
my $lock = (reverse time) ^ $$ ^ \&freezeString; # To distingush processes
|
|
294 |
|
|
295 |
use vars qw( @multiple
|
|
296 |
%seen_packages
|
|
297 |
$seen_packages
|
|
298 |
%seen_packages
|
|
299 |
%count
|
|
300 |
%address
|
|
301 |
$string
|
|
302 |
$unsafe
|
|
303 |
$noCache
|
|
304 |
$cooky
|
|
305 |
$secondpass
|
|
306 |
), # Localized in freeze()
|
|
307 |
qw( $norepeated ), # Localized in freezeScalar()
|
|
308 |
qw( $uninitOK ), # Localized in thawScalar()
|
|
309 |
qw( @uninit ), # Localized in thaw()
|
|
310 |
qw($safe); # Localized in safeFreeze()
|
|
311 |
my (%saved);
|
|
312 |
|
|
313 |
my %Empty = ( ARRAY => sub {[]}, HASH => sub {{}},
|
|
314 |
SCALAR => sub {my $undef; \$undef},
|
|
315 |
REF => sub {my $undef; \$undef},
|
|
316 |
CODE => 1, # 1 means atomic
|
|
317 |
GLOB => 1,
|
|
318 |
Regexp => 0,
|
|
319 |
);
|
|
320 |
|
|
321 |
|
|
322 |
sub flushCache {$lock ^= rand; undef %saved;}
|
|
323 |
|
|
324 |
sub getref ($) {
|
|
325 |
my $ref = ref $_[0];
|
|
326 |
return $ref if not $ref or defined $Empty{$ref}; # Optimization _and_ Regexp
|
|
327 |
my $str;
|
|
328 |
if (defined &overload::StrVal) {
|
|
329 |
$str = overload::StrVal($_[0]);
|
|
330 |
} else {
|
|
331 |
$str = "$_[0]";
|
|
332 |
}
|
|
333 |
$ref = $1 if $str =~ /=(\w+)/;
|
|
334 |
$ref;
|
|
335 |
}
|
|
336 |
|
|
337 |
sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]}
|
|
338 |
|
|
339 |
sub freezeNumber {$string .= $_[0] . '|'}
|
|
340 |
|
|
341 |
sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]}
|
|
342 |
|
|
343 |
sub thawString { # Returns list: a string and offset of rest
|
|
344 |
substr($string, $_[0]) =~ /^\$(\d+)\|/
|
|
345 |
or confess "Wrong format of frozen string: " . substr($string, $_[0]);
|
|
346 |
length($string) - $_[0] > length($1) + 1 + $1
|
|
347 |
or confess "Frozen string too short: `" .
|
|
348 |
substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1);
|
|
349 |
(substr($string, $_[0] + length($1) + 2, $1), $_[0] + length($1) + 2 + $1);
|
|
350 |
}
|
|
351 |
|
|
352 |
sub thawNumber { # Returns list: a number and offset of rest
|
|
353 |
substr($string, $_[0]) =~ /^(\d+)\|/
|
|
354 |
or confess "Wrong format of frozen string: " . substr($string, $_[0]);
|
|
355 |
($1, $_[0] + length($1) + 1);
|
|
356 |
}
|
|
357 |
|
|
358 |
sub _2rex ($);
|
|
359 |
if (eval '"Regexp" eq ref qr/1/') {
|
|
360 |
eval 'sub _2rex ($) {my $r = shift; qr/$r/} 1' or die;
|
|
361 |
} else {
|
|
362 |
eval 'sub _2rex ($) { shift } 1' or die;
|
|
363 |
}
|
|
364 |
|
|
365 |
sub thawREx { # Returns list: a REx and offset of rest
|
|
366 |
substr($string, $_[0]) =~ m,^/(\d+)\|,
|
|
367 |
or confess "Wrong format of frozen REx: " . substr($string, $_[0]);
|
|
368 |
length($string) - $_[0] > length($1) + 1 + $1
|
|
369 |
or confess "Frozen string too short: `" .
|
|
370 |
substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1);
|
|
371 |
(_2rex substr($string, $_[0] + length($1) + 2, $1),
|
|
372 |
$_[0] + length($1) + 2 + $1);
|
|
373 |
}
|
|
374 |
|
|
375 |
sub freezeArray {
|
|
376 |
$string .= '@' . @{$_[0]} . '|';
|
|
377 |
for (@{$_[0]}) {
|
|
378 |
freezeScalar($_);
|
|
379 |
}
|
|
380 |
}
|
|
381 |
|
|
382 |
sub thawArray {
|
|
383 |
substr($string, $_[0]) =~ /^[\@%](\d+)\|/ # % To make it possible thaw hashes
|
|
384 |
or confess "Wrong format of frozen array: \n$_[0]";
|
|
385 |
my $count = $1;
|
|
386 |
my $off = $_[0] + 2 + length $count;
|
|
387 |
my (@res, $res);
|
|
388 |
while ($count and length $string > $off) {
|
|
389 |
($res,$off) = thawScalar($off);
|
|
390 |
push(@res,$res);
|
|
391 |
--$count;
|
|
392 |
}
|
|
393 |
confess "Wrong length of data in thawing Array: $count left" if $count;
|
|
394 |
(\@res, $off);
|
|
395 |
}
|
|
396 |
|
|
397 |
sub freezeHash {
|
|
398 |
my @arr = sort keys %{$_[0]};
|
|
399 |
$string .= '%' . (2*@arr) . '|';
|
|
400 |
for (@arr, @{$_[0]}{@arr}) {
|
|
401 |
freezeScalar($_);
|
|
402 |
}
|
|
403 |
}
|
|
404 |
|
|
405 |
sub thawHash {
|
|
406 |
my ($arr, $rest) = &thawArray;
|
|
407 |
my %hash;
|
|
408 |
my $l = @$arr/2;
|
|
409 |
foreach (0 .. $l - 1) {
|
|
410 |
$hash{$arr->[$_]} = $arr->[$l + $_];
|
|
411 |
}
|
|
412 |
(\%hash,$rest);
|
|
413 |
}
|
|
414 |
|
|
415 |
# Second optional argument: ignore the package
|
|
416 |
# Third optional one: do not check for duplicates on outer level
|
|
417 |
|
|
418 |
sub freezeScalar {
|
|
419 |
$string .= '_', return unless defined $_[0];
|
|
420 |
return &freezeString unless ref $_[0];
|
|
421 |
my $ref = ref $_[0];
|
|
422 |
my $str;
|
|
423 |
if ($_[1] and $ref) { # Similar to getref()
|
|
424 |
if (defined &overload::StrVal) {
|
|
425 |
$str = overload::StrVal($_[0]);
|
|
426 |
} else {
|
|
427 |
$str = "$_[0]";
|
|
428 |
}
|
|
429 |
$ref = $1 if $str =~ /=(\w+)/;
|
|
430 |
} else {
|
|
431 |
$str = "$_[0]";
|
|
432 |
}
|
|
433 |
# Die if a) repeated prohibited, b) met, c) not explicitely requested to ingore.
|
|
434 |
confess "Repeated reference met when prohibited"
|
|
435 |
if $norepeated && !$_[2] && defined $count{$str};
|
|
436 |
if ($secondpass and !$_[2]) {
|
|
437 |
$string .= "<$address{$str}|", return
|
|
438 |
if defined $count{$str} and $count{$str} > 1;
|
|
439 |
} elsif (!$_[2]) {
|
|
440 |
# $count{$str} is defined if we have seen it on this pass.
|
|
441 |
$address{$str} = @multiple, push(@multiple, $_[0])
|
|
442 |
if defined $count{$str} and not exists $address{$str};
|
|
443 |
# This is for debugging and shortening thrown-away output (also
|
|
444 |
# internal data in arrays and hashes is not duplicated).
|
|
445 |
$string .= "<$address{$str}|", ++$count{$str}, return
|
|
446 |
if defined $count{$str};
|
|
447 |
++$count{$str};
|
|
448 |
}
|
|
449 |
return &freezeArray if $ref eq 'ARRAY';
|
|
450 |
return &freezeHash if $ref eq 'HASH';
|
|
451 |
return &freezeREx if $ref eq 'Regexp' and not defined ${$_[0]};
|
|
452 |
$string .= "*", return &freezeString
|
|
453 |
if $ref eq 'GLOB' and !$safe;
|
|
454 |
$string .= "&", return &freezeString
|
|
455 |
if $ref eq 'CODE' and !$safe;
|
|
456 |
$string .= '\\', return &freezeScalar( $ {shift()} )
|
|
457 |
if $ref eq 'REF' or $ref eq 'SCALAR';
|
|
458 |
if ($noCache and (($ref eq 'CODE') or $ref eq 'GLOB')) {
|
|
459 |
confess "CODE and GLOB references prohibited now";
|
|
460 |
}
|
|
461 |
if ($safe and (($ref eq 'CODE') or $ref eq 'GLOB')) {
|
|
462 |
$unsafe = 1;
|
|
463 |
$saved{$str} = $_[0] unless defined $saved{$str};
|
|
464 |
$string .= "?";
|
|
465 |
return &freezeString;
|
|
466 |
}
|
|
467 |
$string .= '>';
|
|
468 |
local $norepeated = $norepeated;
|
|
469 |
local $noCache = $noCache;
|
|
470 |
freezePackage(ref $_[0]);
|
|
471 |
$_[0]->Freeze($cooky);
|
|
472 |
}
|
|
473 |
|
|
474 |
sub freezePackage {
|
|
475 |
my $packageid = $seen_packages{$_[0]};
|
|
476 |
if (defined $packageid) {
|
|
477 |
$string .= ')';
|
|
478 |
&freezeNumber( $packageid );
|
|
479 |
} else {
|
|
480 |
$string .= '>';
|
|
481 |
&freezeNumber( $seen_packages );
|
|
482 |
&freezeScalar( $_[0] );
|
|
483 |
$seen_packages{ $_[0] } = $seen_packages++;
|
|
484 |
}
|
|
485 |
}
|
|
486 |
|
|
487 |
sub thawPackage { # First argument: offset
|
|
488 |
my $key = substr($string,$_[0],1);
|
|
489 |
my ($get, $rest, $id);
|
|
490 |
($id, $rest) = &thawNumber($_[0] + 1);
|
|
491 |
if ($key eq ')') {
|
|
492 |
$get = $seen_packages{$id};
|
|
493 |
} else {
|
|
494 |
($get, $rest) = &thawString($rest);
|
|
495 |
$seen_packages{$id} = $get;
|
|
496 |
}
|
|
497 |
($get, $rest);
|
|
498 |
}
|
|
499 |
|
|
500 |
# First argument: offset; Optional other: index in the @uninit array
|
|
501 |
|
|
502 |
sub thawScalar {
|
|
503 |
my $key = substr($string,$_[0],1);
|
|
504 |
if ($key eq "\$") {&thawString}
|
|
505 |
elsif ($key eq '@') {&thawArray}
|
|
506 |
elsif ($key eq '%') {&thawHash}
|
|
507 |
elsif ($key eq '/') {&thawREx}
|
|
508 |
elsif ($key eq '\\') {
|
|
509 |
my ($out,$rest) = &thawScalar( $_[0]+1 ) ;
|
|
510 |
(\$out,$rest);
|
|
511 |
}
|
|
512 |
elsif ($key eq '_') { (undef, $_[0]+1) }
|
|
513 |
elsif ($key eq '&') {confess "Do not know how to thaw CODE"}
|
|
514 |
elsif ($key eq '*') {confess "Do not know how to thaw GLOB"}
|
|
515 |
elsif ($key eq '?') {
|
|
516 |
my ($address,$rest) = &thawScalar( $_[0]+1 ) ;
|
|
517 |
confess "The saved data accessed in unprotected thaw" unless $unsafe;
|
|
518 |
confess "The saved data disappeared somewhere"
|
|
519 |
unless defined $saved{$address};
|
|
520 |
($saved{$address},$rest);
|
|
521 |
} elsif ($key eq '<') {
|
|
522 |
confess "Repeated data prohibited at this moment" unless $uninitOK;
|
|
523 |
my ($off,$end) = &thawNumber ($_[0]+1);
|
|
524 |
($uninit[$off],$end);
|
|
525 |
} elsif ($key eq '>' or $key eq '{' or $key eq '}') {
|
|
526 |
my ($package,$rest) = &thawPackage( $_[0]+1 );
|
|
527 |
my $cooky = bless \$rest, 'FreezeThaw::TCooky';
|
|
528 |
local $uninitOK = $uninitOK;
|
|
529 |
local $unsafe = $unsafe;
|
|
530 |
if ($key eq '{') {
|
|
531 |
my $res = $package->Allocate($cooky);
|
|
532 |
($res, $rest);
|
|
533 |
} elsif ($key eq '}') {
|
|
534 |
warn "Here it is undef!" unless defined $_[1];
|
|
535 |
$package->Instantiate($uninit[$_[1]],$cooky);
|
|
536 |
(undef, $rest);
|
|
537 |
} else {
|
|
538 |
($package->Thaw($cooky),$rest);
|
|
539 |
}
|
|
540 |
} else {
|
|
541 |
confess "Do not know how to thaw data with code `$key'";
|
|
542 |
}
|
|
543 |
}
|
|
544 |
|
|
545 |
sub freezeEmpty { # Takes a type, freezes ref to empty object
|
|
546 |
my $e = $Empty{ref $_[0]};
|
|
547 |
if (ref $e) {
|
|
548 |
my $cache = &$e;
|
|
549 |
freezeScalar $cache;
|
|
550 |
$cache;
|
|
551 |
} elsif ($e) {
|
|
552 |
my $cache = shift;
|
|
553 |
freezeScalar($cache,1,1); # Atomic
|
|
554 |
$cache;
|
|
555 |
} else {
|
|
556 |
$string .= "{";
|
|
557 |
freezePackage ref $_[0];
|
|
558 |
$_[0]->FreezeEmpty($cooky);
|
|
559 |
}
|
|
560 |
}
|
|
561 |
|
|
562 |
sub freeze {
|
|
563 |
local @multiple;
|
|
564 |
local %seen_packages;
|
|
565 |
local $seen_packages = 0;
|
|
566 |
local %seen_packages;
|
|
567 |
# local @seentypes;
|
|
568 |
local %count;
|
|
569 |
local %address;
|
|
570 |
local $string = 'FrT;';
|
|
571 |
local $unsafe;
|
|
572 |
local $noCache;
|
|
573 |
local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake
|
|
574 |
local $secondpass;
|
|
575 |
freezeScalar(\@_);
|
|
576 |
if (@multiple) {
|
|
577 |
# Now repeated structures are enumerated with order of *second* time
|
|
578 |
# they appear in the what we freeze.
|
|
579 |
# What we want is to have them enumerated with respect to the first time
|
|
580 |
#### $string = ''; # Start again
|
|
581 |
#### @multiple = ();
|
|
582 |
#### %address = ();
|
|
583 |
#### for (keys %count) {
|
|
584 |
#### $count{$_} = undef if $count{$_} <= 1; # As at start
|
|
585 |
#### $count{$_} = 0 if $count{$_}; # As at start
|
|
586 |
#### }
|
|
587 |
#### $seen_packages = 0;
|
|
588 |
#### %seen_packages = ();
|
|
589 |
#### freezeScalar(\@_);
|
|
590 |
# Now repeated structures are enumerated with order of first time
|
|
591 |
# they appear in the what we freeze
|
|
592 |
#### my $oldstring = substr $string, 4;
|
|
593 |
$string = 'FrT;!'; # Start again
|
|
594 |
$seen_packages = 0;
|
|
595 |
%seen_packages = (); # XXXX We reshuffle parts of the
|
|
596 |
# string, so the order of packages may
|
|
597 |
# be wrong...
|
|
598 |
freezeNumber($#multiple);
|
|
599 |
{
|
|
600 |
my @cache; # Force different values for different
|
|
601 |
# empty objects.
|
|
602 |
foreach (@multiple) {
|
|
603 |
push @cache, freezeEmpty $_;
|
|
604 |
}
|
|
605 |
}
|
|
606 |
# for (keys %count) {
|
|
607 |
# $count{$_} = undef
|
|
608 |
# if !(defined $count{$_}) or $count{$_} <= 1; # As at start
|
|
609 |
# }
|
|
610 |
# $string .= '@' . @multiple . '|';
|
|
611 |
$secondpass = 1;
|
|
612 |
for (@multiple) {
|
|
613 |
freezeScalar($_,0,1,1), next if $Empty{ref $_};
|
|
614 |
$string .= "}";
|
|
615 |
freezePackage ref $_;
|
|
616 |
$_->FreezeInstance($cooky);
|
|
617 |
}
|
|
618 |
#### $string .= $oldstring;
|
|
619 |
freezeScalar(\@_);
|
|
620 |
}
|
|
621 |
return "FrT;?\$" . length($lock) . "|" . $lock . substr $string, 4
|
|
622 |
if $unsafe;
|
|
623 |
$string;
|
|
624 |
}
|
|
625 |
|
|
626 |
sub safeFreeze {
|
|
627 |
local $safe = 1;
|
|
628 |
&freeze;
|
|
629 |
}
|
|
630 |
|
|
631 |
sub copyContents { # Given two references, copies contents of the
|
|
632 |
# second one to the first one, provided they have
|
|
633 |
# the same basic type. The package is copied too.
|
|
634 |
my($first,$second) = @_;
|
|
635 |
my $ref = getref $second;
|
|
636 |
if ($ref eq 'SCALAR' or $ref eq 'REF') {
|
|
637 |
$$first = $$second;
|
|
638 |
} elsif ($ref eq 'ARRAY') {
|
|
639 |
@$first = @$second;
|
|
640 |
} elsif ($ref eq 'HASH') {
|
|
641 |
%$first = %$second;
|
|
642 |
} else {
|
|
643 |
croak "Don't know how to copyContents of type `$ref'";
|
|
644 |
}
|
|
645 |
if (ref $second ne ref $first) { # Rebless
|
|
646 |
# SvAMAGIC() is a property of a reference, not of a referent!
|
|
647 |
# Thus we cannot use $first here if $second was overloaded...
|
|
648 |
bless $_[0], ref $second;
|
|
649 |
}
|
|
650 |
$first;
|
|
651 |
}
|
|
652 |
|
|
653 |
sub thaw {
|
|
654 |
confess "thaw requires one argument" unless @_ ==1;
|
|
655 |
local $string = shift;
|
|
656 |
local %seen_packages;
|
|
657 |
my $initoff = 0;
|
|
658 |
#print STDERR "Thawing `$string'", substr ($string, 0, 4), "\n";
|
|
659 |
if (substr($string, 0, 4) ne 'FrT;') {
|
|
660 |
warn "Signature not present, continuing anyway" if $^W;
|
|
661 |
} else {
|
|
662 |
$initoff = 4;
|
|
663 |
}
|
|
664 |
local $unsafe = $initoff + (substr($string, $initoff, 1) eq "?" ? 1 : 0);
|
|
665 |
if ($unsafe != $initoff) {
|
|
666 |
my $key;
|
|
667 |
($key,$unsafe) = thawScalar($unsafe);
|
|
668 |
confess "The lock in frozen data does not match the key"
|
|
669 |
unless $key eq $lock;
|
|
670 |
}
|
|
671 |
local @multiple;
|
|
672 |
local $uninitOK = 1; # The methods can change it.
|
|
673 |
my $repeated = substr($string,$unsafe,1) eq '!' ? 1 : 0;
|
|
674 |
my ($res, $off);
|
|
675 |
if ($repeated) {
|
|
676 |
($res, $off) = thawNumber($repeated + $unsafe);
|
|
677 |
} else {
|
|
678 |
($res, $off) = thawScalar($repeated + $unsafe);
|
|
679 |
}
|
|
680 |
my $cooky = bless \$off, 'FreezeThaw::TCooky';
|
|
681 |
if ($repeated) {
|
|
682 |
local @uninit;
|
|
683 |
my $lst = $res;
|
|
684 |
foreach (0..$lst) {
|
|
685 |
($res, $off) = thawScalar($off, $_);
|
|
686 |
push(@uninit, $res);
|
|
687 |
}
|
|
688 |
my @init;
|
|
689 |
foreach (0..$lst) {
|
|
690 |
($res, $off) = thawScalar($off, $_);
|
|
691 |
push(@init, $res);
|
|
692 |
}
|
|
693 |
#($init, $off) = thawScalar($off);
|
|
694 |
#print "Instantiating...\n";
|
|
695 |
#my $ref;
|
|
696 |
for (0..$#uninit) {
|
|
697 |
copyContents $uninit[$_], $init[$_] if ref $init[$_];
|
|
698 |
}
|
|
699 |
($res, $off) = thawScalar($off);
|
|
700 |
}
|
|
701 |
croak "Extra elements in frozen structure: `" . substr($string,$off) . "'"
|
|
702 |
if $off != length $string;
|
|
703 |
return @$res;
|
|
704 |
}
|
|
705 |
|
|
706 |
sub cmpStr {
|
|
707 |
confess "Compare requires two arguments" unless @_ == 2;
|
|
708 |
freeze(shift) cmp freeze(shift);
|
|
709 |
}
|
|
710 |
|
|
711 |
sub cmpStrHard {
|
|
712 |
confess "Compare requires two arguments" unless @_ == 2;
|
|
713 |
local @multiple;
|
|
714 |
# local @seentypes;
|
|
715 |
local %count;
|
|
716 |
local %address;
|
|
717 |
local $string = 'FrT;';
|
|
718 |
local $unsafe;
|
|
719 |
local $noCache;
|
|
720 |
local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake
|
|
721 |
freezeScalar($_[0]);
|
|
722 |
my %cnt1 = %count;
|
|
723 |
freezeScalar($_[1]);
|
|
724 |
my %cnt2 = %count;
|
|
725 |
%count = ();
|
|
726 |
# Now all the caches are filled, delete the entries for guys which
|
|
727 |
# are in one argument only.
|
|
728 |
my ($elt, $val);
|
|
729 |
while (($elt, $val) = each %cnt1) {
|
|
730 |
$count{$elt}++ if $cnt2{$elt} > $cnt1{$elt};
|
|
731 |
}
|
|
732 |
$string = '';
|
|
733 |
freezeScalar($_[0]);
|
|
734 |
my $str1 = $string;
|
|
735 |
$string = '';
|
|
736 |
freezeScalar($_[1]);
|
|
737 |
$str1 cmp $string;
|
|
738 |
}
|
|
739 |
|
|
740 |
# local $string = freeze(shift,shift);
|
|
741 |
# local $uninitOK = 1;
|
|
742 |
# #print "$string\n";
|
|
743 |
# my $off = 7; # Hardwired offset after @2|
|
|
744 |
# if (substr($string,4,1) eq '!') {
|
|
745 |
# $off = 5; # Hardwired offset after !
|
|
746 |
# my ($uninit, $len);
|
|
747 |
# ($len,$off) = thawScalar $off;
|
|
748 |
# local @uninit;
|
|
749 |
# foreach (0..$len) {
|
|
750 |
# ($uninit,$off) = thawScalar $off, $_;
|
|
751 |
# }
|
|
752 |
# $off += 3; # Hardwired offset after @2|
|
|
753 |
# }
|
|
754 |
# croak "Unknown format of frozen array: " . substr($string,$off-3)
|
|
755 |
# unless substr($string,$off-3,1) eq '@';
|
|
756 |
# my ($first,$off2) = thawScalar $off;
|
|
757 |
# my $off3;
|
|
758 |
# ($first,$off3) = thawScalar $off2;
|
|
759 |
# substr($string, $off, $off2-$off) cmp substr($string,$off2,$off3-$off2);
|
|
760 |
# }
|
|
761 |
|
|
762 |
sub FreezeThaw::FCooky::FreezeScalar {
|
|
763 |
shift;
|
|
764 |
&freezeScalar;
|
|
765 |
}
|
|
766 |
|
|
767 |
sub FreezeThaw::FCooky::isSafe {
|
|
768 |
$safe || $noCache;
|
|
769 |
}
|
|
770 |
|
|
771 |
sub FreezeThaw::FCooky::makeSafe {
|
|
772 |
$noCache = 1;
|
|
773 |
}
|
|
774 |
|
|
775 |
sub FreezeThaw::FCooky::repeatedOK {
|
|
776 |
!$norepeated;
|
|
777 |
}
|
|
778 |
|
|
779 |
sub FreezeThaw::FCooky::noRepeated {
|
|
780 |
$norepeated = 1;
|
|
781 |
}
|
|
782 |
|
|
783 |
sub FreezeThaw::TCooky::repeatedOK {
|
|
784 |
$uninitOK;
|
|
785 |
}
|
|
786 |
|
|
787 |
sub FreezeThaw::TCooky::noRepeated {
|
|
788 |
undef $uninitOK;
|
|
789 |
}
|
|
790 |
|
|
791 |
sub FreezeThaw::TCooky::isSafe {
|
|
792 |
!$unsafe;
|
|
793 |
}
|
|
794 |
|
|
795 |
sub FreezeThaw::TCooky::makeSafe {
|
|
796 |
undef $unsafe;
|
|
797 |
}
|
|
798 |
|
|
799 |
sub FreezeThaw::TCooky::ThawScalar {
|
|
800 |
my $self = shift;
|
|
801 |
my ($res,$off) = &thawScalar($$self);
|
|
802 |
$$self = $off;
|
|
803 |
$res;
|
|
804 |
}
|
|
805 |
|
|
806 |
sub UNIVERSAL::Freeze {
|
|
807 |
my ($obj, $cooky) = (shift, shift);
|
|
808 |
$cooky->FreezeScalar($obj,1,1);
|
|
809 |
}
|
|
810 |
|
|
811 |
sub UNIVERSAL::Thaw {
|
|
812 |
my ($package, $cooky) = (shift, shift);
|
|
813 |
my $obj = $cooky->ThawScalar;
|
|
814 |
bless $obj, $package;
|
|
815 |
}
|
|
816 |
|
|
817 |
sub UNIVERSAL::FreezeInstance {
|
|
818 |
my($obj,$cooky) = @_;
|
|
819 |
return if (ref $obj and ref $obj eq 'Regexp' and not defined $$obj); # Regexp
|
|
820 |
$obj->Freeze($cooky);
|
|
821 |
}
|
|
822 |
|
|
823 |
sub UNIVERSAL::Instantiate {
|
|
824 |
my($package,$pre,$cooky) = @_;
|
|
825 |
return if $package eq 'Regexp';
|
|
826 |
my $obj = $package->Thaw($cooky);
|
|
827 |
# SvAMAGIC() is a property of a reference, not of a referent!
|
|
828 |
# Thus we cannot use $pre here if $obj was overloaded...
|
|
829 |
copyContents $_[1], $obj;
|
|
830 |
}
|
|
831 |
|
|
832 |
sub UNIVERSAL::Allocate {
|
|
833 |
my($package,$cooky) = @_;
|
|
834 |
$cooky->ThawScalar;
|
|
835 |
}
|
|
836 |
|
|
837 |
sub UNIVERSAL::FreezeEmpty {
|
|
838 |
my $obj = shift;
|
|
839 |
my $type = getref $obj;
|
|
840 |
my $e = $Empty{$type};
|
|
841 |
if (ref $e) {
|
|
842 |
my $ref = &$e;
|
|
843 |
freezeScalar $ref;
|
|
844 |
$ref; # Put into cache.
|
|
845 |
} elsif ($e) {
|
|
846 |
freezeScalar($obj,1,1); # Atomic
|
|
847 |
undef;
|
|
848 |
} elsif (defined $e and not defined $$obj) { # Regexp
|
|
849 |
freezeREx($obj);
|
|
850 |
undef;
|
|
851 |
} else {
|
|
852 |
die "Do not know how to FreezeEmpty $type";
|
|
853 |
}
|
|
854 |
}
|
|
855 |
|
|
856 |
1;
|