ext/Storable/Storable.xs Storable extension
ext/Storable/t/blessed.t See if Storable works
ext/Storable/t/canonical.t See if Storable works
+ext/Storable/t/circular_hook.t Test thaw hook called depth-first for circular refs
ext/Storable/t/code.t See if Storable works
ext/Storable/t/compat06.t See if Storable works
ext/Storable/t/croak.t See if Storable works
ext/Storable/t/downgrade.t See if Storable works
ext/Storable/t/forgive.t See if Storable works
ext/Storable/t/freeze.t See if Storable works
+ext/Storable/t/HAS_ATTACH.pm For auto-requiring of modules for STORABLE_attach
ext/Storable/t/HAS_HOOK.pm For auto-requiring of modules for STORABLE_thaw
ext/Storable/t/HAS_OVERLOAD.pm For auto-requiring of mdoules for overload
+ext/Storable/t/attach_errors.t Trigger and test STORABLE_attach errors
+ext/Storable/t/attach_singleton.t Test STORABLE_attach for the Singleton pattern
ext/Storable/t/integer.t See if Storable works
ext/Storable/t/interwork56.t Test compatibility kludge for 64bit data under 5.6.x
ext/Storable/t/just_plain_nasty.t See if Storable works
-Sat Jul 10 22:37:47 BST 2004 Nicholas Clark <nick@ccl4.org>
+Mon Apr 25 07:29:14 IST 2005 Abhijit Menon-Sen <ams@wiw.org>
Version 2.14
1. Store weak references
+ 2. Add STORABLE_attach hook.
Thu Jun 17 12:26:43 BST 2004 Nicholas Clark <nick@ccl4.org>
ChangeLog Changes since baseline
hints/linux.pl Hint file to drop gcc to -O2
# ppport.h Compatibility header
+t/HAS_ATTACH.pm For auto-requiring of modules for STORABLE_attach
t/HAS_HOOK.pm For auto-requiring of modules for STORABLE_thaw
t/HAS_OVERLOAD.pm For auto-requiring of mdoules for overload
+t/attach_errors.t Trigger and test STORABLE_attach errors
+t/attach_singleton.t Test STORABLE_attach for the Singleton pattern
t/blessed.t See if Storable works
t/canonical.t See if Storable works
+t/circular_hook.t Test thaw hook called depth-first for circular refs
t/code.t Test (de)serialization of code references
t/compat06.t See if Storable works
t/croak.t See if Storable works
Returned value: none.
+=item C<STORABLE_attach> I<class>, I<cloning>, I<serialized>
+
+While C<STORABLE_freeze> and C<STORABLE_thaw> are useful for classes where
+each instance is independant, this mechanism has difficulty (or is
+incompatible) with objects that exist as common process-level or
+system-level resources, such as singleton objects, database pools, caches
+or memoized objects.
+
+The alternative C<STORABLE_attach> method provides a solution for these
+shared objects. Instead of C<STORABLE_freeze> --E<GT> C<STORABLE_thaw>,
+you implement C<STORABLE_freeze> --E<GT> C<STORABLE_attach> instead.
+
+Arguments: I<class> is the class we are attaching to, I<cloning> is a flag
+indicating whether we're in a dclone() or a regular de-serialization via
+thaw(), and I<serialized> is the stored string for the resource object.
+
+Because these resource objects are considered to be owned by the entire
+process/system, and not the "property" of whatever is being serialized,
+no references underneath the object should be included in the serialized
+string. Thus, in any class that implements C<STORABLE_attach>, the
+C<STORABLE_freeze> method cannot return any references, and C<Storable>
+will throw an error if C<STORABLE_freeze> tries to return references.
+
+All information required to "attach" back to the shared resource object
+B<must> be contained B<only> in the C<STORABLE_freeze> return string.
+Otherwise, C<STORABLE_freeze> behaves as normal for C<STORABLE_attach>
+classes.
+
+Because C<STORABLE_attach> is passed the class (rather than an object),
+it also returns the object directly, rather than modifying the passed
+object.
+
+Returned value: object of type C<class>
+
=back
=head2 Predicates
ary = AvARRAY(av);
pv = SvPV(ary[0], len2);
+ /* We can't use pkg_can here because it only caches one method per
+ * package */
+ {
+ GV* gv = gv_fetchmethod_autoload(pkg, "STORABLE_attach", FALSE);
+ if (gv && isGV(gv)) {
+ if (count > 1)
+ CROAK(("Freeze cannot return references if %s class is using STORABLE_attach", classname));
+ goto check_done;
+ }
+ }
/*
* If they returned more than one item, we need to serialize some
* proposed the right fix. -- RAM, 15/09/2000
*/
+check_done:
if (!known_class(aTHX_ cxt, classname, len, &classnum)) {
TRACEME(("first time we see class %s, ID = %d", classname, classnum));
classnum = -1; /* Mark: we must store classname */
* Recursively store object...
*/
- ASSERT(is_storing(), ("within store operation"));
+ ASSERT(is_storing(aTHX), ("within store operation"));
status = store(aTHX_ cxt, sv); /* Just do it! */
SV *hook;
SV *sv;
SV *rv;
+ GV *attach;
int obj_type;
int clone = cxt->optype & ST_CLONE;
char mtype = '\0';
*/
BLESS(sv, classname);
+
+ /* Handle attach case; again can't use pkg_can because it only
+ * caches one method */
+ attach = gv_fetchmethod_autoload(SvSTASH(sv), "STORABLE_attach", FALSE);
+ if (attach && isGV(attach)) {
+ SV* attached;
+ SV* attach_hook = newRV((SV*) GvCV(attach));
+
+ if (av)
+ CROAK(("STORABLE_attach called with unexpected references"));
+ av = newAV();
+ av_extend(av, 1);
+ AvFILLp(av) = 0;
+ AvARRAY(av)[0] = SvREFCNT_inc(frozen);
+ rv = newSVpv(classname, 0);
+ attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
+ if (attached &&
+ SvROK(attached) &&
+ sv_derived_from(attached, classname))
+ return SvRV(attached);
+ CROAK(("STORABLE_attach did not return a %s object", classname));
+ }
+
hook = pkg_can(aTHX_ cxt->hook, SvSTASH(sv), "STORABLE_thaw");
if (!hook) {
/*
TRACEME(("input source is %s", is_tainted ? "tainted" : "trusted"));
init_retrieve_context(aTHX_ cxt, optype, is_tainted);
- ASSERT(is_retrieving(), ("within retrieve operation"));
+ ASSERT(is_retrieving(aTHX), ("within retrieve operation"));
sv = retrieve(aTHX_ cxt, 0); /* Recursively retrieve object, get root SV */
--- /dev/null
+package HAS_ATTACH;
+
+sub STORABLE_attach {
+ ++$attached_count;
+ return bless [], 'HAS_ATTACH';
+}
+
+++$loaded_count;
+
+1;
--- /dev/null
+#!./perl -w
+#
+# Copyright 2005, Adam Kennedy.
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+
+# Man, blessed.t scared the hell out of me. For a second there I thought
+# I'd lose Test::More...
+
+# This file tests several known-error cases relating to STORABLE_attach, in
+# which Storable should (correctly) throw errors.
+
+sub BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config; import Config;
+ if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 35;
+use Storable ();
+
+
+
+
+
+#####################################################################
+# Error 1
+#
+# Classes that implement STORABLE_thaw _cannot_ have references
+# returned by their STORABLE_freeze method. When they do, Storable
+# should throw an exception
+
+
+
+# Good Case - should not die
+{
+ my $goodfreeze = bless {}, 'My::GoodFreeze';
+ my $frozen = undef;
+ eval {
+ $frozen = Storable::freeze( $goodfreeze );
+ };
+ ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' );
+ ok( $frozen, 'Storable freezes to a string successfully' );
+
+ package My::GoodFreeze;
+
+ sub STORABLE_freeze {
+ my ($self, $clone) = @_;
+
+ # Illegally include a reference in this return
+ return ('');
+ }
+
+ sub STORABLE_attach {
+ my ($class, $clone, $string) = @_;
+ return bless { }, 'My::GoodFreeze';
+ }
+}
+
+
+
+# Error Case - should die on freeze
+{
+ my $badfreeze = bless {}, 'My::BadFreeze';
+ eval {
+ Storable::freeze( $badfreeze );
+ };
+ ok( $@, 'Storable dies correctly when STORABLE_freeze returns a referece' );
+ # Check for a unique substring of the error message
+ ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' );
+
+ package My::BadFreeze;
+
+ sub STORABLE_freeze {
+ my ($self, $clone) = @_;
+
+ # Illegally include a reference in this return
+ return ('', []);
+ }
+
+ sub STORABLE_attach {
+ my ($class, $clone, $string) = @_;
+ return bless { }, 'My::BadFreeze';
+ }
+}
+
+
+
+
+
+#####################################################################
+# Error 2
+#
+# If, for some reason, a STORABLE_attach object is accidentally stored
+# with references, this should be checked and and error should be throw.
+
+
+
+# Good Case - should not die
+{
+ my $goodthaw = bless {}, 'My::GoodThaw';
+ my $frozen = undef;
+ eval {
+ $frozen = Storable::freeze( $goodthaw );
+ };
+ ok( $frozen, 'Storable freezes to a string as expected' );
+ my $thawed = eval {
+ Storable::thaw( $frozen );
+ };
+ isa_ok( $thawed, 'My::GoodThaw' );
+ is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' );
+
+ package My::GoodThaw;
+
+ sub STORABLE_freeze {
+ my ($self, $clone) = @_;
+
+ return ('');
+ }
+
+ sub STORABLE_attach {
+ my ($class, $clone, $string) = @_;
+ return bless { 'foo' => 'bar' }, 'My::GoodThaw';
+ }
+}
+
+
+
+# Bad Case - should die on thaw
+{
+ # Create the frozen string normally
+ my $badthaw = bless { }, 'My::BadThaw';
+ my $frozen = undef;
+ eval {
+ $frozen = Storable::freeze( $badthaw );
+ };
+ ok( $frozen, 'BadThaw was frozen with references correctly' );
+
+ # Set up the error condition by deleting the normal STORABLE_thaw,
+ # and creating a STORABLE_attach.
+ *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw;
+ *My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning
+ delete ${'My::BadThaw::'}{STORABLE_thaw};
+
+ # Trigger the error condition
+ my $thawed = undef;
+ eval {
+ $thawed = Storable::thaw( $frozen );
+ };
+ ok( $@, 'My::BadThaw object dies when thawing as expected' );
+ # Check for a snippet from the error message
+ ok( $@ =~ /unexpected references/, 'Dies with the expected error message' );
+
+ package My::BadThaw;
+
+ sub STORABLE_freeze {
+ my ($self, $clone) = @_;
+
+ return ('', []);
+ }
+
+ # Start with no STORABLE_attach method so we can get a
+ # frozen object-containing-a-reference into the freeze string.
+ sub STORABLE_thaw {
+ my ($class, $clone, $string) = @_;
+ return bless { 'foo' => 'bar' }, 'My::BadThaw';
+ }
+}
+
+
+
+
+#####################################################################
+# Error 3
+#
+# Die if what is returned by STORABLE_attach is not something of that class
+
+
+
+# Good Case - should not die
+{
+ my $goodattach = bless { }, 'My::GoodAttach';
+ my $frozen = Storable::freeze( $goodattach );
+ ok( $frozen, 'My::GoodAttach return as expected' );
+ my $thawed = eval {
+ Storable::thaw( $frozen );
+ };
+ isa_ok( $thawed, 'My::GoodAttach' );
+ is( ref($thawed), 'My::GoodAttach::Subclass',
+ 'The slightly-tricky good "returns a subclass" case returns as expected' );
+
+ package My::GoodAttach;
+
+ sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return ('');
+ }
+
+ sub STORABLE_attach {
+ my ($class, $cloning, $string) = @_;
+
+ return bless { }, 'My::GoodAttach::Subclass';
+ }
+
+ package My::GoodAttach::Subclass;
+
+ BEGIN {
+ @ISA = 'My::GoodAttach';
+ }
+}
+
+
+
+# Bad Cases - die on thaw
+{
+ my $returnvalue = undef;
+
+ # Create and freeze the object
+ my $badattach = bless { }, 'My::BadAttach';
+ my $frozen = Storable::freeze( $badattach );
+ ok( $frozen, 'BadAttach freezes as expected' );
+
+ # Try a number of different return values, all of which
+ # should cause Storable to die.
+ my @badthings = (
+ undef,
+ '',
+ 1,
+ [],
+ {},
+ \"foo",
+ (bless { }, 'Foo'),
+ );
+ foreach ( @badthings ) {
+ $returnvalue = $_;
+
+ my $thawed = undef;
+ eval {
+ $thawed = Storable::thaw( $frozen );
+ };
+ ok( $@, 'BadAttach dies on thaw' );
+ ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/,
+ 'BadAttach dies on thaw with the expected error message' );
+ is( $thawed, undef, 'Double checking $thawed was not set' );
+ }
+
+ package My::BadAttach;
+
+ sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return ('');
+ }
+
+ sub STORABLE_attach {
+ my ($class, $cloning, $string) = @_;
+
+ return $returnvalue;
+ }
+}
--- /dev/null
+#!./perl -w
+#
+# Copyright 2005, Adam Kennedy.
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+
+# Tests freezing/thawing structures containing Singleton objects,
+# which should see both structs pointing to the same object.
+
+sub BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config; import Config;
+ if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+use Test::More tests => 11;
+use Storable ();
+
+# Get the singleton
+my $object = My::Singleton->new;
+isa_ok( $object, 'My::Singleton' );
+
+# Confirm (for the record) that the class is actually a Singleton
+my $object2 = My::Singleton->new;
+isa_ok( $object2, 'My::Singleton' );
+is( "$object", "$object2", 'Class is a singleton' );
+
+############
+# Main Tests
+
+my $struct = [ 1, $object, 3 ];
+
+# Freeze the struct
+my $frozen = Storable::freeze( $struct );
+ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' );
+
+# Thaw the struct
+my $thawed = Storable::thaw( $frozen );
+
+# Now it should look exactly like the original
+is_deeply( $struct, $thawed, 'Struct superficially looks like the original' );
+
+# ... EXCEPT that the Singleton should be the same instance of the object
+is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' );
+
+# We can also test this empirically
+$struct->[1]->{value} = 'Goodbye cruel world!';
+is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
+
+# End Tests
+###########
+
+package My::Singleton;
+
+my $SINGLETON = undef;
+
+sub new {
+ $SINGLETON or
+ $SINGLETON = bless { value => 'Hello World!' }, $_[0];
+}
+
+sub STORABLE_freeze {
+ my $self = shift;
+
+ # We don't actually need to return anything, but provide a null string
+ # to avoid the null-list-return behaviour.
+ return ('foo');
+}
+
+sub STORABLE_attach {
+ my ($class, $clone, $string) = @_;
+ Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' );
+ Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' );
+ Test::More::is( $clone, 0, 'We are not in a dclone' );
+ Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' );
+
+ # Get the Singleton object and return it
+ return $class->new;
+}
--- /dev/null
+#!./perl -w
+#
+# Copyright 2005, Adam Kennedy.
+#
+# You may redistribute only under the same terms as Perl 5, as specified
+# in the README file that comes with the distribution.
+#
+
+# Man, blessed.t scared the hell out of me. For a second there I thought
+# I'd lose Test::More...
+
+# This file tests several known-error cases relating to STORABLE_attach, in
+# which Storable should (correctly) throw errors.
+
+sub BEGIN {
+ if ($ENV{PERL_CORE}){
+ chdir('t') if -d 't';
+ @INC = ('.', '../lib');
+ } else {
+ unshift @INC, 't';
+ }
+ require Config; import Config;
+ if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+ print "1..0 # Skip: Storable was not built\n";
+ exit 0;
+ }
+}
+
+use Storable ();
+use Test::More tests => 9;
+
+my $ddd = bless { }, 'Foo';
+my $eee = bless { Bar => $ddd }, 'Bar';
+$ddd->{Foo} = $eee;
+
+my $array = [ $ddd ];
+
+my $string = Storable::freeze( $array );
+my $thawed = Storable::thaw( $string );
+
+# is_deeply infinite loops in ciculars, so do it manually
+# is_deeply( $array, $thawed, 'Circular hooked objects work' );
+is( ref($thawed), 'ARRAY', 'Top level ARRAY' );
+is( scalar(@$thawed), 1, 'ARRAY contains one element' );
+isa_ok( $thawed->[0], 'Foo' );
+is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' );
+isa_ok( $thawed->[0]->{Foo}, 'Bar' );
+is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' );
+isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' );
+is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' );
+
+# Make sure the thawing went the way we expected
+is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' );
+
+
+
+
+
+package Foo;
+
+@order = ();
+
+sub STORABLE_freeze {
+ my ($self, $clone) = @_;
+ my $class = ref $self;
+
+ # print "# Freezing $class\n";
+
+ return ($class, $self->{$class});
+}
+
+sub STORABLE_thaw {
+ my ($self, $clone, $string, @refs) = @_;
+ my $class = ref $self;
+
+ # print "# Thawing $class\n";
+
+ $self->{$class} = shift @refs;
+
+ push @order, $class;
+
+ return;
+}
+
+package Bar;
+
+BEGIN {
+@ISA = 'Foo';
+}
+
+1;
projects / p5sagit/p5-mst-13.2.git / commitdiff