build_requires 'Test::Exception' => '0';
build_requires 'Test::TempDir' => '0.02';
+resources repository => 'git://git.moose.perl.org/gitmo/MooseX-Storage.git';
+
auto_install;
WriteAll;
+
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+
# || confess "You must specify a format role in order to use an IO role";
push @roles => 'MooseX::Storage::IO::' . $params{'io'};
}
-
- Class::MOP::load_class($_)
- || die "Could not load role (" . $_ . ")"
- foreach @roles;
+
+ # Note:
+ # These traits alter the behaviour of the engine, the user can
+ # specify these per role-usage
+ for my $trait ( @{ $params{'traits'} ||= [] } ) {
+ push @roles, 'MooseX::Storage::Traits::'.$trait;
+ }
+
+ for my $role ( @roles ) {
+ Class::MOP::load_class($role) or die "Could not load role ($role)";
+ }
return @roles;
}
=head1 NAME
-MooseX::Storage - An serialization framework for Moose classes
+MooseX::Storage - A serialization framework for Moose classes
=head1 SYNOPSIS
This level is not optional, it is the bare minumum that
MooseX::Storage provides and all other levels build on top of this.
+See L<Moosex::Storage::Basic> for the fundamental implementation and
+options to C<pack> and C<unpack>
+
=item B<format>
The second (format) level is C<freeze> and C<thaw>. In this level the
=back
+=head2 Behaviour modifiers
+
+The serialization behaviour can be changed by supplying C<traits>.
+This can be done as follows:
+
+ use MooseX::Storage;
+ with Storage( traits => [Trait1, Trait2,...] );
+
+The following traits are currently bundled with C<MooseX::Storage>:
+
+=over 4
+
+=item OnlyWhenBuilt
+
+Only attributes that have been built (ie, where the predicate returns
+'true') will be serialized. This avoids any potentially expensive computations.
+
+See L<MooseX::Storage::Traits::OnlyWhenBuilt> for details.
+
+=back
+
=head2 How we serialize
There are always limits to any serialization framework, there are just
-
package MooseX::Storage::Base::WithChecksum;
use Moose::Role;
+with 'MooseX::Storage::Basic';
+
use Digest ();
use Data::Dumper ();
-use MooseX::Storage::Engine;
-
our $VERSION = '0.18';
our $AUTHORITY = 'cpan:STEVAN';
our $DIGEST_MARKER = '__DIGEST__';
-sub pack {
- my ($self, @args ) = @_;
+around pack => sub {
+ my $orig = shift;
+ my $self = shift;
+ my @args = @_;
- my $e = MooseX::Storage::Engine->new( object => $self );
+ my $collapsed = $self->$orig( @args );
- my $collapsed = $e->collapse_object(@args);
-
$collapsed->{$DIGEST_MARKER} = $self->_digest_packed($collapsed, @args);
return $collapsed;
-}
+};
-sub unpack {
- my ($class, $data, @args) = @_;
+around unpack => sub {
+ my ($orig, $class, $data, @args) = @_;
# check checksum on data
-
my $old_checksum = delete $data->{$DIGEST_MARKER};
my $checksum = $class->_digest_packed($data, @args);
($checksum eq $old_checksum)
|| confess "Bad Checksum got=($checksum) expected=($old_checksum)";
- my $e = MooseX::Storage::Engine->new(class => $class);
- $class->new($e->expand_object($data, @args));
-}
+ $class->$orig( $data, @args );
+};
sub _digest_packed {
-
package MooseX::Storage::Basic;
use Moose::Role;
sub pack {
my ( $self, @args ) = @_;
- my $e = MooseX::Storage::Engine->new( object => $self );
+ my $e = $self->_storage_get_engine( object => $self );
$e->collapse_object(@args);
}
sub unpack {
- my ( $class, $data, @args ) = @_;
- my $e = MooseX::Storage::Engine->new( class => $class );
- $class->new( $e->expand_object($data, @args) );
+ my ($class, $data, %args) = @_;
+ my $e = $class->_storage_get_engine(class => $class);
+
+ $class->_storage_construct_instance(
+ $e->expand_object($data, %args),
+ \%args
+ );
+}
+
+sub _storage_get_engine {
+ my $self = shift;
+ MooseX::Storage::Engine->new( @_ );
+}
+
+sub _storage_construct_instance {
+ my ($class, $args, $opts) = @_;
+ my %i = defined $opts->{'inject'} ? %{ $opts->{'inject'} } : ();
+
+ $class->new( %$args, %i );
}
1;
# unpack the hash into a class
my $p2 = Point->unpack({ __CLASS__ => 'Point-0.01', x => 10, y => 10 });
+
+ # unpack the hash, with insertion of paramaters
+ my $p3 = Point->unpack( $p->pack, inject => { x => 11 } );
=head1 DESCRIPTION
=over 4
-=item B<pack>
+=item B<pack ([ disable_cycle_check => 1])>
+
+Providing the C<disable_cycle_check> argument disables checks for any cyclical
+references. The current implementation for this check is rather naive, so if
+you know what you are doing, you can bypass this check.
+
+This trait is applied on a perl-case basis. To set this flag for all objects
+that inherit from this role, see L<MooseX::Storage::Traits::DisableCycleDetection>.
+
+=item B<unpack ($data [, insert => { key => val, ... } ] )>
-=item B<unpack ($data)>
+Providing the C<insert> argument let's you supply additional arguments to
+the class' C<new> function, or override ones from the serialized data.
=back
sub expand_object {
my ($self, $data, %options) = @_;
- $options{check_version} = 1 unless exists $options{check_version};
- $options{check_authority} = 1 unless exists $options{check_authority};
-
+ $options{check_version} = 1 unless exists $options{check_version};
+ $options{check_authority} = 1 unless exists $options{check_authority};
+
# NOTE:
# mark the root object as seen ...
$self->seen->{refaddr $data} = undef;
# this might not be enough, we might
# need to make it possible for the
# cycle checker to return the value
- $self->check_for_cycle_in_collapse($attr, $value)
- if ref $value;
+ # Check cycles unless explicitly disabled
+ if( ref $value and not(
+ $options->{disable_cycle_check} or
+ $self->object->does('MooseX::Storage::Traits::DisableCycleDetection')
+ )) {
+ $self->check_for_cycle_in_collapse($attr, $value)
+ }
if (defined $value && $attr->has_type_constraint) {
my $type_converter = $self->find_type_handler($attr->type_constraint);
# NOTE:
# (see comment in method above ^^)
- $self->check_for_cycle_in_expansion($attr, $value)
- if ref $value;
+ if( ref $value and not(
+ $options->{disable_cycle_check} or
+ $self->class->does('MooseX::Storage::Traits::DisableCycleDetection')
+ )) {
+ $self->check_for_cycle_in_collapse($attr, $value)
+ }
if (defined $value && $attr->has_type_constraint) {
my $type_converter = $self->find_type_handler($attr->type_constraint);
sub map_attributes {
my ($self, $method_name, @args) = @_;
- map {
- $self->$method_name($_, @args)
- } grep {
+
+ # The $self->object check is here to differentiate a ->pack from a
+ # ->unpack; ->object is only defined for a ->pack
+
+ # no checks needed if this is class based (ie, restore)
+ unless( $self->object ) {
+ return map { $self->$method_name($_, @args) }
+ $self->class->meta->get_all_attributes;
+ }
+
+ # if it's object based, it's a store -- in that case,
+ # check thoroughly
+ my @rv;
+ my $o = $self->object;
+ for my $attr ( $o->meta->get_all_attributes ) {
+
# Skip our special skip attribute :)
- !$_->does('MooseX::Storage::Meta::Attribute::Trait::DoNotSerialize')
- } ($self->object || $self->class)->meta->get_all_attributes;
+ next if $attr->does(
+ 'MooseX::Storage::Meta::Attribute::Trait::DoNotSerialize');
+
+ # If we're invoked with the 'OnlyWhenBuilt' trait, we should
+ # only serialize the attribute if it's already built. So, go ahead
+ # and check if the attribute has a predicate. If so, check if it's
+ # set and then go ahead and look it up.
+ if( $o->does('MooseX::Storage::Traits::OnlyWhenBuilt') and
+ my $pred = $attr->predicate
+ ) {
+ next unless $self->object->$pred;
+ }
+ push @rv, $self->$method_name($attr, @args);
+ }
+
+ return @rv;
}
## ------------------------------------------------------------------
--- /dev/null
+package MooseX::Storage::Traits::DisableCycleDetection;
+use Moose::Role;
+
+our $VERSION = '0.18';
+our $AUTHORITY = 'cpan:STEVAN';
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Storage::Traits::DisableCycleDetection - A custom trait to bypass cycle detection
+
+=head1 SYNOPSIS
+
+
+ package Double;
+ use Moose;
+ use MooseX::Storage;
+ with Storage( traits => ['DisableCycleDetection'] );
+
+ has 'x' => ( is => 'rw', isa => 'HashRef' );
+ has 'y' => ( is => 'rw', isa => 'HashRef' );
+
+ my $ref = {};
+
+ my $double = Double->new( 'x' => $ref, 'y' => $ref );
+
+ $double->pack;
+
+
+=head1 DESCRIPTION
+
+C<MooseX::Storage> implements a primitive check for circular references.
+This check also triggers on simple cases as shown in the Synopsis.
+Providing the C<DisableCycleDetection> traits disables checks for any cyclical
+references, so if you know what you are doing, you can bypass this check.
+
+This trait is applied to all objects that inherit from it. To use this
+on a per-case basis, see C<disable_cycle_check> in L<MooseX::Storage::Basic>.
+
+See the SYNOPSIS for a nice example that can be easily cargo-culted.
+
+=head1 METHODS
+
+=head2 Introspection
+
+=over 4
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
--- /dev/null
+package MooseX::Storage::Traits::OnlyWhenBuilt;
+use Moose::Role;
+
+our $VERSION = '0.18';
+our $AUTHORITY = 'cpan:STEVAN';
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Storage::Traits::OnlyWhenBuilt - A custom trait to bypass serialization
+
+=head1 SYNOPSIS
+
+
+ { package Point;
+ use Moose;
+ use MooseX::Storage;
+
+ with Storage( traits => [qw|OnlyWhenBuilt|] );
+
+ has 'x' => (is => 'rw', lazy_build => 1 );
+ has 'y' => (is => 'rw', lazy_build => 1 );
+ has 'z' => (is => 'rw', builder => '_build_z' );
+
+
+ sub _build_x { 3 }
+ sub _build_y { expensive_computation() }
+ sub _build_z { 3 }
+
+ }
+
+ my $p = Point->new( 'x' => 4 );
+
+ # the result of ->pack will contain:
+ # { x => 4, z => 3 }
+ $p->pack;
+
+=head1 DESCRIPTION
+
+Sometimes you don't want a particular attribute to be part of the
+serialization if it has not been built yet. If you invoke C<Storage()>
+as outlined in the C<Synopsis>, only attributes that have been built
+(ie, where the predicate returns 'true') will be serialized.
+This avoids any potentially expensive computations.
+
+See the SYNOPSIS for a nice example that can be easily cargo-culted.
+
+=head1 METHODS
+
+=head2 Introspection
+
+=over 4
+
+=item B<meta>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2008 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More tests => 18;
use Test::Exception;
BEGIN {
'... got the right packed version (with parent attribute skipped)');
}
+### this fails with cycle detection on
+{ package Double;
+ use Moose;
+ use MooseX::Storage;
+ with Storage;
+
+ has 'x' => ( is => 'rw', isa => 'HashRef' );
+ has 'y' => ( is => 'rw', isa => 'HashRef' );
+}
+
+{ my $ref = {};
+
+ my $double = Double->new( 'x' => $ref, 'y' => $ref );
+
+ ### currently, the cycle checker's too naive to figure out this is not
+ ### a problem, pass an empty hashref to the 2nd test to make sure it
+ ### doesn't warn/die
+ TODO: {
+ local $TODO = "Cycle check is too naive";
+ my $pack = eval { $double->pack; };
+ ok( $pack, "Object with 2 references packed" );
+ ok( Double->unpack( $pack || {} ),
+ " And unpacked again" );
+ }
+
+ my $pack = $double->pack( disable_cycle_check => 1 );
+ ok( $pack, " Object packs when cycle check is disabled");
+ ok( Double->unpack( $pack ),
+ " And unpacked again" );
+
+}
+
+### the same as above, but now done with a trait
+### this fails with cycle detection on
+{ package DoubleNoCycle;
+ use Moose;
+ use MooseX::Storage;
+ with Storage( traits => ['DisableCycleDetection'] );
+
+ has 'x' => ( is => 'rw', isa => 'HashRef' );
+ has 'y' => ( is => 'rw', isa => 'HashRef' );
+}
+
+{ my $ref = {};
+ my $double = DoubleNoCycle->new( 'x' => $ref, 'y' => $ref );
+ my $pack = $double->pack;
+ ok( $pack, "Object packs with DisableCycleDetection trait");
+ ok( DoubleNoCycle->unpack( $pack ),
+ " Unpacked again" );
+}
use strict;
use warnings;
-use Test::More tests => 6;
+use Test::More tests => 13;
use Test::Exception;
BEGIN {
1;
}
-my $foo = Foo->new;
-isa_ok($foo, 'Foo');
-
-is($foo->bar, 'BAR', '... got the value we expected');
-is($foo->baz, 'BAZ', '... got the value we expected');
-is($foo->gorch, 'GORCH', '... got the value we expected');
+{ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 'BAR', '... got the value we expected');
+ is($foo->baz, 'BAZ', '... got the value we expected');
+ is($foo->gorch, 'GORCH', '... got the value we expected');
+
+ is_deeply(
+ $foo->pack,
+ {
+ __CLASS__ => 'Foo',
+ gorch => 'GORCH'
+ },
+ '... got the right packed class data'
+ );
+}
-is_deeply(
- $foo->pack,
- {
- __CLASS__ => 'Foo',
- gorch => 'GORCH'
- },
- '... got the right packed class data'
-);
+### more involved test; required attribute that's not serialized
+{ package Bar;
+ use Moose;
+ use MooseX::Storage;
+ with Storage;
+ has foo => (
+ metaclass => 'DoNotSerialize',
+ required => 1,
+ is => 'rw',
+ isa => 'Object', # type constraint is important
+ );
+
+ has zot => (
+ default => sub { $$ },
+ is => 'rw',
+ );
+}
+{ my $obj = bless {};
+ my $bar = Bar->new( foo => $obj );
+
+ ok( $bar, "New object created" );
+ is( $bar->foo, $obj, " ->foo => $obj" );
+ is( $bar->zot, $$, " ->zot => $$" );
+
+ my $bpack = $bar->pack;
+ is_deeply(
+ $bpack,
+ { __CLASS__ => 'Bar',
+ zot => $$,
+ }, " Packed correctly" );
+
+ eval { Bar->unpack( $bpack ) };
+ ok( $@, " Unpack without required attribute fails" );
+ like( $@, qr/foo/, " Proper error recorded" );
+
+ my $bar2 = Bar->unpack( $bpack, inject => { foo => bless {} } );
+ ok( $bar2, " Unpacked correctly with foo => Object");
+}
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';#tests => 6;
+use Test::Exception;
+
+BEGIN {
+ use_ok('MooseX::Storage');
+}
+
+{ package Point;
+ use Moose;
+ use MooseX::Storage;
+
+ with Storage( traits => [qw|OnlyWhenBuilt|] );
+
+ has 'x' => (is => 'rw', lazy_build => 1 );
+ has 'y' => (is => 'rw', lazy_build => 1 );
+ has 'z' => (is => 'rw', builder => '_build_z' );
+
+
+ sub _build_x { 'x' }
+ sub _build_y { 'y' }
+ sub _build_z { 'z' }
+
+}
+
+my $p = Point->new( 'x' => $$ );
+ok( $p, "New object created" );
+
+my $href = $p->pack;
+
+ok( $href, " Object packed" );
+is( $href->{'x'}, $$, " x => $$" );
+is( $href->{'z'}, 'z', " z => z" );
+ok( not(exists($href->{'y'})), " y does not exist" );
+
+is_deeply(
+ $href,
+ { '__CLASS__' => 'Point',
+ 'x' => $$,
+ 'z' => 'z'
+ }, " Deep check passed" );
projects / gitmo/MooseX-Storage.git / commitdiff