package MooseX::Storage;
+use Moose qw(confess);
sub import {
my $pkg = caller();
+
+ return if $pkg eq 'main';
+
+ ($pkg->can('meta'))
+ || confess "This package can only be used in Moose based classes";
+
$pkg->meta->alias_method('Storage' => sub {
my %params = @_;
+ $params{'base'} ||= 'Basic';
+
my @roles = (
- 'MooseX::Storage::Basic'
+ ('MooseX::Storage::' . $params{'base'}),
);
- push @roles => 'MooseX::Storage::Format::' . $params{'format'};
- Class::MOP::load_class($roles[-1])
- || die "Could not load format role (" . $roles[-1] . ") for package ($pkg)";
-
+ # NOTE:
+ # you don't have to have a format
+ # role, this just means you dont
+ # get anything other than pack/unpack
+ push @roles => 'MooseX::Storage::Format::' . $params{'format'}
+ if exists $params{'format'};
+
+ # NOTE:
+ # if you do choose an IO role, then
+ # you *must* have a format role chosen
+ # since load/store require freeze/thaw
if (exists $params{'io'}) {
+ (exists $params{'format'})
+ || 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($roles[-1])
- || die "Could not load IO role (" . $roles[-1] . ") for package ($pkg)";
}
+ Class::MOP::load_class($_)
+ || die "Could not load role (" . $_ . ") for package ($pkg)"
+ foreach @roles;
+
return @roles;
});
}
-package MooseX::Storage::Basic;
-use Moose::Role;
+1;
-use MooseX::Storage::Engine;
+__END__
-sub pack {
- my $self = shift;
- my $e = MooseX::Storage::Engine->new( object => $self );
- $e->collapse_object;
-}
+=pod
-sub unpack {
- my ( $class, $data ) = @_;
- my $e = MooseX::Storage::Engine->new( class => $class );
- $class->new( $e->expand_object($data) );
-}
+=head1 NAME
-1;
+MooseX::Storage - A persistence framework for Moose classes
-__END__
+=head1 SYNOPSIS
-=pod
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<import>
+
+=back
+
+=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
+
+Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 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::Basic;
+use Moose::Role;
+
+use MooseX::Storage::Engine;
+
+sub pack {
+ my $self = shift;
+ my $e = MooseX::Storage::Engine->new( object => $self );
+ $e->collapse_object;
+}
+
+sub unpack {
+ my ( $class, $data ) = @_;
+ my $e = MooseX::Storage::Engine->new( class => $class );
+ $class->new( $e->expand_object($data) );
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Storage::Basic
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<pack>
+
+=item B<unpack ($data)>
+
+=back
+
+=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
+
+Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 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
=pod
+=head1 NAME
+
+MooseX::Storage::Engine
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Accessors
+
+=over 4
+
+=item B<class>
+
+=item B<object>
+
+=item B<storage>
+
+=back
+
+=head2 API
+
+=over 4
+
+=item B<expand_object>
+
+=item B<collapse_object>
+
+=back
+
+=head2 ...
+
+=over 4
+
+=item B<collapse_attribute>
+
+=item B<collapse_attribute_value>
+
+=item B<expand_attribute>
+
+=item B<expand_attribute_value>
+
+=item B<map_attributes>
+
+=item B<match_type>
+
+=back
+
+=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
+
+Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 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 IO::File;
-has file => (
- isa => 'Str',
- is => 'ro',
+has 'file' => (
+ is => 'ro',
+ isa => 'Str',
required => 1,
);
print $fh $data;
}
-1;
\ No newline at end of file
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Storage::Engine::IO::File
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<file>
+
+=item B<load>
+
+=item B<store ($data)>
+
+=back
+
+=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
+
+Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 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
=pod
+=head1 NAME
+
+MooseX::Storage::Format::JSON
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<freeze>
+
+=item B<thaw ($json)>
+
+=back
+
+=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
+
+Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 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
+
=pod
+=head1 NAME
+
+MooseX::Storage::IO::File
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<load ($filename)>
+
+=item B<store ($filename)>
+
+=back
+
+=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
+
+Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
+
+Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 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
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+ use_ok('MooseX::Storage');
+}
\ No newline at end of file
use Test::More no_plan => 1;
+BEGIN {
+ use_ok('MooseX::Storage');
+}
+
{
package Foo;
use Moose;
use MooseX::Storage;
- with Storage( 'format' => 'JSON' );
+ with Storage();
has 'number' => ( is => 'ro', isa => 'Int' );
has 'string' => ( is => 'ro', isa => 'Str' );
has 'object' => ( is => 'ro', isa => 'Object' );
}
-SKIP: {
- eval { require Test::JSON };
- skip "HTML::Lint not installed", 3 if $@;
- Test::JSON->import();
+{
my $foo = Foo->new(
number => 10,
string => 'foo',
object => Foo->new( number => 2 ),
);
isa_ok( $foo, 'Foo' );
- my $json = $foo->freeze;
- is_valid_json($json);
- is_json(
- $json,
- '{"array":[1,2,3,4,5,6,7,8,9,10],"hash":{"6":null,"3":null,"7":null,"9":null,"2":null,"8":null,"1":null,"4":null,"10":null,"5":null},"float":10.5,"object":{"number":2,"__class__":"Foo"},"number":10,"__class__":"Foo","string":"foo"}',
- '... got the right JSON'
+
+ is_deeply(
+ $foo->pack,
+ {
+ __class__ => 'Foo',
+ number => 10,
+ string => 'foo',
+ float => 10.5,
+ array => [ 1 .. 10 ],
+ hash => { map { $_ => undef } ( 1 .. 10 ) },
+ object => {
+ __class__ => 'Foo',
+ number => 2
+ },
+ },
+ '... got the right frozen class'
);
}
{
- my $foo = Foo->thaw(
- '{"array":[1,2,3,4,5,6,7,8,9,10],"hash":{"6":null,"3":null,"7":null,"9":null,"2":null,"8":null,"1":null,"4":null,"10":null,"5":null},"float":10.5,"object":{"number":2,"__class__":"Foo"},"number":10,"__class__":"Foo","string":"foo"}'
+ my $foo = Foo->unpack(
+ {
+ __class__ => 'Foo',
+ number => 10,
+ string => 'foo',
+ float => 10.5,
+ array => [ 1 .. 10 ],
+ hash => { map { $_ => undef } ( 1 .. 10 ) },
+ object => {
+ __class__ => 'Foo',
+ number => 2
+ },
+ }
);
isa_ok( $foo, 'Foo' );
is( $foo->object->number, 2,
'... got the right number (in the embedded object)' );
}
-
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::JSON;
+
+BEGIN {
+ use_ok('MooseX::Storage');
+}
+
+{
+
+ package Foo;
+ use Moose;
+ use MooseX::Storage;
+
+ with Storage( 'format' => 'JSON' );
+
+ has 'number' => ( is => 'ro', isa => 'Int' );
+ has 'string' => ( is => 'ro', isa => 'Str' );
+ has 'float' => ( is => 'ro', isa => 'Num' );
+ has 'array' => ( is => 'ro', isa => 'ArrayRef' );
+ has 'hash' => ( is => 'ro', isa => 'HashRef' );
+ has 'object' => ( is => 'ro', isa => 'Object' );
+}
+
+{
+ my $foo = Foo->new(
+ number => 10,
+ string => 'foo',
+ float => 10.5,
+ array => [ 1 .. 10 ],
+ hash => { map { $_ => undef } ( 1 .. 10 ) },
+ object => Foo->new( number => 2 ),
+ );
+ isa_ok( $foo, 'Foo' );
+
+ my $json = $foo->freeze;
+
+ is_valid_json($json);
+
+ is_json(
+ $json,
+ '{"array":[1,2,3,4,5,6,7,8,9,10],"hash":{"6":null,"3":null,"7":null,"9":null,"2":null,"8":null,"1":null,"4":null,"10":null,"5":null},"float":10.5,"object":{"number":2,"__class__":"Foo"},"number":10,"__class__":"Foo","string":"foo"}',
+ '... got the right JSON'
+ );
+}
+
+{
+ my $foo = Foo->thaw(
+ '{"array":[1,2,3,4,5,6,7,8,9,10],"hash":{"6":null,"3":null,"7":null,"9":null,"2":null,"8":null,"1":null,"4":null,"10":null,"5":null},"float":10.5,"object":{"number":2,"__class__":"Foo"},"number":10,"__class__":"Foo","string":"foo"}'
+ );
+ isa_ok( $foo, 'Foo' );
+
+ is( $foo->number, 10, '... got the right number' );
+ is( $foo->string, 'foo', '... got the right string' );
+ is( $foo->float, 10.5, '... got the right float' );
+ is_deeply( $foo->array, [ 1 .. 10 ], '... got the right array' );
+ is_deeply(
+ $foo->hash,
+ { map { $_ => undef } ( 1 .. 10 ) },
+ '... got the right hash'
+ );
+
+ isa_ok( $foo->object, 'Foo' );
+ is( $foo->object->number, 2,
+ '... got the right number (in the embedded object)' );
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+ use_ok('MooseX::Storage');
+}
+
+{
+ package Foo;
+ use Moose;
+ use MooseX::Storage;
+
+ with Storage(format => 'JSON', io => 'File');
+
+ has 'number' => (is => 'ro', isa => 'Int');
+ has 'string' => (is => 'ro', isa => 'Str');
+ has 'float' => (is => 'ro', isa => 'Num');
+ has 'array' => (is => 'ro', isa => 'ArrayRef');
+ has 'hash' => (is => 'ro', isa => 'HashRef');
+ has 'object' => (is => 'ro', isa => 'Object');
+}
+
+my $file = 'temp.json';
+
+{
+ my $foo = Foo->new(
+ number => 10,
+ string => 'foo',
+ float => 10.5,
+ array => [ 1 .. 10 ],
+ hash => { map { $_ => undef } (1 .. 10) },
+ object => Foo->new( number => 2 ),
+ );
+ isa_ok($foo, 'Foo');
+
+ $foo->store($file);
+}
+
+{
+ my $foo = Foo->load($file);
+ isa_ok($foo, 'Foo');
+
+ is($foo->number, 10, '... got the right number');
+ is($foo->string, 'foo', '... got the right string');
+ is($foo->float, 10.5, '... got the right float');
+ is_deeply($foo->array, [ 1 .. 10], '... got the right array');
+ is_deeply($foo->hash, { map { $_ => undef } (1 .. 10) }, '... got the right hash');
+
+ isa_ok($foo->object, 'Foo');
+ is($foo->object->number, 2, '... got the right number (in the embedded object)');
+}
+
+unlink $file;
projects / gitmo/MooseX-Storage.git / commitdiff