From: Stevan Little Date: Thu, 29 Mar 2007 01:00:10 +0000 (+0000) Subject: now with thaw as well as freeze, see TODOs X-Git-Tag: 0_02~37 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e97396242e8acc8dff6cf3f4f5961ee1fbd8498e;p=gitmo%2FMooseX-Storage.git now with thaw as well as freeze, see TODOs --- diff --git a/Build.PL b/Build.PL index 77f2b77..4e2028d 100644 --- a/Build.PL +++ b/Build.PL @@ -3,13 +3,12 @@ use warnings; use Module::Build; my $builder = Module::Build->new( - module_name => 'MooseX::Storage::JSON', + module_name => 'MooseX::Storage', license => 'perl', dist_author => 'Chris Prather ', - dist_version_from => 'lib/MooseX/Storage/JSON.pm', + dist_version_from => 'lib/MooseX/Storage.pm', requires => { 'Test::More' => 0, - 'version' => 0, }, add_to_cleanup => [ 'MooseX-Storage-JSON-*' ], ); diff --git a/Changes b/Changes index 142479a..02529ed 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,5 @@ -Revision history for MooseX-Storage-JSON +Revision history for MooseX-Storage -0.0.1 Tue Mar 27 16:37:53 2007 - Initial release. +0.01 + Initial release. diff --git a/Makefile.PL b/Makefile.PL index 73561c5..dd4ef63 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,14 +3,13 @@ use warnings; use ExtUtils::MakeMaker; WriteMakefile( - NAME => 'MooseX::Storage::JSON', + NAME => 'MooseX::Storage', AUTHOR => 'Chris Prather ', - VERSION_FROM => 'lib/MooseX/Storage/JSON.pm', - ABSTRACT_FROM => 'lib/MooseX/Storage/JSON.pm', + VERSION_FROM => 'lib/MooseX/Storage.pm', + ABSTRACT_FROM => 'lib/MooseX/Storage.pm', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, - 'version' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'MooseX-Storage-JSON-*' }, diff --git a/README b/README index 4490990..bab99a8 100644 --- a/README +++ b/README @@ -1,19 +1,4 @@ -MooseX-Storage-JSON version 0.0.1 - -[ REPLACE THIS... - - The README is used to introduce the module and provide instructions on - how to install the module, any machine dependencies it may have (for - example C compilers and installed libraries) and any other information - that should be understood before the module is installed. - - A README file is required for CPAN modules since CPAN extracts the - README file from a module distribution so that people browsing the - archive can use it get an idea of the modules uses. It is usually a - good idea to provide version information here so that people can - decide whether fixes for the module are worth downloading. -] - +MooseX-Storage version 0.01 INSTALLATION @@ -24,7 +9,6 @@ To install this module, run the following commands: make test make install - Alternatively, to install with Module::Build, you can use the following commands: perl Build.PL @@ -32,16 +16,13 @@ Alternatively, to install with Module::Build, you can use the following commands ./Build test ./Build install - - DEPENDENCIES -None. - +Moose!!!!!!! COPYRIGHT AND LICENCE -Copyright (C) 2007, Chris Prather +Copyright (C) 2007, Infinity Interactive This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. diff --git a/lib/MooseX/Storage.pm b/lib/MooseX/Storage.pm index 7078721..e3e2c3e 100644 --- a/lib/MooseX/Storage.pm +++ b/lib/MooseX/Storage.pm @@ -1,24 +1,32 @@ - package MooseX::Storage; sub import { my $pkg = caller(); $pkg->meta->alias_method('Storage' => sub { - my $engine = shift; - return 'MooseX::Storage::' . $engine; + my $engine_name = 'MooseX::Storage::' . (shift); + Class::MOP::load_class($engine_name) + || die "Could not load engine ($engine_name) for package ($pkg)"; + return $engine_name; }); } package MooseX::Storage::Base; use Moose::Role; -requires 'load'; -requires 'store'; +requires 'pack'; +requires 'unpack'; requires 'freeze'; requires 'thaw'; +requires 'load'; +requires 'store'; + 1; -__END__ \ No newline at end of file +__END__ + +=pod + +=cut diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index 6492260..d496fd1 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -3,59 +3,100 @@ package MooseX::Storage::Engine; use Moose; has 'storage' => ( - is => 'rw', - isa => 'HashRef', + is => 'rw', + isa => 'HashRef', default => sub {{}} ); -has 'object' => ( - is => 'rw', - isa => 'Object', -); +has 'object' => (is => 'rw', isa => 'Object'); +has 'class' => (is => 'rw', isa => 'Str'); -sub BUILD { - (shift)->collapse_object; -} +## this is the API used by other modules ... sub collapse_object { my $self = shift; - $self->process_attributes; + $self->map_attributes('collapse_attribute'); + $self->storage->{'__class__'} = $self->object->meta->name; return $self->storage; } -sub extract_attributes { - my $self = shift; - return $self->object->meta->compute_all_applicable_attributes; +sub expand_object { + my ($self, $data) = @_; + $self->map_attributes('expand_attribute', $data); + return $self->storage; } -sub process_attributes { - my $self = shift; - foreach my $attr ($self->extract_attributes) { - next if $attr->name eq '_storage'; - $self->process_attribute($attr); - } +## this is the internal API ... + +sub collapse_attribute { + my ($self, $attr) = @_; + $self->storage->{$attr->name} = $self->collapse_attribute_value($attr) || return; +} + +sub expand_attribute { + my ($self, $attr, $data) = @_; + $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}) || return; } -sub process_attribute { +sub collapse_attribute_value { my ($self, $attr) = @_; - $self->storage->{$attr->name} = $self->collapse_attribute($attr); + my $value = $attr->get_value($self->object); + # TODO: + # we want to explicitly disallow + # cycles here, because the base + # storage engine does not support + # them + if (defined $value && $attr->has_type_constraint) { + my $type_converter = $self->match_type($attr->type_constraint); + (defined $type_converter) + || confess "Cannot convert " . $attr->type_constraint->name; + $value = $type_converter->{collapse}->($value); + } + return $value; +} + +sub expand_attribute_value { + my ($self, $attr, $value) = @_; + # TODO: + # we need to check $value here to + # make sure that we do not have + # a cycle here. + if (defined $value && $attr->has_type_constraint) { + my $type_converter = $self->match_type($attr->type_constraint); + $value = $type_converter->{expand}->($value); + } + return $value; +} + +# util methods ... + +sub map_attributes { + my ($self, $method_name, @args) = @_; + map { + $self->$method_name($_, @args) + } ($self->object || $self->class)->meta->compute_all_applicable_attributes; } my %TYPES = ( - 'Int' => sub { shift }, - 'Num' => sub { shift }, - 'Str' => sub { shift }, - 'ArrayRef' => sub { shift }, - 'HashRef' => sub { shift }, - 'GlobRef' => sub { confess "FOO" }, - 'CodeRef' => sub { confess "This should use B::Deparse" }, - 'Object' => sub { - my $obj = shift; - $obj || confess("Object Not Defined"); - ($obj->does('MooseX::Storage::Base')) - || confess "Bad object"; - $obj->pack(); - } + 'Int' => { expand => sub { shift }, collapse => sub { shift } }, + 'Num' => { expand => sub { shift }, collapse => sub { shift } }, + 'Str' => { expand => sub { shift }, collapse => sub { shift } }, + 'ArrayRef' => { expand => sub { shift }, collapse => sub { shift } }, + 'HashRef' => { expand => sub { shift }, collapse => sub { shift } }, + 'Object' => { + expand => sub { + my $data = shift; + (exists $data->{'__class__'}) + || confess "Serialized item has no class marker"; + $data->{'__class__'}->unpack($data); + }, + collapse => sub { + my $obj = shift; + ($obj->can('does') && $obj->does('MooseX::Storage::Base')) + || confess "Bad object ($obj) does not do MooseX::Storage::Base role"; + $obj->pack(); + }, + } ); sub match_type { @@ -65,19 +106,33 @@ sub match_type { return $TYPES{$type} if $type_constraint->is_subtype_of($type); } -} + # TODO: + # from here we can expand this to support the following: + # - if it is subtype of Ref + # -- if it is a subtype of Object + # --- treat it like an object + # -- else + # --- treat it like any other Ref + # - else + # -- if it is a subtype of Num or Str + # --- treat it like Num or Str + # -- else + # --- pass it on + # this should cover 80% of all use cases -sub collapse_attribute { - my ($self, $attr) = @_; - my $value = $attr->get_value($self->object); - if (defined $value && $attr->has_type_constraint) { - my $type_converter = $self->match_type($attr->type_constraint); - (defined $type_converter) - || confess "Cannot convert " . $attr->type_constraint->name; - $value = $type_converter->($value); - } - return $value; + # NOTE: + # if this method hasnt returned by now + # then we have no been able to find a + # type constraint handler to match + confess "Cannot handle type constraint (" . $type_constraint->name . ")"; } 1; -__END__ \ No newline at end of file + +__END__ + +=pod + +=cut + + diff --git a/lib/MooseX/Storage/JSON.pm b/lib/MooseX/Storage/JSON.pm index 26ac774..7787bdc 100644 --- a/lib/MooseX/Storage/JSON.pm +++ b/lib/MooseX/Storage/JSON.pm @@ -4,32 +4,46 @@ use Moose::Role; with 'MooseX::Storage::Base'; -use JSON::Syck; +use JSON::Syck (); use MooseX::Storage::Engine; -has '_storage' => ( - is => 'ro', - isa => 'MooseX::Storage::Engine', - default => sub { - my $self = shift; - warn "Building Storage Engine\n"; - MooseX::Storage::Engine->new(object => $self); - }, - handles => { - 'pack' => 'collapse_object', - # unpack here ... - } -); - -sub load {} -sub store {} -sub thaw {} +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)); +} + +sub load { + my ($class, $filename) = @_; + $class->unpack(JSON::Syck::LoadFile($filename)); +} + +sub store { + my ($self, $filename) = @_; + JSON::Syck::DumpFile($filename, $self->pack()); +} + +sub thaw { + my ($class, $json) = @_; + $class->unpack(JSON::Syck::Load($json)); +} sub freeze { my $self = shift; - JSON::Syck::Dump($self->pack()); + JSON::Syck::Dump($self->pack()); } - 1; -__END__ \ No newline at end of file + +__END__ + +=pod + +=cut + diff --git a/t/00.load.t b/t/00.load.t deleted file mode 100644 index fee8329..0000000 --- a/t/00.load.t +++ /dev/null @@ -1,7 +0,0 @@ -use Test::More tests => 1; - -BEGIN { -use_ok( 'MooseX::Storage::JSON' ); -} - -diag( "Testing MooseX::Storage::JSON $MooseX::Storage::JSON::VERSION" ); diff --git a/t/001_basic.t b/t/001_basic.t index 548dacc..6ffbeac 100644 --- a/t/001_basic.t +++ b/t/001_basic.t @@ -14,8 +14,9 @@ use Test::More no_plan => 1; 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 'float' => (is => 'ro', isa => 'Num'); + has 'array' => (is => 'ro', isa => 'ArrayRef'); + has 'hash' => (is => 'ro', isa => 'HashRef'); has 'object' => (is => 'ro', isa => 'Object'); } @@ -23,9 +24,24 @@ my $foo = Foo->new( number => 10, string => 'foo', float => 10.5, - array => [ 1 .. 10 ], + array => [ 1 .. 10 ], + hash => { map { $_ => undef } (1 .. 10) }, object => Foo->new( number => 2 ), ); -diag $foo->freeze; +is($foo->freeze, +'{"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 $foo2 = 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($foo2, 'Foo'); + +is($foo2->number, 10, '... got the right number'); +is($foo2->string, 'foo', '... got the right string'); +is($foo2->float, 10.5, '... got the right float'); +is_deeply($foo2->array, [ 1 .. 10], '... got the right array'); +is_deeply($foo2->hash, { map { $_ => undef } (1 .. 10) }, '... got the right hash'); + +isa_ok($foo2->object, 'Foo'); +is($foo2->object->number, 2, '... got the right number (in the embedded object)'); diff --git a/t/perlcritic.t b/t/perlcritic.t deleted file mode 100644 index 7e7b210..0000000 --- a/t/perlcritic.t +++ /dev/null @@ -1,9 +0,0 @@ -#!perl - -if (!require Test::Perl::Critic) { - Test::More::plan( - skip_all => "Test::Perl::Critic required for testing PBP compliance" - ); -} - -Test::Perl::Critic::all_critic_ok();