Class-Std-Storable-v0.0.1/0000755000076500007650000000000010303237776015210 5ustar lukeluke00000000000000Class-Std-Storable-v0.0.1/Build.PL0000644000076500007650000000074510302125661016476 0ustar lukeluke00000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Class::Std::Storable', license => 'perl', dist_author => 'Luke Meyer ', dist_version_from => 'lib/Class/Std/Storable.pm', requires => { 'Class::Std' => '0.0.4', 'Test::More' => 0, 'version' => 0, }, add_to_cleanup => [ 'Class-Std-Storable-*' ], ); $builder->create_build_script(); Class-Std-Storable-v0.0.1/Changes0000644000076500007650000000014210302125031016453 0ustar lukeluke00000000000000Revision history for Class-Std-Storable 0.0.1 Sun Aug 21 12:21:45 2005 Initial release. Class-Std-Storable-v0.0.1/lib/0000755000076500007650000000000010303237776015756 5ustar lukeluke00000000000000Class-Std-Storable-v0.0.1/lib/Class/0000755000076500007650000000000010303237776017023 5ustar lukeluke00000000000000Class-Std-Storable-v0.0.1/lib/Class/Std/0000755000076500007650000000000010303237776017555 5ustar lukeluke00000000000000Class-Std-Storable-v0.0.1/lib/Class/Std/Storable.pm0000644000076500007650000003610310303237145021657 0ustar lukeluke00000000000000package 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 %attributes_of; 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 = \&Class::Std::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 @{$attributes_of{$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) = @_; $self->STORABLE_freeze_pre($cloning) if UNIVERSAL::can($self, "STORABLE_freeze_pre"); 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 = $attributes_of{$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}; } } $self->STORABLE_freeze_post($cloning, \%frozen_attr) if UNIVERSAL::can($self, "STORABLE_freeze_post"); 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 can ignore $serialized, as we know it's an anon_scalar. $self->STORABLE_thaw_pre($cloning, $frozen_attr_ref) if UNIVERSAL::can($self, "STORABLE_thaw_pre"); my $id = ident($self); PACKAGE: while( my ($package, $pkg_attr_ref) = each %$frozen_attr_ref ) { croak "unknown base class '$package' seen while thawing ".ref($self) if ! UNIVERSAL::isa($self, $package); my $attr_list_ref = $attributes_of{$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 while thawing" ." class $package: " . join(q{, }, @extra_keys); } } $self->STORABLE_thaw_post($cloning) if UNIVERSAL::can($self, "STORABLE_thaw_post"); } 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 :set ); my %flavor_of :ATTR( :get :set ); } package main; my $object = Ice::Cream->new; $object->set_name("Vanilla Bean"); $object->set_flavor("vanilla"); But now, you may also serialize the object with Storable. use Storable; my $serialized = Storable::freeze($object); #store to a file, database, or wherever, and retrieve later. my $clone = Storable::thaw($serialized); =head1 DESCRIPTION Class::Std introduced the "inside-out" model for classes (perldoc Class::Std for details). Among its salient features is complete encapsulation; that is, an object's data may only be accessed via its methods, unlike the usual hashref model that permits direct access by any code whatsoever. However, the drawback of complete encapsulation is that normal mechanisms for serialization won't work, as they rely on direct access to an object's attributes. 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 replace the existing attributes of an object, it COULD be used to create an arbitrarily mutated clone of an object without going through its methods. Also, if attributes are themselves references, then the objects to which they refer can be obtained and modified. 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 required to provide serialization. You must choose which is more important for your purposes, serialization or complete encapsulation. Consider also that while bypassing the class methods is possible to a limited degree with Class::Std::Storable, doing so is much more complicated than just using the methods, so use of this class still discourages casual violations of encapsulation. =head1 INTERFACE See Class::Std This package provides object methods STORABLE_freeze and STORABLE_thaw which are not intended to be used directly or overridden. A class generated using Class::Std::Storable may provide hooks to be called when a freeze or a thaw is performed. These methods will be called if provided: =over =item $obj->STORABLE_freeze_pre($cloning) Called against the object at the very beginning of a freeze. First parameter is Storable's "cloning" flag -- see Storable. This method could be used, for example, to adjust or remove non-serializable attributes. =item $obj->STORABLE_freeze_post($cloning, $param_ref) Called against the object after the parameters for the freeze have been determined, but before actual serialization. First parameter is Storable's "cloning" flag -- see Storable. Second parameter is a reference to a hash of hashes of parameters to be frozen, where the first level hash is keyed on the package name of the class, and the second level is keyed on the declared parameters of that class. E.g.: $param_ref = { 'Base::Class' => { flavor => "vanilla", name => "Vanilla Bean", }, 'Sub::Class' => { name => "Shiny Wax", price => '$0.02', }, }; This hook could be used to adjust the attributes that are about to be frozen for its class. It is probably unwise to adjust the attributes of other classes or to add new top-level hash entries. This hook could also be used to undo any changes that were necessary in STORABLE_freeze_pre. =item $obj->STORABLE_thaw_pre($cloning, $param_ref) Called against the object at the very beginning of a thaw. First parameter is Storable's "cloning" flag -- see Storable. Second parameter is the same parameter hash described for the previous method, which will be used to reconstruct the object. This method could be used for validation, or to reconstruct attributes that couldn't be serialized. =item $obj->STORABLE_thaw_post($cloning) Called against the object when a thaw is otherwise complete. First parameter is Storable's "cloning" flag -- see Storable. This method could be used for validation, to reconstruct attributes that couldn't be serialized, or to adjust class data. =back It would undoubtedly be a good idea to mark these methods :CUMULATIVE if provided, so that base classes can perform their own hooks. Also, these methods can not be provided via AUTOLOAD. =head1 DIAGNOSTICS See Class::Std for its diagnostics. Only the following are particular to Class::Std::Storable. All are exceptions thrown with Carp::croak. =over =item "unknown attribute(s) seen while thawing" This indicates that when STORABLE_thaw tried to thaw an object, it found that the frozen object had an attribute that is not declared in the class. This could mean the class definition changed, removing or renaming attributes, between the freezing and thawing of the object. It could also mean that the STORABLE_freeze_post hook was used to insert an unknown key into the freezing hash for this class. Remove such additions in the STORABLE_thaw_pre hook (before the thawing gets under way). =item "unknown base class '$package' seen while thawing" This means that when thawing an object, its frozen hash representation included an entry that is neither the class or a base class. While this could mean that class names changed between freezing and thawing the object (don't do that), a more likely explanation is that a STORABLE_freeze_post hook inserted an unknown key into the top level of the freezing hash (don't do that either). =item "trying to modify existing attributes for $package" This probably means that some code is calling STORABLE_thaw directly on an existing object in an attempt to fiddle with its attributes. Don't even think about doing that. The other explanation would be that the STORABLE_thaw_pre hook set an attribute for the object but left that attribute in the frozen hash to be thawed later. STORABLE_thaw_pre should delete from the frozen hash any attributes that it sets itself. =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. This module depends on a small set of Class::Std internals staying largely the same and could break if that assumption proves false. =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 works fine with nested structures and correctly persists multiple references to the same object, as long as all references are contained in a single serialization. Class::Std::Storable has never been tested for thread safety, so no guarantees there. 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" won't 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, or through the web interface at L. =head1 AUTHOR Luke Meyer C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, Luke Meyer. 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. =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. Class-Std-Storable-v0.0.1/Makefile.PL0000644000076500007650000000107410302125723017147 0ustar lukeluke00000000000000use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Class::Std::Storable', AUTHOR => 'Luke Meyer ', VERSION_FROM => 'lib/Class/Std/Storable.pm', ABSTRACT_FROM => 'lib/Class/Std/Storable.pm', PL_FILES => {}, PREREQ_PM => { 'Class::Std' => '0.0.4', 'Test::More' => 0, 'version' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Class-Std-Storable-*' }, ); Class-Std-Storable-v0.0.1/MANIFEST0000644000076500007650000000022410303237546016332 0ustar lukeluke00000000000000Build.PL Changes MANIFEST META.yml # Will be created by "make dist" Makefile.PL README lib/Class/Std/Storable.pm t/00.load.t t/01.cloning.t t/pod.t Class-Std-Storable-v0.0.1/META.yml0000644000076500007650000000066510303237775016467 0ustar lukeluke00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Class-Std-Storable version: v0.0.1 version_from: lib/Class/Std/Storable.pm installdirs: site requires: Class::Std: 0.0.4 Test::More: 0 version: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Class-Std-Storable-v0.0.1/README0000644000076500007650000000113710302126327016056 0ustar lukeluke00000000000000Class-Std-Storable version 0.0.1 An "inside-out" class builder based on Class::Std that adds the ability to serialize the objects. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL ./Build ./Build test ./Build install DEPENDENCIES Class::Std COPYRIGHT AND LICENCE Copyright (C) 2005, Luke Meyer This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Class-Std-Storable-v0.0.1/t/0000755000076500007650000000000010303237776015453 5ustar lukeluke00000000000000Class-Std-Storable-v0.0.1/t/00.load.t0000644000076500007650000000022010302125031016742 0ustar lukeluke00000000000000use Test::More tests => 1; BEGIN { use_ok( 'Class::Std::Storable' ); } diag( "Testing Class::Std::Storable $Class::Std::Storable::VERSION" ); Class-Std-Storable-v0.0.1/t/01.cloning.t0000644000076500007650000001063510303237730017503 0ustar lukeluke00000000000000package main; use Test::More tests => 43; use strict; package TestClass; use Class::Std::Storable; { my %name_of :ATTR( :get :set ); my %flavor_of :ATTR( :get :set ); } package LinkedList; use Class::Std::Storable; { my %info_of :ATTR( :get :set ); my %next_node_for :ATTR( :get :set ); } package TestMISubClass; use Class::Std::Storable; use base qw( TestClass LinkedList ); { my %ref_copy_for :ATTR( :get ); 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 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"); eval { $object->STORABLE_thaw(0, 0, {unknown => {} } ) }; like($@, qr{unknown base class}, "error on unknown base class"); ########################################################## # calling hooks my($freeze_pre, $freeze_post, $thaw_pre, $thaw_post); { no warnings; #ignore spurious "only used once" warnings *TestClass::STORABLE_freeze_pre = sub { $freeze_pre = 1 }; *TestClass::STORABLE_freeze_post = sub { $freeze_post = 1 }; *TestClass::STORABLE_thaw_pre = sub { $thaw_pre = 1 }; *TestClass::STORABLE_thaw_post = sub { $thaw_post = 1 }; } Storable::dclone($object); ok( $freeze_pre, "STORABLE_freeze_pre called"); ok( $freeze_post, "STORABLE_freeze_post called"); ok( $thaw_pre, "STORABLE_thaw_pre called"); ok( $thaw_post, "STORABLE_thaw_post called"); Class-Std-Storable-v0.0.1/t/pod.t0000644000076500007650000000021410302125031016372 0ustar lukeluke00000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok();