| Date: | Sun, 21 Aug 2005 13:10:30 -0400 |
| From: | Luke Meyer <luke [...] daeron.com> |
| To: | bug-Class-Std [...] rt.cpan.org |
| Subject: | Class::Std::Storable |
Alright; starting a new ticket because of too many false starts in the
other one :-)
I now have a fully-formed Class::Std::Storable, with documentation and
everything. It still breaks encapsulation in theory (though it doesn't
allow changing attributes on existing objects), and it relies on a few
Class::Std internals to stay the same, but I think the approach is
basically as sound as possible.
The question for you, Damian, is whether you would like to:
1) Include this in the Class::Std distribution
2) Look into including the functionality as an import option in
Class::Std itself (I'd be happy to do the work)
3) Disavow any connection with the thing and I can upload to CPAN as a
separate distro
All fine by me.
package Class::Std::Storable;
use version; $VERSION = qv('0.0.1');
use strict;
use warnings;
use Class::Std; #get subs from parent to export
use Carp;
#hold attributes by package
my %attribute;
my @exported_subs = qw(
new
ident
DESTROY
MODIFY_HASH_ATTRIBUTES
MODIFY_CODE_ATTRIBUTES
AUTOLOAD
_DUMP
STORABLE_freeze
STORABLE_thaw
);
sub import {
no strict 'refs';
for my $sub ( @exported_subs ) {
*{ caller() . '::' . $sub } = \&{$sub};
}
}
#NOTE: this subroutine should override the one that's imported
#by the "use Class::Std" above.
{
my $old_sub = \&MODIFY_HASH_ATTRIBUTES;
my %positional_arg_of;
my $new_sub = sub {
my ($package, $referent, @attrs) = @_;
my @return_attrs = $old_sub->(@_);
for my $attr (@attrs) {
next if $attr !~ m/\A ATTRS? \s* (?:[(] (.*) [)] )? \z/xms;
my $name;
#we have a backup if no name is given for the attribute.
$positional_arg_of{$package} ||= "__Positional_0001";
#but we would prefer to know the argument as the class does.
if (my $config = $1) {
$name = Class::Std::_extract_init_arg($config)
|| Class::Std::_extract_get($config)
|| Class::Std::_extract_set($config);
}
$name ||= $positional_arg_of{$package}++;
push @{$attribute{$package}}, {
ref => $referent,
name => $name,
};
}
return @return_attrs;
};
no warnings; #or this complains about redefining sub
*MODIFY_HASH_ATTRIBUTES = $new_sub;
};
sub STORABLE_freeze {
#croak "must be called from Storable" unless caller eq 'Storable';
#unfortunately, Storable never appears on the call stack.
my($self, $cloning) = @_;
#we'll ignore $cloning, as there's nothing to do differently.
my $id = ident($self);
require Storable;
my $serialized = Storable::freeze( \ (my $anon_scalar) );
my %frozen_attr; #to be constructed
my @package_list = ref $self;
my %package_seen = ( ref($self) => 1 ); #ignore diamond/looped base classes :-)
PACKAGE:
while( my $package = shift @package_list) {
#make sure we add any base classes to the list of
#packages to examine for attributes.
{ no strict 'refs';
for my $base_class ( @{"${package}::ISA"} ) {
push @package_list, $base_class
if !$package_seen{$base_class}++;
}
}
#examine attributes from known packages only
my $attr_list_ref = $attribute{$package} or next PACKAGE;
#look for any attributes of this object for this package
ATTR:
for my $attr_ref ( @{$attr_list_ref} ) {
#nothing to do if attr not set for this object
next ATTR if !exists $attr_ref->{ref}{$id};
#save the attr by name into the package hash
$frozen_attr{$package}{ $attr_ref->{name} }
= $attr_ref->{ref}{$id};
}
}
return ($serialized, \%frozen_attr );
}
sub STORABLE_thaw {
#croak "must be called from Storable" unless caller eq 'Storable';
#unfortunately, Storable never appears on the call stack.
my($self, $cloning, $serialized, $frozen_attr_ref) = @_;
#we'll ignore $cloning, as there's nothing to do differently.
#we can ignore $serialized too, as we know it's an anon_scalar.
my $id = ident($self);
PACKAGE:
while( my ($package, $pkg_attr_ref) = each %$frozen_attr_ref ) {
my $attr_list_ref = $attribute{$package};
ATTR:
for my $attr_ref ( @{$attr_list_ref} ) { #for known attrs...
#nothing to do if frozen attr doesn't exist
next ATTR if !exists $pkg_attr_ref->{ $attr_ref->{name} };
#block attempts to meddle with existing objects
croak "trying to modify existing attributes for $package"
if exists $attr_ref->{ref}{$id};
#ok, set the attribute
$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);
}
}
}
1; # Magic true value required at end of module
__END__
=head1 NAME
Class::Std::Storable - Support for creating serializable "inside-out" classes
=head1 VERSION
This document describes Class::Std::Storable version 0.0.1
=head1 SYNOPSIS
In general, use this class exactly as you would Class::Std.
package Ice::Cream;
use Class::Std::Storable;
{
my %name_of :ATTR( :get<name> :set<name> );
my %flavor_of :ATTR( :get<flavor> :set<flavor> );
}
package main;
my $object = Ice::Cream->new;
$object->set_name("Vanilla Bean");
$object->set_flavor("vanilla");
But now, you may also serialize the object.
use Storable;
my $serialized = Storable::freeze($object);
#store to a file, database, or wherever, and retrieve later.
my $clone = Storable::thaw($serialized);
=head1 DESCRIPTION
This class provides the class-building functionality from Class::Std, and in
addition provides an interface to allow Storable to freeze and thaw any
declared attributes of this class and any superclasses that were built via
Class::Std::Storable.
However, in order to let Storable save attributes and construct the object,
it is necessary to expose the attributes of the class to the world. Thus,
any code could use the same interface that Storable does to get a copy of
object attributes and create new objects with arbitrary attributes
without going through the constructor. While the interface can't be used to
modify the existing attributes of an object, it could be used to create an
arbitrarily mutated clone of an object without going through its methods.
As true encapsulation is one of the major features of Class::Std, this
would be a good reason NOT to use this class. But this sacrifice is
necessary to provide serialization with an inside-out class.
=head1 INTERFACE
See Class::Std
This package provides private object methods STORABLE_freeze and STORABLE_thaw
which are not to be used directly or overridden.
=head1 DIAGNOSTICS
See Class::Std for its diagnostics. Only the following are
particular to Class::Std::Storable.
=over
=item "unknown attribute(s) seen during deserialization"
This indicates that when Storable tried to thaw an object, it found that the
frozen object had an attribute that is not declared in the class.
This probably means the class definition changed, removing or renaming
attributes, between the freezing and thawing of the object.
Don't do that.
This would also be a problem with plain old hashref
objects, but the failure would be silent and would only show up when your
methods attempted to use the missing attributes.
=item "trying to modify existing attributes for $package"
This almost certainly means that some code is calling STORABLE_thaw
directly on an existing object in an attempt to fiddle with its attributes.
Don't do that.
=back
=head1 CONFIGURATION AND ENVIRONMENT
Class::Std::Storable requires no configuration files or environment variables.
=head1 DEPENDENCIES
Class::Std version 0.0.4 or newer, which is not at this time part of
the Perl core modules.
=head1 INCOMPATIBILITIES
None reported.
=head1 LIMITATIONS
Vanilla Class::Std objects are not themselves serializable. Any base
classes that are not built using Class::Std::Storable will probably not serialize
correctly without special tricks. This is a feature, as it means no one can
just subclass a Class::Std class and break its encapsulation.
Class::Std::Storable attempts to identify attributes by their declaration,
that is, according to how :ATTR declares their getters/setters/initializers.
If none of these are declared for an attribute, it can only be identified by
its position, that is, the order of its appearance in the source code. This
scheme will break if you change the position of these nameless attributes, or
change the names of the named ones, between the freezing and the thawing of an
object.
Serialization of inside-out objects naturally maintains the same caveats as for
any other object. Only declared (:ATTR) object attributes identified with the
object will be serialized with the object. In particular, "class data" cannot
be serialized with the object. Also, an object can't be serialized if any of
its attributes cannot themselves be serialized, e.g. if one is a closure.
=head1 BUGS
No bugs have been reported.
Please report any bugs or feature requests to
C<bug-class-std-storable@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org>.
=head1 AUTHOR
Luke Meyer C<< <luke@daeron.com> >>
=head1 LICENCE AND COPYRIGHT
Copyright (c) 2005, Luke Meyer C<< <luke@daeron.com> >>. All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
=head1 DISCLAIMER OF WARRANTY
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
use strict;
package TestClass;
use Class::Std::Storable;
{
my %name_of :ATTR( :get<name> :set<name> );
my %flavor_of :ATTR( :get<flavor> :set<flavor> );
}
package LinkedList;
use Class::Std::Storable;
{
my %info_of :ATTR( :get<info> :set<info> );
my %next_node_for :ATTR( :get<next_node> :set<next_node> );
}
package TestMISubClass;
use Class::Std::Storable;
use base qw( TestClass LinkedList );
{
my %ref_copy_for :ATTR( :get<ref_copy> );
my %unknown1 :ATTR; #for testing with no attr name given
my %unknown2 :ATTR; #for testing with no attr name given
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;
}
sub set_unknown1 {
my $id = ident shift;
$unknown1{$id} = shift;
}
sub get_unknown1 {
return $unknown1{ident shift};
}
sub set_unknown2 {
my $id = ident shift;
$unknown2{$id} = shift;
}
sub get_unknown2 {
return $unknown2{ident shift};
}
}
package main;
use Test::More tests => 38;
use Class::Std::Storable;
use Storable;
use Carp;
use Data::Dumper;
##########################################################
# 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_unknown1("1_$flavor");
$next->set_unknown2("2_$flavor");
$next->set_next_node($obj);
$obj = $next;
}
$clone = Storable::freeze($obj);
undef $obj; #should destroy the whole list
$clone = Storable::thaw($clone);
for my $flavor ( reverse @flavors ) {
is($flavor, $clone->get_flavor, "flavor cloned the same");
is("1_$flavor", $clone->get_unknown1, "unknown1 cloned the same");
is("2_$flavor", $clone->get_unknown2, "unknown2 cloned the same");
my $next = $clone->get_next_node;
my $copy = $clone->get_ref_copy;
last unless $next;
is(ident($next), ident($copy), "clones of same object should be the same");
$clone = $next;
}
##########################################################
# generating diagnostics
$object = TestClass->new;
$object->set_name("Vanilla Bean");
$object->set_flavor("vanilla");
eval { $object->STORABLE_thaw(0, 0, {TestClass => { name => "foo" } } ) };
like($@, qr{trying to modify existing attributes}, "block attempted manipulation");
eval { $object->STORABLE_thaw(0, 0, {TestClass => { unknown => "foo" } } ) };
like($@, qr{unknown attribute}, "error on unknown attribute");