forked from openkylin/libfreezethaw-perl
Compare commits
No commits in common. "openkylin/yangtze" and "pristine-tar" have entirely different histories.
openkylin/
...
pristine-t
40
Changes
40
Changes
|
|
@ -1,40 +0,0 @@
|
||||||
Version 0.2:
|
|
||||||
The frozen info starts with 'FrT;'. Warning if not - nonfatal.
|
|
||||||
Results of freezeEmpty are cached, explanation about caching
|
|
||||||
FreezeEmpty added.
|
|
||||||
At last, all the tests are OK.
|
|
||||||
Little bit more compact backreferences.
|
|
||||||
Version 0.2:
|
|
||||||
New tests added and work.
|
|
||||||
"Repeated" handled much cleaner now (basing on $secondpass).
|
|
||||||
Packages are stored in a more compact form.
|
|
||||||
Numbers are stored in a more compact form.
|
|
||||||
Version 0.4:
|
|
||||||
Can handle overloaded objects.
|
|
||||||
Version 0.41:
|
|
||||||
Bug in detecting duplicated overloaded objects fixed.
|
|
||||||
(When Reissued:)
|
|
||||||
Remove wrong comments on faking out tests in t/*.
|
|
||||||
Add a POD section on limitations.
|
|
||||||
Version 0.42:
|
|
||||||
Fix test for a change of string representation of Math::BigInt.
|
|
||||||
Support qr// objects (via UNIVERSAL, so if Regexp supports
|
|
||||||
(de)serialization methods, they will be used instead).
|
|
||||||
`use strict'-complient.
|
|
||||||
Version 0.43:
|
|
||||||
Correct save/restore of overloaded values, including repeated refs.
|
|
||||||
Version 0.44:
|
|
||||||
Optimize thaw; apparently, with 5.8.8 \G in REx is not optimized;
|
|
||||||
so implement along lines suggested by Bram [wizbit] (about 5x speedup
|
|
||||||
in some test cases).
|
|
||||||
Version 0.45:
|
|
||||||
Maxpointer decimal width was wrongly calculated on 64bit machines with
|
|
||||||
narrow NVs.
|
|
||||||
Version 0.5
|
|
||||||
Support RExes of 5.11 and later (XXXX but not yet reblessed ones...)
|
|
||||||
(prototype by Andreas Koenig)
|
|
||||||
Version 0.5001
|
|
||||||
Switch to a course version-check to recognize that regexps are
|
|
||||||
first-level (otherwise would need to rely on Scalar::Utils).
|
|
||||||
(Tested to work with 5.8, 5.10, 5.11.)
|
|
||||||
|
|
||||||
890
FreezeThaw.pm
890
FreezeThaw.pm
|
|
@ -1,890 +0,0 @@
|
||||||
=head1 NAME
|
|
||||||
|
|
||||||
FreezeThaw - converting Perl structures to strings and back.
|
|
||||||
|
|
||||||
=head1 SYNOPSIS
|
|
||||||
|
|
||||||
use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
|
|
||||||
$string = freeze $data1, $data2, $data3;
|
|
||||||
...
|
|
||||||
($olddata1, $olddata2, $olddata3) = thaw $string;
|
|
||||||
if (cmpStr($olddata2,$data2) == 0) {print "OK!"}
|
|
||||||
|
|
||||||
=head1 DESCRIPTION
|
|
||||||
|
|
||||||
Converts data to/from stringified form, appropriate for
|
|
||||||
saving-to/reading-from permanent storage.
|
|
||||||
|
|
||||||
Deals with objects, circular lists, repeated appearence of the same
|
|
||||||
refence. Does not deal with overloaded I<stringify> operator yet.
|
|
||||||
|
|
||||||
=head1 EXPORT
|
|
||||||
|
|
||||||
=over 12
|
|
||||||
|
|
||||||
=item Default
|
|
||||||
|
|
||||||
None.
|
|
||||||
|
|
||||||
=item Exportable
|
|
||||||
|
|
||||||
C<freeze thaw cmpStr cmpStrHard safeFreeze>.
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 User API
|
|
||||||
|
|
||||||
=over 12
|
|
||||||
|
|
||||||
=item C<cmpStr>
|
|
||||||
|
|
||||||
analogue of C<cmp> for data. Takes two arguments and compares them as
|
|
||||||
separate entities.
|
|
||||||
|
|
||||||
=item C<cmpStrHard>
|
|
||||||
|
|
||||||
analogue of C<cmp> for data. Takes two arguments and compares them
|
|
||||||
considered as a group.
|
|
||||||
|
|
||||||
=item C<freeze>
|
|
||||||
|
|
||||||
returns a string that encupsulates its arguments (considered as a
|
|
||||||
group). C<thaw>ing this string leads to a fatal error if arguments to
|
|
||||||
C<freeze> contained references to C<GLOB>s and C<CODE>s.
|
|
||||||
|
|
||||||
=item C<safeFreeze>
|
|
||||||
|
|
||||||
returns a string that encupsulates its arguments (considered as a
|
|
||||||
group). The result is C<thaw>able in the same process. C<thaw>ing the
|
|
||||||
result in a different process should result in a fatal error if
|
|
||||||
arguments to C<safeFreeze> contained references to C<GLOB>s and
|
|
||||||
C<CODE>s.
|
|
||||||
|
|
||||||
=item C<thaw>
|
|
||||||
|
|
||||||
takes one string argument and returns an array. The elements of the
|
|
||||||
array are "equivalent" to arguments of the C<freeze> command that
|
|
||||||
created the string. Can result in a fatal error (see above).
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 Developer API
|
|
||||||
|
|
||||||
C<FreezeThaw> C<freeze>s and C<thaw>s data blessed in some package by
|
|
||||||
calling methods C<Freeze> and C<Thaw> in the package. The fallback
|
|
||||||
methods are provided by the C<FreezeThaw> itself. The fallback
|
|
||||||
C<Freeze> freezes the "content" of blessed object (from Perl point of
|
|
||||||
view). The fallback C<Thaw> blesses the C<thaw>ed data back into the package.
|
|
||||||
|
|
||||||
So the package needs to define its own methods only if the fallback
|
|
||||||
methods will fail (for example, for a lot of data the "content" of an
|
|
||||||
object is an address of some B<C> data). The methods are called like
|
|
||||||
|
|
||||||
$newcooky = $obj->Freeze($cooky);
|
|
||||||
$obj = Package->Thaw($content,$cooky);
|
|
||||||
|
|
||||||
To save and restore the data the following method are applicable:
|
|
||||||
|
|
||||||
$cooky->FreezeScalar($data,$ignorePackage,$noduplicate);
|
|
||||||
|
|
||||||
during Freeze()ing, and
|
|
||||||
|
|
||||||
$data = $cooky->ThawScalar;
|
|
||||||
|
|
||||||
Two optional arguments $ignorePackage and $noduplicate regulate
|
|
||||||
whether the freezing should not call the methods even if $data is a
|
|
||||||
reference to a blessed object, and whether the data should not be
|
|
||||||
marked as seen already even if it was seen before. The default methods
|
|
||||||
|
|
||||||
sub UNIVERSAL::Freeze {
|
|
||||||
my ($obj, $cooky) = (shift, shift);
|
|
||||||
$cooky->FreezeScalar($obj,1,1);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::Thaw {
|
|
||||||
my ($package, $cooky) = (shift, shift);
|
|
||||||
my $obj = $cooky->ThawScalar;
|
|
||||||
bless $obj, $package;
|
|
||||||
}
|
|
||||||
|
|
||||||
call the C<FreezeScalar> method of the $cooky since the freezing
|
|
||||||
engine will see the data the second time during this call. Indeed, it
|
|
||||||
is the freezing engine who calls UNIVERSAL::Freeze(), and it calls it
|
|
||||||
because it needs to freeze $obj. The above call to
|
|
||||||
$cooky->FreezeScalar() handles the same data back to engine, but
|
|
||||||
because flags are different, the code does not cycle.
|
|
||||||
|
|
||||||
Freezing and thawing $cooky also allows the following additional methods:
|
|
||||||
|
|
||||||
$cooky->isSafe;
|
|
||||||
|
|
||||||
to find out whether the current freeze was initiated by C<freeze> or
|
|
||||||
C<safeFreeze> command. Analogous method for thaw $cooky returns
|
|
||||||
whether the current thaw operation is considered safe (i.e., either
|
|
||||||
does not contain cached elsewhere data, or comes from the same
|
|
||||||
application). You can use
|
|
||||||
|
|
||||||
$cooky->makeSafe;
|
|
||||||
|
|
||||||
to prohibit cached data for the duration of the rest of freezing or
|
|
||||||
thawing of current object.
|
|
||||||
|
|
||||||
Two methods
|
|
||||||
|
|
||||||
$value = $cooky->repeatedOK;
|
|
||||||
$cooky->noRepeated; # Now repeated are prohibited
|
|
||||||
|
|
||||||
allow to find out/change the current setting for allowing repeated
|
|
||||||
references.
|
|
||||||
|
|
||||||
If you want to flush the cache of saved objects you can use
|
|
||||||
|
|
||||||
FreezeThaw->flushCache;
|
|
||||||
|
|
||||||
this can invalidate some frozen string, so that thawing them will
|
|
||||||
result in fatal error.
|
|
||||||
|
|
||||||
=head2 Instantiating
|
|
||||||
|
|
||||||
Sometimes, when an object from a package is recreated in presense of
|
|
||||||
repeated references, it is not safe to recreate the internal structure
|
|
||||||
of an object in one step. In such a situation recreation of an object
|
|
||||||
is carried out in two steps: in the first the object is C<allocate>d,
|
|
||||||
in the second it is C<instantiate>d.
|
|
||||||
|
|
||||||
The restriction is that during the I<allocation> step you cannot use any
|
|
||||||
reference to any Perl object that can be referenced from any other
|
|
||||||
place. This restriction is applied since that object may not exist yet.
|
|
||||||
|
|
||||||
Correspondingly, during I<instantiation> step the previosly I<allocated>
|
|
||||||
object should be C<filled>, i.e., it can be changed in any way such
|
|
||||||
that the references to this object remain valid.
|
|
||||||
|
|
||||||
The methods are called like this:
|
|
||||||
|
|
||||||
$pre_object_ref = Package->Allocate($pre_pre_object_ref);
|
|
||||||
# Returns reference
|
|
||||||
Package->Instantiate($pre_object_ref,$cooky);
|
|
||||||
# Converts into reference to blessed object
|
|
||||||
|
|
||||||
The reverse operations are
|
|
||||||
|
|
||||||
$object_ref->FreezeEmpty($cooky);
|
|
||||||
$object_ref->FreezeInstance($cooky);
|
|
||||||
|
|
||||||
during these calls object can C<freezeScalar> some information (in a
|
|
||||||
usual way) that will be used during C<Allocate> and C<Instantiate>
|
|
||||||
calls (via C<thawScalar>). Note that the return value of
|
|
||||||
C<FreezeEmpty> is cached during the phase of creation of uninialized
|
|
||||||
objects. This B<must> be used like this: the return value is the
|
|
||||||
reference to the created object, so it is not destructed until other
|
|
||||||
objects are created, thus the frozen values of the different objects
|
|
||||||
will not share the same references. Example of bad result:
|
|
||||||
|
|
||||||
$o1->FreezeEmpty($cooky)
|
|
||||||
|
|
||||||
freezes C<{}>, and C<$o2-E<gt>FreezeEmpty($cooky)> makes the same. Now
|
|
||||||
nobody guaranties that that these two copies of C<{}> are different,
|
|
||||||
unless a reference to the first one is preserved during the call to
|
|
||||||
C<$o2-E<gt>FreezeEmpty($cooky)>. If C<$o1-E<gt>FreezeEmpty($cooky)>
|
|
||||||
returns the value of C<{}> it uses, it will be preserved by the
|
|
||||||
engine.
|
|
||||||
|
|
||||||
The helper function C<FreezeThaw::copyContents> is provided for
|
|
||||||
simplification of instantiation. The syntax is
|
|
||||||
|
|
||||||
FreezeThaw::copyContents $to, $from;
|
|
||||||
|
|
||||||
The function copies contents the object $from point to into what the
|
|
||||||
object $to points to (including package for blessed references). Both
|
|
||||||
arguments should be references.
|
|
||||||
|
|
||||||
The default methods are provided. They do the following:
|
|
||||||
|
|
||||||
=over 12
|
|
||||||
|
|
||||||
=item C<FreezeEmpty>
|
|
||||||
|
|
||||||
Freezes an I<empty> object of underlying type.
|
|
||||||
|
|
||||||
=item C<FreezeInstance>
|
|
||||||
|
|
||||||
Calls C<Freeze>.
|
|
||||||
|
|
||||||
=item C<Allocate>
|
|
||||||
|
|
||||||
Thaws what was frozen by C<FreezeEmpty>.
|
|
||||||
|
|
||||||
=item C<Instantiate>
|
|
||||||
|
|
||||||
Thaws what was frozen by C<FreezeInstance>, uses C<copyContents> to
|
|
||||||
transfer this to the $pre_object.
|
|
||||||
|
|
||||||
=back
|
|
||||||
|
|
||||||
=head1 BUGS and LIMITATIONS
|
|
||||||
|
|
||||||
A lot of objects are blessed in some obscure packages by XSUB
|
|
||||||
typemaps. It is not clear how to (automatically) prevent the
|
|
||||||
C<UNIVERSAL> methods to be called for objects in these packages.
|
|
||||||
|
|
||||||
The objects which can survive freeze()/thaw() cycle must also survive a
|
|
||||||
change of a "member" to an equal member. Say, after
|
|
||||||
|
|
||||||
$a = [a => 3];
|
|
||||||
$a->{b} = \ $a->{a};
|
|
||||||
|
|
||||||
$a satisfies
|
|
||||||
|
|
||||||
$a->{b} == \ $a->{a}
|
|
||||||
|
|
||||||
This property will be broken by freeze()/thaw(), but it is also broken by
|
|
||||||
|
|
||||||
$a->{a} = delete $a->{a};
|
|
||||||
|
|
||||||
=cut
|
|
||||||
|
|
||||||
require 5.002; # defined ref stuff...
|
|
||||||
|
|
||||||
# Different line noise chars:
|
|
||||||
#
|
|
||||||
# $567| next 567 chars form a scalar
|
|
||||||
#
|
|
||||||
# @34| next 34 scalars form an array
|
|
||||||
#
|
|
||||||
# %34| next 34 scalars form a hash
|
|
||||||
#
|
|
||||||
# ? next scalar is a safe-stamp at beginning
|
|
||||||
#
|
|
||||||
# ? next scalar is a stringified data
|
|
||||||
#
|
|
||||||
# ! repeated array follows (after a scalar denoting array $#),
|
|
||||||
# (possibly?) followed by instantiation array. At beginning
|
|
||||||
#
|
|
||||||
# <45| ordinal of element in repeated array
|
|
||||||
#
|
|
||||||
# * stringified glob follows
|
|
||||||
#
|
|
||||||
# & stringified coderef follows
|
|
||||||
#
|
|
||||||
# \\ stringified defererenced data follows
|
|
||||||
#
|
|
||||||
# / stringified REx follows
|
|
||||||
#
|
|
||||||
# > stringified package name follows, then frozen data
|
|
||||||
#
|
|
||||||
# { stringified package name follows, then allocation data
|
|
||||||
#
|
|
||||||
# } stringified package name follows, then instantiation data
|
|
||||||
#
|
|
||||||
# _ frozen form of undef
|
|
||||||
|
|
||||||
|
|
||||||
package FreezeThaw;
|
|
||||||
|
|
||||||
use Exporter;
|
|
||||||
|
|
||||||
@ISA = qw(Exporter);
|
|
||||||
$VERSION = '0.5001';
|
|
||||||
@EXPORT_OK = qw(freeze thaw cmpStr cmpStrHard safeFreeze);
|
|
||||||
|
|
||||||
use strict;
|
|
||||||
use Carp;
|
|
||||||
|
|
||||||
my $lock = (reverse time) ^ $$ ^ \&freezeString; # To distingush processes
|
|
||||||
|
|
||||||
use vars qw( @multiple
|
|
||||||
%seen_packages
|
|
||||||
$seen_packages
|
|
||||||
%seen_packages
|
|
||||||
%count
|
|
||||||
%address
|
|
||||||
$string
|
|
||||||
$unsafe
|
|
||||||
$noCache
|
|
||||||
$cooky
|
|
||||||
$secondpass
|
|
||||||
), # Localized in freeze()
|
|
||||||
qw( $norepeated ), # Localized in freezeScalar()
|
|
||||||
qw( $uninitOK ), # Localized in thawScalar()
|
|
||||||
qw( @uninit ), # Localized in thaw()
|
|
||||||
qw($safe); # Localized in safeFreeze()
|
|
||||||
|
|
||||||
BEGIN { # allow optimization away
|
|
||||||
my $haveIsRex = defined &re::is_regexp;
|
|
||||||
my $RexIsREGEXP = ($haveIsRex and # 'REGEXP' eq ref qr/1/); # First-class REX
|
|
||||||
$] >= 5.011); # Code like above requires Scalar::Utils::reftype
|
|
||||||
eval <<EOE or die;
|
|
||||||
sub haveIsRex () {$haveIsRex}
|
|
||||||
sub RexIsREGEXP () {$RexIsREGEXP}
|
|
||||||
1
|
|
||||||
EOE
|
|
||||||
}
|
|
||||||
|
|
||||||
my (%saved);
|
|
||||||
|
|
||||||
my %Empty = ( ARRAY => sub {[]}, HASH => sub {{}},
|
|
||||||
SCALAR => sub {my $undef; \$undef},
|
|
||||||
REF => sub {my $undef; \$undef},
|
|
||||||
CODE => 1, # 1 means atomic
|
|
||||||
GLOB => 1,
|
|
||||||
(RexIsREGEXP
|
|
||||||
? (Regexp => sub {my $qr = qr//})
|
|
||||||
: (Regexp => 0)),
|
|
||||||
);
|
|
||||||
|
|
||||||
# This should better be done via pos() and \G, but apparently \G is not
|
|
||||||
# optimized (bug in the REx optimizer???)
|
|
||||||
BEGIN {
|
|
||||||
my $pointer_size = length pack 'p', 0;
|
|
||||||
#my $max_dig0 = 3*$pointer_size; # 8bits take less than 3 decimals
|
|
||||||
# Now calculate the exact value:
|
|
||||||
#my $max_pointer = sprintf "%.${max_dig0}g", 0x100**$pointer_size;
|
|
||||||
my $max_pointer = sprintf "%.0f", 0x100**$pointer_size;
|
|
||||||
die "Panic" if $max_pointer =~ /\D/;
|
|
||||||
my $max_pointer_l = length $max_pointer;
|
|
||||||
warn "Max pointer_l=$max_pointer_l" if $ENV{FREEZE_THAW_WARN};
|
|
||||||
eval "sub max_strlen_l () {$max_pointer_l}; 1" or die;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub flushCache {$lock ^= rand; undef %saved;}
|
|
||||||
|
|
||||||
sub getref ($) {
|
|
||||||
my $ref = ref $_[0];
|
|
||||||
return $ref if not $ref or defined $Empty{$ref}; # Optimization _and_ Regexp
|
|
||||||
my $str;
|
|
||||||
if (defined &overload::StrVal) {
|
|
||||||
$str = overload::StrVal($_[0]);
|
|
||||||
} else {
|
|
||||||
$str = "$_[0]";
|
|
||||||
}
|
|
||||||
$ref = $1 if $str =~ /=(\w+)/;
|
|
||||||
$ref;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub freezeString {$string .= "\$" . length($_[0]) . '|' . $_[0]}
|
|
||||||
|
|
||||||
sub freezeNumber {$string .= $_[0] . '|'}
|
|
||||||
|
|
||||||
sub freezeREx {$string .= '/' . length($_[0]) . '|' . $_[0]}
|
|
||||||
|
|
||||||
sub thawString { # Returns list: a string and offset of rest
|
|
||||||
substr($string, $_[0], 2+max_strlen_l) =~ /^\$(\d+)\|/
|
|
||||||
or confess "Wrong format of frozen string: " . substr($string, $_[0]);
|
|
||||||
length($string) - $_[0] > length($1) + 1 + $1
|
|
||||||
or confess "Frozen string too short: `" .
|
|
||||||
substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1);
|
|
||||||
(substr($string, $_[0] + length($1) + 2, $1), $_[0] + length($1) + 2 + $1);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub thawNumber { # Returns list: a number and offset of rest
|
|
||||||
substr($string, $_[0], 1+max_strlen_l) =~ /^(\d+)\|/
|
|
||||||
or confess "Wrong format of frozen string: " . substr($string, $_[0]);
|
|
||||||
($1, $_[0] + length($1) + 1);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub _2rex ($);
|
|
||||||
if (eval 'ref qr/1/') {
|
|
||||||
eval 'sub _2rex ($) {my $r = shift; qr/$r/} 1' or die;
|
|
||||||
} else {
|
|
||||||
eval 'sub _2rex ($) { shift } 1' or die;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub thawREx { # Returns list: a REx and offset of rest
|
|
||||||
substr($string, $_[0], 2+max_strlen_l) =~ m,^/(\d+)\|,
|
|
||||||
or confess "Wrong format of frozen REx: " . substr($string, $_[0]);
|
|
||||||
length($string) - $_[0] > length($1) + 1 + $1
|
|
||||||
or confess "Frozen string too short: `" .
|
|
||||||
substr($string, $_[0]) . "', expect " . (length($1) + 2 + $1);
|
|
||||||
(_2rex substr($string, $_[0] + length($1) + 2, $1),
|
|
||||||
$_[0] + length($1) + 2 + $1);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub freezeArray {
|
|
||||||
$string .= '@' . @{$_[0]} . '|';
|
|
||||||
for (@{$_[0]}) {
|
|
||||||
freezeScalar($_);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub thawArray {
|
|
||||||
substr($string, $_[0], 2+max_strlen_l) =~ /^[\@%](\d+)\|/ # % To make it possible thaw hashes
|
|
||||||
or confess "Wrong format of frozen array: \n$_[0]";
|
|
||||||
my $count = $1;
|
|
||||||
my $off = $_[0] + 2 + length $count;
|
|
||||||
my (@res, $res);
|
|
||||||
while ($count and length $string > $off) {
|
|
||||||
($res,$off) = thawScalar($off);
|
|
||||||
push(@res,$res);
|
|
||||||
--$count;
|
|
||||||
}
|
|
||||||
confess "Wrong length of data in thawing Array: $count left" if $count;
|
|
||||||
(\@res, $off);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub freezeHash {
|
|
||||||
my @arr = sort keys %{$_[0]};
|
|
||||||
$string .= '%' . (2*@arr) . '|';
|
|
||||||
for (@arr, @{$_[0]}{@arr}) {
|
|
||||||
freezeScalar($_);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub thawHash {
|
|
||||||
my ($arr, $rest) = &thawArray;
|
|
||||||
my %hash;
|
|
||||||
my $l = @$arr/2;
|
|
||||||
foreach (0 .. $l - 1) {
|
|
||||||
$hash{$arr->[$_]} = $arr->[$l + $_];
|
|
||||||
}
|
|
||||||
(\%hash,$rest);
|
|
||||||
}
|
|
||||||
|
|
||||||
# Second optional argument: ignore the package
|
|
||||||
# Third optional one: do not check for duplicates on outer level
|
|
||||||
|
|
||||||
sub freezeScalar {
|
|
||||||
$string .= '_', return unless defined $_[0];
|
|
||||||
return &freezeString unless ref $_[0];
|
|
||||||
my $ref = ref $_[0];
|
|
||||||
my $str;
|
|
||||||
if ($_[1] and $ref) { # Similar to getref()
|
|
||||||
if (defined &overload::StrVal) {
|
|
||||||
$str = overload::StrVal($_[0]);
|
|
||||||
} else {
|
|
||||||
$str = "$_[0]";
|
|
||||||
}
|
|
||||||
$ref = $1 if $str =~ /=(\w+)/;
|
|
||||||
} else {
|
|
||||||
$str = "$_[0]";
|
|
||||||
}
|
|
||||||
# Die if a) repeated prohibited, b) met, c) not explicitely requested to ingore.
|
|
||||||
confess "Repeated reference met when prohibited"
|
|
||||||
if $norepeated && !$_[2] && defined $count{$str};
|
|
||||||
if ($secondpass and !$_[2]) {
|
|
||||||
$string .= "<$address{$str}|", return
|
|
||||||
if defined $count{$str} and $count{$str} > 1;
|
|
||||||
} elsif (!$_[2]) {
|
|
||||||
# $count{$str} is defined if we have seen it on this pass.
|
|
||||||
$address{$str} = @multiple, push(@multiple, $_[0])
|
|
||||||
if defined $count{$str} and not exists $address{$str};
|
|
||||||
# This is for debugging and shortening thrown-away output (also
|
|
||||||
# internal data in arrays and hashes is not duplicated).
|
|
||||||
$string .= "<$address{$str}|", ++$count{$str}, return
|
|
||||||
if defined $count{$str};
|
|
||||||
++$count{$str};
|
|
||||||
}
|
|
||||||
return &freezeArray if $ref eq 'ARRAY';
|
|
||||||
return &freezeHash if $ref eq 'HASH';
|
|
||||||
return &freezeREx if haveIsRex ? re::is_regexp($_[0])
|
|
||||||
: ($ref eq 'Regexp' and not defined ${$_[0]});
|
|
||||||
$string .= "*", return &freezeString
|
|
||||||
if $ref eq 'GLOB' and !$safe;
|
|
||||||
$string .= "&", return &freezeString
|
|
||||||
if $ref eq 'CODE' and !$safe;
|
|
||||||
$string .= '\\', return &freezeScalar( $ {shift()} )
|
|
||||||
if $ref eq 'REF' or $ref eq 'SCALAR';
|
|
||||||
if ($noCache and (($ref eq 'CODE') or $ref eq 'GLOB')) {
|
|
||||||
confess "CODE and GLOB references prohibited now";
|
|
||||||
}
|
|
||||||
if ($safe and (($ref eq 'CODE') or $ref eq 'GLOB')) {
|
|
||||||
$unsafe = 1;
|
|
||||||
$saved{$str} = $_[0] unless defined $saved{$str};
|
|
||||||
$string .= "?";
|
|
||||||
return &freezeString;
|
|
||||||
}
|
|
||||||
$string .= '>';
|
|
||||||
local $norepeated = $norepeated;
|
|
||||||
local $noCache = $noCache;
|
|
||||||
freezePackage(ref $_[0]);
|
|
||||||
$_[0]->Freeze($cooky);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub freezePackage {
|
|
||||||
my $packageid = $seen_packages{$_[0]};
|
|
||||||
if (defined $packageid) {
|
|
||||||
$string .= ')';
|
|
||||||
&freezeNumber( $packageid );
|
|
||||||
} else {
|
|
||||||
$string .= '>';
|
|
||||||
&freezeNumber( $seen_packages );
|
|
||||||
&freezeScalar( $_[0] );
|
|
||||||
$seen_packages{ $_[0] } = $seen_packages++;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub thawPackage { # First argument: offset
|
|
||||||
my $key = substr($string,$_[0],1);
|
|
||||||
my ($get, $rest, $id);
|
|
||||||
($id, $rest) = &thawNumber($_[0] + 1);
|
|
||||||
if ($key eq ')') {
|
|
||||||
$get = $seen_packages{$id};
|
|
||||||
} else {
|
|
||||||
($get, $rest) = &thawString($rest);
|
|
||||||
$seen_packages{$id} = $get;
|
|
||||||
}
|
|
||||||
($get, $rest);
|
|
||||||
}
|
|
||||||
|
|
||||||
# First argument: offset; Optional other: index in the @uninit array
|
|
||||||
|
|
||||||
sub thawScalar {
|
|
||||||
my $key = substr($string,$_[0],1);
|
|
||||||
if ($key eq "\$") {&thawString}
|
|
||||||
elsif ($key eq '@') {&thawArray}
|
|
||||||
elsif ($key eq '%') {&thawHash}
|
|
||||||
elsif ($key eq '/') {&thawREx}
|
|
||||||
elsif ($key eq '\\') {
|
|
||||||
my ($out,$rest) = &thawScalar( $_[0]+1 ) ;
|
|
||||||
(\$out,$rest);
|
|
||||||
}
|
|
||||||
elsif ($key eq '_') { (undef, $_[0]+1) }
|
|
||||||
elsif ($key eq '&') {confess "Do not know how to thaw CODE"}
|
|
||||||
elsif ($key eq '*') {confess "Do not know how to thaw GLOB"}
|
|
||||||
elsif ($key eq '?') {
|
|
||||||
my ($address,$rest) = &thawScalar( $_[0]+1 ) ;
|
|
||||||
confess "The saved data accessed in unprotected thaw" unless $unsafe;
|
|
||||||
confess "The saved data disappeared somewhere"
|
|
||||||
unless defined $saved{$address};
|
|
||||||
($saved{$address},$rest);
|
|
||||||
} elsif ($key eq '<') {
|
|
||||||
confess "Repeated data prohibited at this moment" unless $uninitOK;
|
|
||||||
my ($off,$end) = &thawNumber ($_[0]+1);
|
|
||||||
($uninit[$off],$end);
|
|
||||||
} elsif ($key eq '>' or $key eq '{' or $key eq '}') {
|
|
||||||
my ($package,$rest) = &thawPackage( $_[0]+1 );
|
|
||||||
my $cooky = bless \$rest, 'FreezeThaw::TCooky';
|
|
||||||
local $uninitOK = $uninitOK;
|
|
||||||
local $unsafe = $unsafe;
|
|
||||||
if ($key eq '{') {
|
|
||||||
my $res = $package->Allocate($cooky);
|
|
||||||
($res, $rest);
|
|
||||||
} elsif ($key eq '}') {
|
|
||||||
warn "Here it is undef!" unless defined $_[1];
|
|
||||||
$package->Instantiate($uninit[$_[1]],$cooky);
|
|
||||||
(undef, $rest);
|
|
||||||
} else {
|
|
||||||
($package->Thaw($cooky),$rest);
|
|
||||||
}
|
|
||||||
} else {
|
|
||||||
confess "Do not know how to thaw data with code `$key'";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub freezeEmpty { # Takes a type, freezes ref to empty object
|
|
||||||
my $e = $Empty{ref $_[0]};
|
|
||||||
if (ref $e) {
|
|
||||||
my $cache = &$e;
|
|
||||||
freezeScalar $cache;
|
|
||||||
$cache;
|
|
||||||
} elsif ($e) {
|
|
||||||
my $cache = shift;
|
|
||||||
freezeScalar($cache,1,1); # Atomic
|
|
||||||
$cache;
|
|
||||||
} else {
|
|
||||||
$string .= "{";
|
|
||||||
freezePackage ref $_[0];
|
|
||||||
$_[0]->FreezeEmpty($cooky);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub freeze {
|
|
||||||
local @multiple;
|
|
||||||
local %seen_packages;
|
|
||||||
local $seen_packages = 0;
|
|
||||||
local %seen_packages;
|
|
||||||
# local @seentypes;
|
|
||||||
local %count;
|
|
||||||
local %address;
|
|
||||||
local $string = 'FrT;';
|
|
||||||
local $unsafe;
|
|
||||||
local $noCache;
|
|
||||||
local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake
|
|
||||||
local $secondpass;
|
|
||||||
freezeScalar(\@_);
|
|
||||||
if (@multiple) {
|
|
||||||
# Now repeated structures are enumerated with order of *second* time
|
|
||||||
# they appear in the what we freeze.
|
|
||||||
# What we want is to have them enumerated with respect to the first time
|
|
||||||
#### $string = ''; # Start again
|
|
||||||
#### @multiple = ();
|
|
||||||
#### %address = ();
|
|
||||||
#### for (keys %count) {
|
|
||||||
#### $count{$_} = undef if $count{$_} <= 1; # As at start
|
|
||||||
#### $count{$_} = 0 if $count{$_}; # As at start
|
|
||||||
#### }
|
|
||||||
#### $seen_packages = 0;
|
|
||||||
#### %seen_packages = ();
|
|
||||||
#### freezeScalar(\@_);
|
|
||||||
# Now repeated structures are enumerated with order of first time
|
|
||||||
# they appear in the what we freeze
|
|
||||||
#### my $oldstring = substr $string, 4;
|
|
||||||
$string = 'FrT;!'; # Start again
|
|
||||||
$seen_packages = 0;
|
|
||||||
%seen_packages = (); # XXXX We reshuffle parts of the
|
|
||||||
# string, so the order of packages may
|
|
||||||
# be wrong...
|
|
||||||
freezeNumber($#multiple);
|
|
||||||
{
|
|
||||||
my @cache; # Force different values for different
|
|
||||||
# empty objects.
|
|
||||||
foreach (@multiple) {
|
|
||||||
push @cache, freezeEmpty $_;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
# for (keys %count) {
|
|
||||||
# $count{$_} = undef
|
|
||||||
# if !(defined $count{$_}) or $count{$_} <= 1; # As at start
|
|
||||||
# }
|
|
||||||
# $string .= '@' . @multiple . '|';
|
|
||||||
$secondpass = 1;
|
|
||||||
for (@multiple) {
|
|
||||||
freezeScalar($_,0,1,1), next if $Empty{ref $_};
|
|
||||||
$string .= "}";
|
|
||||||
freezePackage ref $_;
|
|
||||||
$_->FreezeInstance($cooky);
|
|
||||||
}
|
|
||||||
#### $string .= $oldstring;
|
|
||||||
freezeScalar(\@_);
|
|
||||||
}
|
|
||||||
return "FrT;?\$" . length($lock) . "|" . $lock . substr $string, 4
|
|
||||||
if $unsafe;
|
|
||||||
$string;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub safeFreeze {
|
|
||||||
local $safe = 1;
|
|
||||||
&freeze;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub copyContents { # Given two references, copies contents of the
|
|
||||||
# second one to the first one, provided they have
|
|
||||||
# the same basic type. The package is copied too.
|
|
||||||
my($first,$second) = @_;
|
|
||||||
my $ref = getref $second;
|
|
||||||
if ($ref eq 'SCALAR' or $ref eq 'REF') {
|
|
||||||
$$first = $$second;
|
|
||||||
} elsif ($ref eq 'ARRAY') {
|
|
||||||
@$first = @$second;
|
|
||||||
} elsif ($ref eq 'HASH') {
|
|
||||||
%$first = %$second;
|
|
||||||
} elsif (haveIsRex ? re::is_regexp($second)
|
|
||||||
: ($ref eq 'Regexp' and not defined $$second)) {
|
|
||||||
$first = qr/$second/;
|
|
||||||
} else {
|
|
||||||
croak "Don't know how to copyContents of type `$ref'";
|
|
||||||
}
|
|
||||||
if (ref $second ne ref $first) { # Rebless
|
|
||||||
# SvAMAGIC() is a property of a reference, not of a referent!
|
|
||||||
# Thus we cannot use $first here if $second was overloaded...
|
|
||||||
bless $_[0], ref $second;
|
|
||||||
}
|
|
||||||
$first;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub thaw {
|
|
||||||
confess "thaw requires one argument" unless @_ ==1;
|
|
||||||
local $string = shift;
|
|
||||||
local %seen_packages;
|
|
||||||
my $initoff = 0;
|
|
||||||
#print STDERR "Thawing `$string'", substr ($string, 0, 4), "\n";
|
|
||||||
if (substr($string, 0, 4) ne 'FrT;') {
|
|
||||||
warn "Signature not present, continuing anyway" if $^W;
|
|
||||||
} else {
|
|
||||||
$initoff = 4;
|
|
||||||
}
|
|
||||||
local $unsafe = $initoff + (substr($string, $initoff, 1) eq "?" ? 1 : 0);
|
|
||||||
if ($unsafe != $initoff) {
|
|
||||||
my $key;
|
|
||||||
($key,$unsafe) = thawScalar($unsafe);
|
|
||||||
confess "The lock in frozen data does not match the key"
|
|
||||||
unless $key eq $lock;
|
|
||||||
}
|
|
||||||
local @multiple;
|
|
||||||
local $uninitOK = 1; # The methods can change it.
|
|
||||||
my $repeated = substr($string,$unsafe,1) eq '!' ? 1 : 0;
|
|
||||||
my ($res, $off);
|
|
||||||
if ($repeated) {
|
|
||||||
($res, $off) = thawNumber($repeated + $unsafe);
|
|
||||||
} else {
|
|
||||||
($res, $off) = thawScalar($repeated + $unsafe);
|
|
||||||
}
|
|
||||||
my $cooky = bless \$off, 'FreezeThaw::TCooky';
|
|
||||||
if ($repeated) {
|
|
||||||
local @uninit;
|
|
||||||
my $lst = $res;
|
|
||||||
foreach (0..$lst) {
|
|
||||||
($res, $off) = thawScalar($off, $_);
|
|
||||||
push(@uninit, $res);
|
|
||||||
}
|
|
||||||
my @init;
|
|
||||||
foreach (0..$lst) {
|
|
||||||
($res, $off) = thawScalar($off, $_);
|
|
||||||
push(@init, $res);
|
|
||||||
}
|
|
||||||
#($init, $off) = thawScalar($off);
|
|
||||||
#print "Instantiating...\n";
|
|
||||||
#my $ref;
|
|
||||||
for (0..$#uninit) {
|
|
||||||
copyContents $uninit[$_], $init[$_] if ref $init[$_];
|
|
||||||
}
|
|
||||||
($res, $off) = thawScalar($off);
|
|
||||||
}
|
|
||||||
croak "Extra elements in frozen structure: `" . substr($string,$off) . "'"
|
|
||||||
if $off != length $string;
|
|
||||||
return @$res;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmpStr {
|
|
||||||
confess "Compare requires two arguments" unless @_ == 2;
|
|
||||||
freeze(shift) cmp freeze(shift);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub cmpStrHard {
|
|
||||||
confess "Compare requires two arguments" unless @_ == 2;
|
|
||||||
local @multiple;
|
|
||||||
# local @seentypes;
|
|
||||||
local %count;
|
|
||||||
local %address;
|
|
||||||
local $string = 'FrT;';
|
|
||||||
local $unsafe;
|
|
||||||
local $noCache;
|
|
||||||
local $cooky = bless \$cooky, 'FreezeThaw::FCooky'; # Just something fake
|
|
||||||
freezeScalar($_[0]);
|
|
||||||
my %cnt1 = %count;
|
|
||||||
freezeScalar($_[1]);
|
|
||||||
my %cnt2 = %count;
|
|
||||||
%count = ();
|
|
||||||
# Now all the caches are filled, delete the entries for guys which
|
|
||||||
# are in one argument only.
|
|
||||||
my ($elt, $val);
|
|
||||||
while (($elt, $val) = each %cnt1) {
|
|
||||||
$count{$elt}++ if $cnt2{$elt} > $cnt1{$elt};
|
|
||||||
}
|
|
||||||
$string = '';
|
|
||||||
freezeScalar($_[0]);
|
|
||||||
my $str1 = $string;
|
|
||||||
$string = '';
|
|
||||||
freezeScalar($_[1]);
|
|
||||||
$str1 cmp $string;
|
|
||||||
}
|
|
||||||
|
|
||||||
# local $string = freeze(shift,shift);
|
|
||||||
# local $uninitOK = 1;
|
|
||||||
# #print "$string\n";
|
|
||||||
# my $off = 7; # Hardwired offset after @2|
|
|
||||||
# if (substr($string,4,1) eq '!') {
|
|
||||||
# $off = 5; # Hardwired offset after !
|
|
||||||
# my ($uninit, $len);
|
|
||||||
# ($len,$off) = thawScalar $off;
|
|
||||||
# local @uninit;
|
|
||||||
# foreach (0..$len) {
|
|
||||||
# ($uninit,$off) = thawScalar $off, $_;
|
|
||||||
# }
|
|
||||||
# $off += 3; # Hardwired offset after @2|
|
|
||||||
# }
|
|
||||||
# croak "Unknown format of frozen array: " . substr($string,$off-3)
|
|
||||||
# unless substr($string,$off-3,1) eq '@';
|
|
||||||
# my ($first,$off2) = thawScalar $off;
|
|
||||||
# my $off3;
|
|
||||||
# ($first,$off3) = thawScalar $off2;
|
|
||||||
# substr($string, $off, $off2-$off) cmp substr($string,$off2,$off3-$off2);
|
|
||||||
# }
|
|
||||||
|
|
||||||
sub FreezeThaw::FCooky::FreezeScalar {
|
|
||||||
shift;
|
|
||||||
&freezeScalar;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::FCooky::isSafe {
|
|
||||||
$safe || $noCache;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::FCooky::makeSafe {
|
|
||||||
$noCache = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::FCooky::repeatedOK {
|
|
||||||
!$norepeated;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::FCooky::noRepeated {
|
|
||||||
$norepeated = 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::TCooky::repeatedOK {
|
|
||||||
$uninitOK;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::TCooky::noRepeated {
|
|
||||||
undef $uninitOK;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::TCooky::isSafe {
|
|
||||||
!$unsafe;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::TCooky::makeSafe {
|
|
||||||
undef $unsafe;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub FreezeThaw::TCooky::ThawScalar {
|
|
||||||
my $self = shift;
|
|
||||||
my ($res,$off) = &thawScalar($$self);
|
|
||||||
$$self = $off;
|
|
||||||
$res;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::Freeze {
|
|
||||||
my ($obj, $cooky) = (shift, shift);
|
|
||||||
$cooky->FreezeScalar($obj,1,1);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::Thaw {
|
|
||||||
my ($package, $cooky) = (shift, shift);
|
|
||||||
my $obj = $cooky->ThawScalar;
|
|
||||||
bless $obj, $package;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::FreezeInstance {
|
|
||||||
my($obj,$cooky) = @_;
|
|
||||||
return if !RexIsREGEXP # Special-case non-1st-class RExes
|
|
||||||
and ref $obj and (haveIsRex ? re::is_regexp($obj)
|
|
||||||
: (ref $obj eq 'Regexp' and not defined $$obj)); # Regexp
|
|
||||||
$obj->Freeze($cooky);
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::Instantiate {
|
|
||||||
my($package,$pre,$cooky) = @_;
|
|
||||||
return if !RexIsREGEXP and $package eq 'Regexp';
|
|
||||||
my $obj = $package->Thaw($cooky);
|
|
||||||
# SvAMAGIC() is a property of a reference, not of a referent!
|
|
||||||
# Thus we cannot use $pre here if $obj was overloaded...
|
|
||||||
copyContents $_[1], $obj;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::Allocate {
|
|
||||||
my($package,$cooky) = @_;
|
|
||||||
$cooky->ThawScalar;
|
|
||||||
}
|
|
||||||
|
|
||||||
sub UNIVERSAL::FreezeEmpty {
|
|
||||||
my $obj = shift;
|
|
||||||
my $type = getref $obj;
|
|
||||||
my $e = $Empty{$type};
|
|
||||||
if (ref $e) {
|
|
||||||
my $ref = &$e;
|
|
||||||
freezeScalar $ref;
|
|
||||||
$ref; # Put into cache.
|
|
||||||
} elsif ($e) {
|
|
||||||
freezeScalar($obj,1,1); # Atomic
|
|
||||||
undef;
|
|
||||||
} elsif (!RexIsREGEXP and defined $e and not defined $$obj) { # REx pre-5.11
|
|
||||||
freezeREx($obj);
|
|
||||||
undef;
|
|
||||||
} else {
|
|
||||||
die "Do not know how to FreezeEmpty $type";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
1;
|
|
||||||
8
MANIFEST
8
MANIFEST
|
|
@ -1,8 +0,0 @@
|
||||||
FreezeThaw.pm
|
|
||||||
t/FreezeThaw.t
|
|
||||||
t/overload.t
|
|
||||||
MANIFEST
|
|
||||||
Makefile.PL
|
|
||||||
Changes
|
|
||||||
README
|
|
||||||
META.yml Module meta-data (added by MakeMaker)
|
|
||||||
21
META.yml
21
META.yml
|
|
@ -1,21 +0,0 @@
|
||||||
--- #YAML:1.0
|
|
||||||
name: FreezeThaw
|
|
||||||
version: 0.5001
|
|
||||||
abstract: ~
|
|
||||||
author:
|
|
||||||
- Ilya Zakharevich <ilyaz@cpan.org>
|
|
||||||
license: unknown
|
|
||||||
distribution_type: module
|
|
||||||
configure_requires:
|
|
||||||
ExtUtils::MakeMaker: 0
|
|
||||||
build_requires:
|
|
||||||
ExtUtils::MakeMaker: 0
|
|
||||||
requires: {}
|
|
||||||
no_index:
|
|
||||||
directory:
|
|
||||||
- t
|
|
||||||
- inc
|
|
||||||
generated_by: ExtUtils::MakeMaker version 6.54
|
|
||||||
meta-spec:
|
|
||||||
url: http://module-build.sourceforge.net/META-spec-v1.4.html
|
|
||||||
version: 1.4
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
use ExtUtils::MakeMaker;
|
|
||||||
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
|
|
||||||
# the contents of the Makefile that is written.
|
|
||||||
WriteMakefile(
|
|
||||||
NAME => 'FreezeThaw',
|
|
||||||
VERSION_FROM => "FreezeThaw.pm",
|
|
||||||
AUTHOR => 'Ilya Zakharevich <ilyaz@cpan.org>',
|
|
||||||
);
|
|
||||||
21
README
21
README
|
|
@ -1,21 +0,0 @@
|
||||||
Copyright (c) 1995 Ilya Zakharevich. All rights reserved.
|
|
||||||
This program is free software; you can redistribute it and/or
|
|
||||||
modify it under the same terms as Perl itself.
|
|
||||||
|
|
||||||
You should have received a copy of the Perl license along with
|
|
||||||
Perl; see the file README in Perl distribution.
|
|
||||||
|
|
||||||
You should have received a copy of the GNU General Public License
|
|
||||||
along with Perl; see the file Copying. If not, write to
|
|
||||||
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
||||||
|
|
||||||
You should have received a copy of the Artistic License
|
|
||||||
along with Perl; see the file Artistic.
|
|
||||||
|
|
||||||
|
|
||||||
Author of this software makes no claim whatsoever about suitability,
|
|
||||||
reliability, edability, editability or usability of this product. If
|
|
||||||
you can use it, you are in luck, if not, I should not be kept
|
|
||||||
responsible. Keep a handy copy of your backup tape at hand.
|
|
||||||
|
|
||||||
With this module from this moment on you are on your own ;-). Good luck.
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
libfreezethaw-perl for Debian
|
|
||||||
|
|
||||||
Please edit this to provide information specific to
|
|
||||||
this libfreezethaw-perl Debian package.
|
|
||||||
|
|
||||||
(Automatically generated by debmake Version 4.3.1)
|
|
||||||
|
|
||||||
-- denghao <denghao@kylinos.cn> Tue, 13 Sep 2022 06:08:11 +0300
|
|
||||||
|
|
@ -1,5 +0,0 @@
|
||||||
libfreezethaw-perl (0.5001-ok1) yangtze; urgency=medium
|
|
||||||
|
|
||||||
* Build for openkylin.
|
|
||||||
|
|
||||||
-- denghao <denghao@kylinos.cn> Tue, 13 Sep 2022 06:08:11 +0300
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
11
|
|
||||||
|
|
@ -1,21 +0,0 @@
|
||||||
Source: libfreezethaw-perl
|
|
||||||
Section: perl
|
|
||||||
Priority: optional
|
|
||||||
Maintainer: OpenKylin Developers <packaging@lists.openkylin.top>
|
|
||||||
Build-Depends: debhelper (>=11~)
|
|
||||||
Build-Depends-Indep: perl
|
|
||||||
Testsuite: autopkgtest-pkg-perl
|
|
||||||
Standards-Version: 4.1.4
|
|
||||||
Vcs-Browser: https://gitee.com/openkylin/libfreezethaw-perl
|
|
||||||
Vcs-Git: https://gitee.com/openkylin/libfreezethaw-perl.git
|
|
||||||
Homepage: https://metacpan.org/release/FreezeThaw
|
|
||||||
|
|
||||||
Package: libfreezethaw-perl
|
|
||||||
Architecture: all
|
|
||||||
Depends: ${misc:Depends},
|
|
||||||
${perl:Depends}
|
|
||||||
Description: module to serialize and deserialize Perl data structures
|
|
||||||
FreezeThaw is a Perl module designed to convert data to and from a serialized
|
|
||||||
string format, appropriate for saving to and reading from permanent storage.
|
|
||||||
It is capable of dealing with objects, circular lists and repeated appearance
|
|
||||||
of the same reference.
|
|
||||||
|
|
@ -1,42 +0,0 @@
|
||||||
Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/
|
|
||||||
Upstream-Name: libfreezethaw-perl
|
|
||||||
Source: <url://example.com>
|
|
||||||
#
|
|
||||||
# Please double check copyright with the licensecheck(1) command.
|
|
||||||
|
|
||||||
Files: Changes
|
|
||||||
FreezeThaw.pm
|
|
||||||
MANIFEST
|
|
||||||
META.yml
|
|
||||||
Makefile.PL
|
|
||||||
t/FreezeThaw.t
|
|
||||||
t/overload.t
|
|
||||||
Copyright: __NO_COPYRIGHT_NOR_LICENSE__
|
|
||||||
License: __NO_COPYRIGHT_NOR_LICENSE__
|
|
||||||
|
|
||||||
Files: README
|
|
||||||
Copyright: 1995 Ilya Zakharevich.
|
|
||||||
License: Perl
|
|
||||||
This program is free software; you can redistribute it and/or
|
|
||||||
modify it under the same terms as Perl itself.
|
|
||||||
.
|
|
||||||
You should have received a copy of the Perl license along with
|
|
||||||
Perl; see the file README in Perl distribution.
|
|
||||||
.
|
|
||||||
You should have received a copy of the GNU General Public License
|
|
||||||
along with Perl; see the file Copying. If not, write to
|
|
||||||
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
||||||
.
|
|
||||||
You should have received a copy of the Artistic License
|
|
||||||
along with Perl; see the file Artistic.
|
|
||||||
.
|
|
||||||
you can use it, you are in luck, if not, I should not be kept
|
|
||||||
responsible. Keep a handy copy of your backup tape at hand.
|
|
||||||
.
|
|
||||||
With this module from this moment on you are on your own ;-). Good luck.
|
|
||||||
.
|
|
||||||
The FSF address in the above text is the old one.
|
|
||||||
|
|
||||||
#----------------------------------------------------------------------------
|
|
||||||
# Files marked as NO_LICENSE_TEXT_FOUND may be covered by the following
|
|
||||||
# license/copyright files.
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
# You must remove unused comment lines for the released package.
|
|
||||||
|
|
@ -1,4 +0,0 @@
|
||||||
#!/usr/bin/make -f
|
|
||||||
|
|
||||||
%:
|
|
||||||
dh $@
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
3.0 (native)
|
|
||||||
|
|
@ -1,3 +0,0 @@
|
||||||
version=3
|
|
||||||
opts=uversionmangle=s/\.\d\d$/$&00/ \
|
|
||||||
https://metacpan.org/release/FreezeThaw .*/FreezeThaw-v?(\d[\d.]+)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)
|
|
||||||
Binary file not shown.
|
|
@ -0,0 +1 @@
|
||||||
|
24c6731d51d4797e6ba18017a0f7dfe0d0af4a5a
|
||||||
244
t/FreezeThaw.t
244
t/FreezeThaw.t
|
|
@ -1,244 +0,0 @@
|
||||||
print "1.." . &last() . "\n";
|
|
||||||
use Carp;
|
|
||||||
$SIG{__WARN__} = sub { warn Carp::longmess(@_) };
|
|
||||||
use FreezeThaw qw(freeze thaw cmpStr safeFreeze cmpStrHard);
|
|
||||||
require 'dumpvar.pl' ;
|
|
||||||
|
|
||||||
#@deb = map {FreezeThaw::makeEmpty (ref $_)} ([1,2],{3,4});
|
|
||||||
#dumpValue ( \@deb );
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
|
|
||||||
$a1 = 'aa$a\nadf';
|
|
||||||
FreezeThaw::freezeString $a1;
|
|
||||||
($aaa,$rest) = FreezeThaw::thawString 0;
|
|
||||||
print($aaa eq $a1 and $rest == length($FreezeThaw::string) ?
|
|
||||||
"ok 1\n": "not ok 1\n");
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
|
|
||||||
$a2 = 'lk$s\nbgj';
|
|
||||||
FreezeThaw::freezeScalar $a2;
|
|
||||||
($aaa,$rest) = FreezeThaw::thawString 0;
|
|
||||||
print($aaa eq $a2 and $rest == length($FreezeThaw::string) ?
|
|
||||||
"ok 2\n": "not ok 2\n");
|
|
||||||
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
|
|
||||||
$a3 = [ 0, "aa", 2, "b" ];
|
|
||||||
FreezeThaw::freezeArray $a3;
|
|
||||||
($b,$rest) = FreezeThaw::thawArray 0;
|
|
||||||
$bb = $FreezeThaw::string;
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
undef @FreezeThaw::seen;
|
|
||||||
undef %FreezeThaw::count;
|
|
||||||
FreezeThaw::freezeArray $b;
|
|
||||||
#print "$FreezeThaw::string\n";
|
|
||||||
print $bb eq $FreezeThaw::string ? "ok 3\n": "not ok 3\n";
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
undef @FreezeThaw::seen;
|
|
||||||
undef %FreezeThaw::count;
|
|
||||||
|
|
||||||
$a4 = [ 0, ["a", 1], 2, "ccc", [4, ["four", 4]] ];
|
|
||||||
FreezeThaw::freezeArray $a4;
|
|
||||||
($b,$rest) = FreezeThaw::thawArray 0;
|
|
||||||
$bb = $FreezeThaw::string;
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
undef @FreezeThaw::seen;
|
|
||||||
undef %FreezeThaw::count;
|
|
||||||
FreezeThaw::freezeArray $b;
|
|
||||||
#print "$bb\n";
|
|
||||||
#print "$FreezeThaw::string\n";
|
|
||||||
print $bb eq $FreezeThaw::string ? "ok 4\n": "not ok 4\n";
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
|
|
||||||
$a5 = [ {"000" => undef}, ["a", 1], 2, "ccc", [4, ["four", 4]],
|
|
||||||
{"five" => 5, "5" => [5,55]}];
|
|
||||||
FreezeThaw::freezeArray $a5;
|
|
||||||
($b) = FreezeThaw::thawArray 0;
|
|
||||||
$bb = $FreezeThaw::string;
|
|
||||||
|
|
||||||
$FreezeThaw::string = '';
|
|
||||||
undef @FreezeThaw::seen;
|
|
||||||
undef %FreezeThaw::count;
|
|
||||||
FreezeThaw::freezeArray $b;
|
|
||||||
#print "$bb\n";
|
|
||||||
print $bb eq $FreezeThaw::string ? "ok 5\n": "not ok 5\n";
|
|
||||||
|
|
||||||
$out = freeze $a1, $a2, $a3, $a4, $a5;
|
|
||||||
#print "$out\n";
|
|
||||||
@out = thaw $out;
|
|
||||||
$out1 = freeze @out;
|
|
||||||
|
|
||||||
#print $out;
|
|
||||||
print $out1 eq $out ? "ok 6\n": "not ok 6\n";
|
|
||||||
|
|
||||||
print 0 == cmpStr([$a1, $a2, $a3, $a4, $a5], \@out) ?
|
|
||||||
"ok 7\n": "not ok 7\n";
|
|
||||||
print 0 == cmpStrHard([$a1, $a2, $a3, $a4, $a5], \@out) ?
|
|
||||||
"ok 8\n": "not ok 8\n";
|
|
||||||
print 0 != cmpStr([$a1, $a2, $a3, $a6, $a5], \@out) ?
|
|
||||||
"ok 9\n": "not ok 9\n";
|
|
||||||
print 0 != cmpStrHard([$a1, $a2, $a3, $a6, $a5], \@out) ?
|
|
||||||
"ok 10\n": "not ok 10\n";
|
|
||||||
print 0 == cmpStr(\@out, \@out) ? "ok 11\n": "not ok 11\n";
|
|
||||||
#print 0 == cmpStrHard(\@out, \@out) ? "ok 11.5\n": "not ok 11.5\n";
|
|
||||||
|
|
||||||
$a8 = \\$a1;
|
|
||||||
$aa = freeze $a8;
|
|
||||||
#print "$aa\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print "$bb\n";
|
|
||||||
print $bb eq $aa ? "ok 12\n": "not ok 12\n";
|
|
||||||
|
|
||||||
{
|
|
||||||
package Simple;
|
|
||||||
sub new {
|
|
||||||
bless {what => ['nott','so','simple']};
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
$a9 = new Simple;
|
|
||||||
$aa = freeze $a9;
|
|
||||||
#print "`$aa'\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print "$bb\n";
|
|
||||||
print $bb eq $aa ? "ok 13\n": "not ok 13\n";
|
|
||||||
|
|
||||||
$a85 = \$a85;
|
|
||||||
$aa = freeze $a85;
|
|
||||||
#print "#$aa\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
#dumpValue ($b);
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print "#$bb\n";
|
|
||||||
print $bb eq $aa ? "ok 14\n": "not ok 14\n# aa=`$aa'\n# bb=`$bb'\n# b=`$b'\n";
|
|
||||||
|
|
||||||
$a86 = \$a86;
|
|
||||||
$a87 = \$a86;
|
|
||||||
$a88 = \$a87;
|
|
||||||
print 0 == cmpStr($a85, $a86) ? "ok 15\n": "not ok 15\n";
|
|
||||||
#print ((freeze $a85), "\n");
|
|
||||||
#print ((freeze $a87), "\n");
|
|
||||||
print 0 == cmpStr($a85, $a87) ? "ok 16\n": "not ok 16\n";
|
|
||||||
print 0 != cmpStr($a85, $a88) ? "ok 17\n": "not ok 17\n";
|
|
||||||
|
|
||||||
print 0 != cmpStrHard($a85, $a86)
|
|
||||||
? "ok 18\n": "not ok 18\n";
|
|
||||||
|
|
||||||
#print freeze(\@out,\@out), "\n";
|
|
||||||
|
|
||||||
print 0 == cmpStrHard(\@out, \@out)
|
|
||||||
? "ok 19\n": "not ok 19\n";
|
|
||||||
|
|
||||||
$a9 = \&subr;
|
|
||||||
$aa = safeFreeze $a9;
|
|
||||||
#print "$aa\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = safeFreeze $b;
|
|
||||||
#print "$bb\n";
|
|
||||||
print $bb eq $aa ? "ok 20\n": "not ok 20\n";
|
|
||||||
|
|
||||||
$a9 = new Simple;
|
|
||||||
$aa = freeze [$a9,89];
|
|
||||||
#print "#`$aa'\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print "$bb\n";
|
|
||||||
print $bb eq $aa ? "ok 21\n": "not ok 21\n";
|
|
||||||
|
|
||||||
$aa = freeze [$a9,$a9];
|
|
||||||
#print "#`$aa'\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print "#`$bb'\n";
|
|
||||||
print $bb eq $aa ? "ok 22\n": "not ok 22\n";
|
|
||||||
|
|
||||||
$a10 = new Simple;
|
|
||||||
$aa = freeze [$a9,$a10];
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
print $bb eq $aa ? "ok 23\n": "not ok 23\n# aa=`$aa'\n# bb=`$bb'\n";
|
|
||||||
|
|
||||||
$a11 = [$a9,$a10,$a9,$a10];
|
|
||||||
$aa = freeze $a11;
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
# print STDERR "`$bb'\n";
|
|
||||||
print $bb eq $aa ? "ok 24\n": "not ok 24\n# aa=`$aa'\n# bb=`$bb'\n";
|
|
||||||
|
|
||||||
$a15 = {};
|
|
||||||
$a16 = {};
|
|
||||||
$a12 = [$a15,$a16,$a15,$a16];
|
|
||||||
$a15->{add} = $a12;
|
|
||||||
$a16->{add} = \$a12;
|
|
||||||
|
|
||||||
$aa = freeze $a12;
|
|
||||||
#print STDERR "#`$aa'\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print STDERR "#`$bb'\n";
|
|
||||||
print $bb eq $aa ? "ok 25\n": "not ok 25\n# aa=`$aa'\n# bb=`$bb'\n";
|
|
||||||
|
|
||||||
$a15 = bless {}, 'Simple';
|
|
||||||
$a16 = bless {}, 'Simple';
|
|
||||||
$a12 = [$a15,$a16,$a15,$a16];
|
|
||||||
$a15->{add} = $a12;
|
|
||||||
$a16->{add} = \$a12;
|
|
||||||
|
|
||||||
$aa = freeze $a12;
|
|
||||||
#print STDERR "#`$aa'\n";
|
|
||||||
($b) = thaw $aa;
|
|
||||||
$bb = freeze $b;
|
|
||||||
#print STDERR "#`$bb'\n";
|
|
||||||
print $bb eq $aa ? "ok 26\n": "not ok 26\n# aa=`$aa'\n# bb=`$bb'\n";
|
|
||||||
|
|
||||||
require Math::BigInt;
|
|
||||||
$v = new Math::BigInt 5;
|
|
||||||
$vf = freeze $v;
|
|
||||||
($vv) = thaw $vf;
|
|
||||||
$vi = $vv;
|
|
||||||
$vi **= 100;
|
|
||||||
print "# vi=`$vi' vv=`$vv' vf=`$vf' v=`$v'\nnot "
|
|
||||||
unless "$vi" =~ /^\+? 7888609052210118054117285652827862296732064351
|
|
||||||
090230047702789306640625 \Z /x;
|
|
||||||
print "ok 27\n";
|
|
||||||
|
|
||||||
if (eval 'ref qr/1/') { # Have qr//
|
|
||||||
eval <<'EOE';
|
|
||||||
my $rex = qr/^abc/mi;
|
|
||||||
my $f = freeze [$rex, $rex, 11];
|
|
||||||
print "# '$f'\n";
|
|
||||||
my @o = thaw $f;
|
|
||||||
my @out = @{$o[0]};
|
|
||||||
print "# ", ref $out[0], "\nnot " unless ref $out[0] eq 'Regexp';
|
|
||||||
print "ok 28\n";
|
|
||||||
print "not " unless "xyz\nABC" =~ $out[0];
|
|
||||||
print "ok 29\n";
|
|
||||||
print "# ", ref $out[0], "\nnot " unless ref $out[1] eq 'Regexp';
|
|
||||||
print "ok 30\n";
|
|
||||||
print "not " unless "xyz\nABC" =~ $out[1];
|
|
||||||
print "ok 31\n";
|
|
||||||
print "not " unless @out == 3;
|
|
||||||
print "ok 32\n";
|
|
||||||
print "not " unless $out[2] == 11;
|
|
||||||
print "ok 33\n";
|
|
||||||
print "not " unless @o == 1;
|
|
||||||
print "ok 34\n";
|
|
||||||
print "not " unless ($out[1]+0) == ($out[1]+0); # Addresses
|
|
||||||
print "ok 35\n";
|
|
||||||
EOE
|
|
||||||
warn if $@;
|
|
||||||
} else {
|
|
||||||
for (28..35) {
|
|
||||||
print "ok $_ # skipped: no qr// support\n";
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
sub last {35}
|
|
||||||
63
t/overload.t
63
t/overload.t
|
|
@ -1,63 +0,0 @@
|
||||||
print "1.." . &last() . "\n";
|
|
||||||
use Carp;
|
|
||||||
$SIG{__WARN__} = sub { warn Carp::longmess(@_) };
|
|
||||||
use FreezeThaw qw(freeze thaw);
|
|
||||||
|
|
||||||
{
|
|
||||||
package Overloaded;
|
|
||||||
use overload '""' => sub { shift()->[0] };
|
|
||||||
sub new { my $p = shift; bless [shift], $p }
|
|
||||||
}
|
|
||||||
|
|
||||||
my $a = new Overloaded 'xyz';
|
|
||||||
my $f = freeze $a;
|
|
||||||
print "# '$f'\n";
|
|
||||||
my ($o) = thaw $f;
|
|
||||||
|
|
||||||
print "not " unless "$o" eq 'xyz';
|
|
||||||
print "ok 1\n";
|
|
||||||
|
|
||||||
print "not " unless ref $o eq 'Overloaded';
|
|
||||||
print "ok 2\n";
|
|
||||||
|
|
||||||
$f = freeze [$a, $a];
|
|
||||||
print "# '$f'\n";
|
|
||||||
($o) = thaw $f;
|
|
||||||
|
|
||||||
print "# '$o->[0]'\nnot " unless "$o->[0]" eq 'xyz';
|
|
||||||
print "ok 3\n";
|
|
||||||
|
|
||||||
print "not " unless $o->[0][0] eq 'xyz';
|
|
||||||
print "ok 4\n";
|
|
||||||
|
|
||||||
print "not " unless ref $o->[0] eq 'Overloaded';
|
|
||||||
print "ok 5\n";
|
|
||||||
|
|
||||||
print "not " unless "$o->[1]" eq 'xyz';
|
|
||||||
print "ok 6\n";
|
|
||||||
|
|
||||||
print "not " unless $o->[1][0] eq 'xyz';
|
|
||||||
print "ok 7\n";
|
|
||||||
|
|
||||||
print "not " unless ref $o->[1] eq 'Overloaded';
|
|
||||||
print "ok 8\n";
|
|
||||||
|
|
||||||
print "not " unless @$o == 2;
|
|
||||||
print "ok 9\n";
|
|
||||||
|
|
||||||
bless $o->[0], 'Something';
|
|
||||||
|
|
||||||
print "not " unless ref $o->[0] eq 'Something';
|
|
||||||
print "ok 10\n";
|
|
||||||
|
|
||||||
# SvAMAGIC() is a property of a reference, not of a referent!
|
|
||||||
# Thus $o->[1] would preserve overloadness unless this:
|
|
||||||
bless $o->[1], ref $o->[1];
|
|
||||||
|
|
||||||
print "not " unless ref $o->[1] eq 'Something';
|
|
||||||
print "ok 11\n";
|
|
||||||
|
|
||||||
print "not " unless $o->[0] == $o->[1]; # Addresses
|
|
||||||
print "ok 12\n";
|
|
||||||
|
|
||||||
sub last {12}
|
|
||||||
Loading…
Reference in New Issue