From: Abhijit Menon-Sen Date: Mon, 25 Apr 2005 01:36:38 +0000 (+0000) Subject: Add STORABLE_attach hook (Adam Kennedy). X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2f796f323f0a2d2e2c3db0d837080471654102e8;p=p5sagit%2Fp5-mst-13.2.git Add STORABLE_attach hook (Adam Kennedy). p4raw-id: //depot/perl@24316 --- diff --git a/MANIFEST b/MANIFEST index 4821bf8..23b68c7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -794,6 +794,7 @@ ext/Storable/Storable.pm Storable extension 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 @@ -801,8 +802,11 @@ ext/Storable/t/dclone.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 diff --git a/ext/Storable/ChangeLog b/ext/Storable/ChangeLog index 8371914..64b2f84 100644 --- a/ext/Storable/ChangeLog +++ b/ext/Storable/ChangeLog @@ -1,8 +1,9 @@ -Sat Jul 10 22:37:47 BST 2004 Nicholas Clark +Mon Apr 25 07:29:14 IST 2005 Abhijit Menon-Sen Version 2.14 1. Store weak references + 2. Add STORABLE_attach hook. Thu Jun 17 12:26:43 BST 2004 Nicholas Clark diff --git a/ext/Storable/MANIFEST b/ext/Storable/MANIFEST index df26a7f..37415e5 100644 --- a/ext/Storable/MANIFEST +++ b/ext/Storable/MANIFEST @@ -6,10 +6,14 @@ Storable.xs The C side of Storable 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 diff --git a/ext/Storable/Storable.pm b/ext/Storable/Storable.pm index 2c7e307..51e4f9c 100644 --- a/ext/Storable/Storable.pm +++ b/ext/Storable/Storable.pm @@ -695,6 +695,40 @@ It is up to you to use this information to populate I the way you want. Returned value: none. +=item C I, I, I + +While C and C 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 method provides a solution for these +shared objects. Instead of C --E C, +you implement C --E C instead. + +Arguments: I is the class we are attaching to, I is a flag +indicating whether we're in a dclone() or a regular de-serialization via +thaw(), and I 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, the +C method cannot return any references, and C +will throw an error if C tries to return references. + +All information required to "attach" back to the shared resource object +B be contained B in the C return string. +Otherwise, C behaves as normal for C +classes. + +Because C 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 + =back =head2 Predicates diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 7c6a755..745e3f6 100644 --- a/ext/Storable/Storable.xs +++ b/ext/Storable/Storable.xs @@ -2910,6 +2910,16 @@ static int store_hook( 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 @@ -3015,6 +3025,7 @@ static int store_hook( * 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 */ @@ -3644,7 +3655,7 @@ static int do_store( * Recursively store object... */ - ASSERT(is_storing(), ("within store operation")); + ASSERT(is_storing(aTHX), ("within store operation")); status = store(aTHX_ cxt, sv); /* Just do it! */ @@ -3917,6 +3928,7 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, char *cname) SV *hook; SV *sv; SV *rv; + GV *attach; int obj_type; int clone = cxt->optype & ST_CLONE; char mtype = '\0'; @@ -4138,6 +4150,29 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, char *cname) */ 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) { /* @@ -5949,7 +5984,7 @@ static SV *do_retrieve( 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 */ diff --git a/ext/Storable/t/HAS_ATTACH.pm b/ext/Storable/t/HAS_ATTACH.pm new file mode 100644 index 0000000..72855aa --- /dev/null +++ b/ext/Storable/t/HAS_ATTACH.pm @@ -0,0 +1,10 @@ +package HAS_ATTACH; + +sub STORABLE_attach { + ++$attached_count; + return bless [], 'HAS_ATTACH'; +} + +++$loaded_count; + +1; diff --git a/ext/Storable/t/attach_errors.t b/ext/Storable/t/attach_errors.t new file mode 100644 index 0000000..85971db --- /dev/null +++ b/ext/Storable/t/attach_errors.t @@ -0,0 +1,269 @@ +#!./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; + } +} diff --git a/ext/Storable/t/attach_singleton.t b/ext/Storable/t/attach_singleton.t new file mode 100644 index 0000000..475204f --- /dev/null +++ b/ext/Storable/t/attach_singleton.t @@ -0,0 +1,89 @@ +#!./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; +} diff --git a/ext/Storable/t/circular_hook.t b/ext/Storable/t/circular_hook.t new file mode 100644 index 0000000..782b3d3 --- /dev/null +++ b/ext/Storable/t/circular_hook.t @@ -0,0 +1,91 @@ +#!./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;