X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FStorage%2FEngine.pm;h=ccf2fde3b76db8261256f49e0b4561d25e28e3ee;hb=e44b5f5498b782752d2c91b6796698c86143a2f0;hp=7df03a14eb45326d9a80b0cb52cd755eb8045794;hpb=5b7ea1fd5ab5a918f17cc1bc0450ddf22d7e37c6;p=gitmo%2FMooseX-Storage.git diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index 7df03a1..ccf2fde 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -3,11 +3,11 @@ package MooseX::Storage::Engine; use Moose; use Scalar::Util qw(refaddr); -our $VERSION = '0.18'; +our $VERSION = '0.32'; our $AUTHORITY = 'cpan:STEVAN'; -# the class marker when -# serializing an object. +# the class marker when +# serializing an object. our $CLASS_MARKER = '__CLASS__'; has 'storage' => ( @@ -22,7 +22,7 @@ has 'seen' => ( default => sub {{}} ); -has 'object' => (is => 'rw', isa => 'Object'); +has 'object' => (is => 'rw', isa => 'Object', predicate => '_has_object'); has 'class' => (is => 'rw', isa => 'Str'); ## this is the API used by other modules ... @@ -35,22 +35,22 @@ sub collapse_object { $self->seen->{refaddr $self->object} = undef; $self->map_attributes('collapse_attribute', \%options); - $self->storage->{$CLASS_MARKER} = $self->object->meta->identifier; + $self->storage->{$CLASS_MARKER} = $self->object->meta->identifier; return $self->storage; } 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_authority} = 1 unless exists $options{check_authority}; # NOTE: # mark the root object as seen ... - $self->seen->{refaddr $data} = undef; - + $self->seen->{refaddr $data} = undef; + $self->map_attributes('expand_attribute', $data, \%options); - return $self->storage; + return $self->storage; } ## this is the internal API ... @@ -78,16 +78,11 @@ sub collapse_attribute_value { # this might not be enough, we might # need to make it possible for the # cycle checker to return the 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) - } + $self->check_for_cycle_in_collapse($attr, $value) + if ref $value; if (defined $value && $attr->has_type_constraint) { - my $type_converter = $self->find_type_handler($attr->type_constraint); + my $type_converter = $self->find_type_handler($attr->type_constraint, $value); (defined $type_converter) || confess "Cannot convert " . $attr->type_constraint->name; $value = $type_converter->{collapse}->($value, $options); @@ -103,28 +98,28 @@ sub expand_attribute_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); + my $type_converter = $self->find_type_handler($attr->type_constraint, $value); $value = $type_converter->{expand}->($value, $options); } return $value; } # NOTE: -# possibly these two methods will -# be used by a cycle supporting -# engine. However, I am not sure -# if I can make a cycle one work +# possibly these two methods will +# be used by a cycle supporting +# engine. However, I am not sure +# if I can make a cycle one work # anyway. sub check_for_cycle_in_collapse { my ($self, $attr, $value) = @_; (!exists $self->seen->{refaddr $value}) - || confess "Basic Engine does not support cycles in class(" + || confess "Basic Engine does not support cycles in class(" . ($attr->associated_class->name) . ").attr(" . ($attr->name) . ") with $value"; $self->seen->{refaddr $value} = undef; @@ -133,7 +128,7 @@ sub check_for_cycle_in_collapse { sub check_for_cycle_in_expansion { my ($self, $attr, $value) = @_; (!exists $self->seen->{refaddr $value}) - || confess "Basic Engine does not support cycles in class(" + || confess "Basic Engine does not support cycles in class(" . ($attr->associated_class->name) . ").attr(" . ($attr->name) . ") with $value"; $self->seen->{refaddr $value} = undef; @@ -143,90 +138,63 @@ sub check_for_cycle_in_expansion { sub map_attributes { my ($self, $method_name, @args) = @_; - - # 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 ) { - + map { + $self->$method_name($_, @args) + } grep { # Skip our special skip attribute :) - 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; + !$_->does('MooseX::Storage::Meta::Attribute::Trait::DoNotSerialize') + } ($self->_has_object ? $self->object : $self->class)->meta->get_all_attributes; } ## ------------------------------------------------------------------ ## This is all the type handler stuff, it is in a state of flux -## right now, so this may change, or it may just continue to be +## right now, so this may change, or it may just continue to be ## improved upon. Comments and suggestions are welcomed. ## ------------------------------------------------------------------ # NOTE: -# these are needed by the +# these are needed by the # ArrayRef and HashRef handlers -# below, so I need easy access +# below, so I need easy access my %OBJECT_HANDLERS = ( expand => sub { - my ($data, $options) = @_; + my ($data, $options) = @_; (exists $data->{$CLASS_MARKER}) || confess "Serialized item has no class marker"; # check the class more thoroughly here ... my ($class, $version, $authority) = (split '-' => $data->{$CLASS_MARKER}); my $meta = eval { $class->meta }; - confess "Class ($class) is not loaded, cannot unpack" if $@; - + confess "Class ($class) is not loaded, cannot unpack" if $@; + if ($options->{check_version}) { my $meta_version = $meta->version; - if (defined $meta_version && $version) { + if (defined $meta_version && $version) { if ($options->{check_version} eq 'allow_less_than') { ($meta_version <= $version) - || confess "Class ($class) versions is not less than currently available." - . " got=($version) available=($meta_version)"; + || confess "Class ($class) versions is not less than currently available." + . " got=($version) available=($meta_version)"; } elsif ($options->{check_version} eq 'allow_greater_than') { ($meta->version >= $version) - || confess "Class ($class) versions is not greater than currently available." - . " got=($version) available=($meta_version)"; - } + || confess "Class ($class) versions is not greater than currently available." + . " got=($version) available=($meta_version)"; + } else { ($meta->version == $version) - || confess "Class ($class) versions don't match." + || confess "Class ($class) versions don't match." . " got=($version) available=($meta_version)"; } } } - + if ($options->{check_authority}) { my $meta_authority = $meta->authority; ($meta->authority eq $authority) - || confess "Class ($class) authorities don't match." + || confess "Class ($class) authorities don't match." . " got=($authority) available=($meta_authority)" - if defined $meta_authority && defined $authority; + if defined $meta_authority && defined $authority; } - + # all is well ... $class->unpack($data, %$options); }, @@ -243,80 +211,80 @@ my %OBJECT_HANDLERS = ( my %TYPES = ( # NOTE: - # we need to make sure that we properly numify the numbers - # before and after them being futzed with, because some of + # we need to make sure that we properly numify the numbers + # before and after them being futzed with, because some of # the JSON engines are stupid/annoying/frustrating 'Int' => { expand => sub { $_[0] + 0 }, collapse => sub { $_[0] + 0 } }, 'Num' => { expand => sub { $_[0] + 0 }, collapse => sub { $_[0] + 0 } }, - # These are boring ones, so they use the identity function ... + # These are boring ones, so they use the identity function ... 'Str' => { expand => sub { shift }, collapse => sub { shift } }, 'Bool' => { expand => sub { shift }, collapse => sub { shift } }, # These are the trickier ones, (see notes) # NOTE: - # Because we are nice guys, we will check - # your ArrayRef and/or HashRef one level - # down and inflate any objects we find. + # Because we are nice guys, we will check + # your ArrayRef and/or HashRef one level + # down and inflate any objects we find. # But this is where it ends, it is too - # expensive to try and do this any more - # recursively, when it is probably not + # expensive to try and do this any more + # recursively, when it is probably not # nessecary in most of the use cases. - # However, if you need more then this, subtype - # and add a custom handler. - 'ArrayRef' => { + # However, if you need more then this, subtype + # and add a custom handler. + 'ArrayRef' => { expand => sub { my ( $array, @args ) = @_; foreach my $i (0 .. $#{$array}) { - next unless ref($array->[$i]) eq 'HASH' + next unless ref($array->[$i]) eq 'HASH' && exists $array->[$i]->{$CLASS_MARKER}; $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i], @args); } $array; - }, + }, collapse => sub { my ( $array, @args ) = @_; - # NOTE: + # NOTE: # we need to make a copy cause - # otherwise it will affect the + # otherwise it will affect the # other real version. [ map { blessed($_) ? $OBJECT_HANDLERS{collapse}->($_, @args) : $_ - } @$array ] - } + } @$array ] + } }, - 'HashRef' => { + 'HashRef' => { expand => sub { my ( $hash, @args ) = @_; foreach my $k (keys %$hash) { - next unless ref($hash->{$k}) eq 'HASH' + next unless ref($hash->{$k}) eq 'HASH' && exists $hash->{$k}->{$CLASS_MARKER}; $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}, @args); } - $hash; - }, + $hash; + }, collapse => sub { my ( $hash, @args ) = @_; - # NOTE: + # NOTE: # we need to make a copy cause - # otherwise it will affect the + # otherwise it will affect the # other real version. +{ map { blessed($hash->{$_}) ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args)) : ($_ => $hash->{$_}) - } keys %$hash } - } + } keys %$hash } + } }, 'Object' => \%OBJECT_HANDLERS, # NOTE: - # The sanity of enabling this feature by + # The sanity of enabling this feature by # default is very questionable. # - SL #'CodeRef' => { # expand => sub {}, # use eval ... - # collapse => sub {}, # use B::Deparse ... - #} + # collapse => sub {}, # use B::Deparse ... + #} ); sub add_custom_type_handler { @@ -332,51 +300,59 @@ sub remove_custom_type_handler { } sub find_type_handler { - my ($self, $type_constraint) = @_; - + my ($self, $type_constraint, $value) = @_; + # check if the type is a Maybe and # if its parent is not parameterized. # If both is true recurse this method # using ->type_parameter. - return $self->find_type_handler($type_constraint->type_parameter) - if $type_constraint->parent eq 'Maybe' - and not $type_constraint->parent->can('type_parameter'); + return $self->find_type_handler($type_constraint->type_parameter, $value) + if ($type_constraint->parent && $type_constraint->parent eq 'Maybe' + and not $type_constraint->parent->can('type_parameter')); + + # find_type_for is a method of a union type. If we can call that method + # then we are dealign with a union and we need to ascertain which of + # the union's types we need to use for the value we are serializing. + if($type_constraint->can('find_type_for')) { + my $tc = $type_constraint->find_type_for($value); + return $self->find_type_handler($tc, $value) if defined($tc); + } # this should handle most type usages - # since they they are usually just + # since they they are usually just # the standard set of built-ins - return $TYPES{$type_constraint->name} + return $TYPES{$type_constraint->name} if exists $TYPES{$type_constraint->name}; - - # the next possibility is they are - # a subtype of the built-in types, - # in which case this will DWIM in - # most cases. It is probably not - # 100% ideal though, but until I - # come up with a decent test case + + # the next possibility is they are + # a subtype of the built-in types, + # in which case this will DWIM in + # most cases. It is probably not + # 100% ideal though, but until I + # come up with a decent test case # it will do for now. foreach my $type (keys %TYPES) { - return $TYPES{$type} + return $TYPES{$type} if $type_constraint->is_subtype_of($type); } - + # NOTE: - # the reason the above will work has to + # the reason the above will work has to # do with the fact that custom subtypes - # are mostly used for validation of + # are mostly used for validation of # the guts of a type, and not for some - # weird structural thing which would + # weird structural thing which would # need to be accomidated by the serializer. - # Of course, mst or phaylon will probably - # do something to throw this assumption + # Of course, mst or phaylon will probably + # do something to throw this assumption # totally out the door ;) # - SL - + # 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 . ")"; + # then we have no been able to find a + # type constraint handler to match + confess "Cannot handle type constraint (" . $type_constraint->name . ")"; } sub find_type_handler_for { @@ -384,6 +360,8 @@ sub find_type_handler_for { $TYPES{$type_handler_name} } +no Moose::Role; + 1; __END__ @@ -396,7 +374,17 @@ MooseX::Storage::Engine - The meta-engine to handle collapsing and expanding obj =head1 DESCRIPTION -No user serviceable parts inside. If you really want to know, read the source :) +There really aren't any major user serviceable parts here. However the typical +use case is adding new non-Moose classes to the type registry for +serialization. Here is an example of this for DateTime objects. This +assumes a C type has been registered. + + MooseX::Storage::Engine->add_custom_type_handler( + 'DateTime' => ( + expand => sub { DateTime->new(shift) }, + collapse => sub { (shift)->iso8601 }, + ) + ); =head1 METHODS @@ -468,7 +456,7 @@ No user serviceable parts inside. If you really want to know, read the source :) =head1 BUGS -All complex software has bugs lurking in it, and this module is no +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.