From: Stevan Little <stevan.little@iinteractive.com>
Date: Fri, 30 Mar 2007 18:41:03 +0000 (+0000)
Subject: moving MooseX::Storage
X-Git-Tag: 0_02~31
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Storage.git;a=commitdiff_plain;h=ec9c19230a64659b0550d8bb3c3686f76ce42588

moving MooseX::Storage
---

diff --git a/lib/MooseX/Storage.pm b/lib/MooseX/Storage.pm
index c6101b9..c28194b 100644
--- a/lib/MooseX/Storage.pm
+++ b/lib/MooseX/Storage.pm
@@ -1,50 +1,98 @@
 
 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
diff --git a/lib/MooseX/Storage/Basic.pm b/lib/MooseX/Storage/Basic.pm
new file mode 100644
index 0000000..24a39ac
--- /dev/null
+++ b/lib/MooseX/Storage/Basic.pm
@@ -0,0 +1,72 @@
+
+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
diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm
index f31386c..1c66577 100644
--- a/lib/MooseX/Storage/Engine.pm
+++ b/lib/MooseX/Storage/Engine.pm
@@ -136,6 +136,86 @@ __END__
 
 =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
 
 
+
diff --git a/lib/MooseX/Storage/Engine/IO/File.pm b/lib/MooseX/Storage/Engine/IO/File.pm
index d6f9854..da5e0f4 100644
--- a/lib/MooseX/Storage/Engine/IO/File.pm
+++ b/lib/MooseX/Storage/Engine/IO/File.pm
@@ -4,9 +4,9 @@ use Moose;
 
 use IO::File;
 
-has file => (
-	isa => 'Str',
-	is  => 'ro',
+has 'file' => (
+	is       => 'ro',
+	isa      => 'Str',	
 	required => 1,
 );
 
@@ -22,4 +22,59 @@ sub store {
 	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
diff --git a/lib/MooseX/Storage/Format/JSON.pm b/lib/MooseX/Storage/Format/JSON.pm
index 9726bf7..47d59ec 100644
--- a/lib/MooseX/Storage/Format/JSON.pm
+++ b/lib/MooseX/Storage/Format/JSON.pm
@@ -23,5 +23,53 @@ __END__
 
 =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
 
+
diff --git a/lib/MooseX/Storage/IO/File.pm b/lib/MooseX/Storage/IO/File.pm
index 957419a..f8da86c 100644
--- a/lib/MooseX/Storage/IO/File.pm
+++ b/lib/MooseX/Storage/IO/File.pm
@@ -23,5 +23,53 @@ __END__
 
 =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
 
+
diff --git a/t/000_load.t b/t/000_load.t
new file mode 100644
index 0000000..3e08819
--- /dev/null
+++ b/t/000_load.t
@@ -0,0 +1,10 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+    use_ok('MooseX::Storage');
+}
\ No newline at end of file
diff --git a/t/001_basic.t b/t/001_basic.t
index e842107..2a4026c 100644
--- a/t/001_basic.t
+++ b/t/001_basic.t
@@ -5,13 +5,17 @@ use warnings;
 
 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' );
@@ -21,10 +25,7 @@ use Test::More no_plan => 1;
     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',
@@ -34,18 +35,39 @@ SKIP: {
         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' );
 
@@ -63,4 +85,3 @@ SKIP: {
     is( $foo->object->number, 2,
         '... got the right number (in the embedded object)' );
 }
-
diff --git a/t/010_basic_json.t b/t/010_basic_json.t
new file mode 100644
index 0000000..6a7d070
--- /dev/null
+++ b/t/010_basic_json.t
@@ -0,0 +1,71 @@
+#!/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)' );
+}
+
diff --git a/t/011_basic_json_io.t b/t/011_basic_json_io.t
new file mode 100644
index 0000000..130f4b7
--- /dev/null
+++ b/t/011_basic_json_io.t
@@ -0,0 +1,57 @@
+#!/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;