| Date: | Thu, 18 Aug 2005 21:26:54 -0400 |
| From: | Luke Meyer <luke [...] daeron.com> |
| To: | bug-Class-Std [...] rt.cpan.org |
| CC: | damian [...] conway.org |
| Subject: | patch to add serialization to Class::Std |
Attached is a patch that adds methods to Class::Std for Storable to
freeze and thaw an inside-out class, as well as a few test cases and the
full class code.
Discussion:
This also provides a side door for users to create inside-out objects
without going through your constructors and accessors, which is
unfortunate for those who really value encapsulation. However, it's
still just about impossible to fool with an object once it's been
created. Nevertheless, it might be a better approach to do one of:
1) Make serializability optional somehow.
2) Make the methods check that caller is 'Storable' (slim security, though)
3) Move serializing to a separate class Class::Std::Storable -- and then
anything you want to be Storable has to be of this type, including base
classes. Sucks because it must either be forked code or a "subclass"
that can parse and keep a copy of the attributes for the serialization.
Also, the serialization of course maintains the same caveat as for any
other object: if it's not an object attribute, it won't get stored with
the object, and you can't serialize an attribute that's a closure or
otherwise not serializable.
--- /Library/Perl/5.8.6/Class/Std.pm 2005-08-07 00:19:22.000000000 -0400
+++ Class/Std.pm 2005-08-18 20:11:41.000000000 -0400
@@ -1,6 +1,6 @@
package Class::Std;
-use version; $VERSION = qv('0.0.4');
+use version; $VERSION = qv('0.0.5');
use strict;
use warnings;
use Carp;
@@ -19,6 +19,8 @@
MODIFY_CODE_ATTRIBUTES
AUTOLOAD
_DUMP
+ STORABLE_freeze
+ STORABLE_thaw
);
sub import {
@@ -130,6 +132,49 @@
return $dump;
}
+sub STORABLE_freeze {
+ my($self, $cloning) = @_;
+ #we'll ignore $cloning; it's not going to make sense to
+ #serialize and deserialize without "cloning".
+ my $id = ID($self);
+ require Storable;
+ my $serialized = Storable::freeze( \(my $anon_scalar) );
+
+ my %freeze; #stolen from _DUMP above
+ for my $package (keys %attribute) {
+ my $attr_list_ref = $attribute{$package};
+ for my $attr_ref ( @{$attr_list_ref} ) {
+ next if !exists $attr_ref->{ref}{$id};
+ $freeze{$package}{$attr_ref->{name}} = $attr_ref->{ref}{$id};
+ }
+ }
+
+ return ($serialized, \%freeze);
+}
+
+sub STORABLE_thaw {
+ my($self, $cloning, $serialized, $frozen_attr_ref) = @_;
+ #we'll ignore $cloning; it's not going to make sense to
+ #serialize and deserialize without "cloning".
+ #we can ignore $serialized too, as we know it's an anon_scalar.
+ my $id = ID($self);
+ while( my ($package, $pkg_attr_ref) = each %$frozen_attr_ref ) {
+ my $attr_list_ref = $attribute{$package};
+ for my $attr_ref ( @{$attr_list_ref} ) {
+ next if !exists $pkg_attr_ref->{ $attr_ref->{name} };
+ $attr_ref->{ref}{$id}
+ = delete $pkg_attr_ref->{ $attr_ref->{name} };
+ }
+ if( my @extra_keys = keys %$pkg_attr_ref ) {
+ #this is probably serious enough to throw an exception.
+ #however, TODO: it would be nice if the class could somehow
+ #indicate to ignore this problem.
+ croak "unknown attribute(s) seen during deserialization"
+ ." for package $package: " . join(q{, }, @extra_keys);
+ }
+ }
+}
+
my $STD_OVERLOADER
= q{ package %%s;
use overload (
use strict;
package TestClass;
use Class::Std;
{
my %name_of :ATTR( :get<name> :set<name> );
my %flavor_of :ATTR( :get<flavor> :set<flavor> );
}
package LinkedList;
use Class::Std;
{
my %info_of :ATTR( :get<info> :set<info> );
my %next_node_for :ATTR( :get<next_node> :set<next_node> );
}
package TestMISubClass;
use Class::Std;
use base qw( TestClass LinkedList );
{
my %ref_copy_for :ATTR( :get<ref_copy> );
sub set_next_node {
my $self = shift;
my $id = ident $self;
die "no param provided" unless @_;
my $next_node = shift;
$ref_copy_for{$id} = $next_node;
$self->SUPER::set_next_node($next_node);
return;
}
}
package main;
use Test::More tests => 24;
use Class::Std;
use Storable;
use Carp;
##########################################################
# very basic testing of a single object
my $object = TestClass->new;
$object->set_name("Vanilla Bean");
$object->set_flavor("vanilla");
my $clone = Storable::dclone($object);
is( $clone->get_name, "Vanilla Bean", "properties successfully cloned");
is( $clone->get_flavor, "vanilla", "properties successfully cloned");
##########################################################
# testing a nested structure
my $first_node = LinkedList->new;
$first_node->set_info(1);
for my $i (2..10) {
my $next_node = LinkedList->new;
$next_node->set_info($i);
$next_node->set_next_node($first_node);
$first_node = $next_node;
}
my $id = ident($first_node);
$first_node = Storable::dclone($first_node);
isnt($id, ident($first_node), "should in fact be a different object");
for my $i (reverse 1..10) {
is($first_node->get_info, $i, "values in the nodes all match");
$first_node = $first_node->get_next_node;
}
##########################################################
# testing MI and structural integrity
my @flavors = qw( vanilla chocolate strawberry mango peach grape );
my $obj;
for my $flavor ( @flavors ) {
my $next = TestMISubClass->new;
$next->set_flavor($flavor);
$next->set_info($flavor);
$next->set_next_node($obj);
$obj = $next;
}
$clone = Storable::dclone($obj);
for my $flavor ( reverse @flavors ) {
is($flavor, $clone->get_flavor, "flavor cloned the same");
my $next = $clone->get_next_node;
my $copy = $clone->get_ref_copy;
last unless $next;
is(ident($next), ident($copy), "clone of same object should be the same");
$clone = $next;
}
Message body is not shown because it is too large.