r3283 - in /packages/libfreezethaw-perl: ./ branches/
branches/upstream/
branches/upstream/current/ branches/upstream/current/t/ tags/
gregoa-guest at users.alioth.debian.org
gregoa-guest at users.alioth.debian.org
Fri Jul 14 21:15:07 UTC 2006
Author: gregoa-guest
Date: Fri Jul 14 21:15:06 2006
New Revision: 3283
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=3283
Log:
[svn-inject] Installing original source of libfreezethaw-perl
Added:
packages/libfreezethaw-perl/
packages/libfreezethaw-perl/branches/
packages/libfreezethaw-perl/branches/upstream/
packages/libfreezethaw-perl/branches/upstream/current/
packages/libfreezethaw-perl/branches/upstream/current/Changes
packages/libfreezethaw-perl/branches/upstream/current/FreezeThaw.pm
packages/libfreezethaw-perl/branches/upstream/current/MANIFEST
packages/libfreezethaw-perl/branches/upstream/current/Makefile.PL
packages/libfreezethaw-perl/branches/upstream/current/README
packages/libfreezethaw-perl/branches/upstream/current/t/
packages/libfreezethaw-perl/branches/upstream/current/t/FreezeThaw.t
packages/libfreezethaw-perl/branches/upstream/current/t/overload.t
packages/libfreezethaw-perl/tags/
Added: packages/libfreezethaw-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/Changes?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/Changes (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/Changes Fri Jul 14 21:15:06 2006
@@ -1,0 +1,25 @@
+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.
Added: packages/libfreezethaw-perl/branches/upstream/current/FreezeThaw.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/FreezeThaw.pm?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/FreezeThaw.pm (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/FreezeThaw.pm Fri Jul 14 21:15:06 2006
@@ -1,0 +1,857 @@
+=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;
+
+ at ISA = qw(Exporter);
+$VERSION = '0.43';
+ at 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()
+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,
+ Regexp => 0,
+ );
+
+
+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]) =~ /^\$(\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]) =~ /^(\d+)\|/
+ or confess "Wrong format of frozen string: " . substr($string, $_[0]);
+ ($1, $_[0] + length($1) + 1);
+}
+
+sub _2rex ($);
+if (eval '"Regexp" eq 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]) =~ 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]) =~ /^[\@%](\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 $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;
+ } 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 (ref $obj and ref $obj eq 'Regexp' and not defined $$obj); # Regexp
+ $obj->Freeze($cooky);
+}
+
+sub UNIVERSAL::Instantiate {
+ my($package,$pre,$cooky) = @_;
+ return if $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 (defined $e and not defined $$obj) { # Regexp
+ freezeREx($obj);
+ undef;
+ } else {
+ die "Do not know how to FreezeEmpty $type";
+ }
+}
+
+1;
Added: packages/libfreezethaw-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/MANIFEST?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/MANIFEST (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/MANIFEST Fri Jul 14 21:15:06 2006
@@ -1,0 +1,7 @@
+FreezeThaw.pm
+t/FreezeThaw.t
+t/overload.t
+MANIFEST
+Makefile.PL
+Changes
+README
Added: packages/libfreezethaw-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/Makefile.PL?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/Makefile.PL (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/Makefile.PL Fri Jul 14 21:15:06 2006
@@ -1,0 +1,7 @@
+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",
+ );
Added: packages/libfreezethaw-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/README?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/README (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/README Fri Jul 14 21:15:06 2006
@@ -1,0 +1,21 @@
+ 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.
Added: packages/libfreezethaw-perl/branches/upstream/current/t/FreezeThaw.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/t/FreezeThaw.t?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/t/FreezeThaw.t (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/t/FreezeThaw.t Fri Jul 14 21:15:06 2006
@@ -1,0 +1,244 @@
+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";
+ at 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 '"Regexp" eq 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}
Added: packages/libfreezethaw-perl/branches/upstream/current/t/overload.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libfreezethaw-perl/branches/upstream/current/t/overload.t?rev=3283&op=file
==============================================================================
--- packages/libfreezethaw-perl/branches/upstream/current/t/overload.t (added)
+++ packages/libfreezethaw-perl/branches/upstream/current/t/overload.t Fri Jul 14 21:15:06 2006
@@ -1,0 +1,63 @@
+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}
More information about the Pkg-perl-cvs-commits
mailing list