X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FStorage%2FEngine.pm;h=999dbb90f82e3a475d96ec512b3e6c6b2692dc74;hb=04990d7a1d61ecde1238e6fd224b6b23b462d05a;hp=dd47f8cf1d5b55afd24add996595e49d2250583b;hpb=b430caa3fe1898fd40d743f5ff1347b7df9671f2;p=gitmo%2FMooseX-Storage.git diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index dd47f8c..999dbb9 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -2,7 +2,8 @@ package MooseX::Storage::Engine; use Moose; -our $VERSION = '0.01'; +our $VERSION = '0.05'; +our $AUTHORITY = 'cpan:STEVAN'; # the class marker when # serializing an object. @@ -26,71 +27,77 @@ has 'class' => (is => 'rw', isa => 'Str'); ## this is the API used by other modules ... sub collapse_object { - my $self = shift; + my ( $self, %options ) = @_; # NOTE: # mark the root object as seen ... $self->seen->{$self->object} = undef; - $self->map_attributes('collapse_attribute'); - $self->storage->{$CLASS_MARKER} = $self->object->meta->name; + $self->map_attributes('collapse_attribute', \%options); + $self->storage->{$CLASS_MARKER} = $self->object->meta->identifier; return $self->storage; } sub expand_object { - my ($self, $data) = @_; + my ($self, $data, %options) = @_; + + $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->{$data} = undef; - $self->map_attributes('expand_attribute', $data); + $self->map_attributes('expand_attribute', $data, \%options); return $self->storage; } ## this is the internal API ... sub collapse_attribute { - my ($self, $attr) = @_; - $self->storage->{$attr->name} = $self->collapse_attribute_value($attr) || return; + my ($self, $attr, $options) = @_; + my $value = $self->collapse_attribute_value($attr, $options); + return if !defined($value); + $self->storage->{$attr->name} = $value; } sub expand_attribute { - my ($self, $attr, $data) = @_; - $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}) || return; + my ($self, $attr, $data, $options) = @_; + my $value = $self->expand_attribute_value($attr, $data->{$attr->name}, $options); + $self->storage->{$attr->name} = defined $value ? $value : return; } sub collapse_attribute_value { - my ($self, $attr) = @_; + my ($self, $attr, $options) = @_; my $value = $attr->get_value($self->object); # NOTE: # 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($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); (defined $type_converter) || confess "Cannot convert " . $attr->type_constraint->name; - $value = $type_converter->{collapse}->($value); + $value = $type_converter->{collapse}->($value, $options); } return $value; } sub expand_attribute_value { - my ($self, $attr, $value) = @_; + my ($self, $attr, $value, $options) = @_; # NOTE: # (see comment in method above ^^) - $self->check_for_cycle_in_expansion($value) + $self->check_for_cycle_in_expansion($attr, $value) if ref $value; if (defined $value && $attr->has_type_constraint) { my $type_converter = $self->find_type_handler($attr->type_constraint); - $value = $type_converter->{expand}->($value); + $value = $type_converter->{expand}->($value, $options); } return $value; } @@ -103,16 +110,20 @@ sub expand_attribute_value { # anyway. sub check_for_cycle_in_collapse { - my ($self, $value) = @_; + my ($self, $attr, $value) = @_; (!exists $self->seen->{$value}) - || confess "Basic Engine does not support cycles"; + || confess "Basic Engine does not support cycles in class(" + . ($attr->associated_class->name) . ").attr(" + . ($attr->name) . ") with $value"; $self->seen->{$value} = undef; } sub check_for_cycle_in_expansion { - my ($self, $value) = @_; + my ($self, $attr, $value) = @_; (!exists $self->seen->{$value}) - || confess "Basic Engine does not support cycles"; + || confess "Basic Engine does not support cycles in class(" + . ($attr->associated_class->name) . ").attr(" + . ($attr->name) . ") with $value"; $self->seen->{$value} = undef; } @@ -124,7 +135,7 @@ sub map_attributes { $self->$method_name($_, @args) } grep { # Skip our special skip attribute :) - !$_->isa('MooseX::Storage::Meta::Attribute::DoNotSerialize') + !$_->does('MooseX::Storage::Meta::Attribute::Trait::DoNotSerialize') } ($self->object || $self->class)->meta->compute_all_applicable_attributes; } @@ -140,25 +151,67 @@ sub map_attributes { # below, so I need easy access my %OBJECT_HANDLERS = ( expand => sub { - my $data = shift; + my ($data, $options) = @_; (exists $data->{$CLASS_MARKER}) || confess "Serialized item has no class marker"; - $data->{$CLASS_MARKER}->unpack($data); + # 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 $@; + + if ($options->{check_version}) { + my $meta_version = $meta->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)"; + } + 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)"; + } + else { + ($meta->version == $version) + || 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." + . " got=($authority) available=($meta_authority)" + if defined $meta_authority && defined $authority; + } + + # all is well ... + $class->unpack($data, %$options); }, collapse => sub { - my $obj = shift; - ($obj->can('does') && $obj->does('MooseX::Storage::Basic')) - || confess "Bad object ($obj) does not do MooseX::Storage::Basic role"; - $obj->pack(); + my ( $obj, $options ) = @_; +# ($obj->can('does') && $obj->does('MooseX::Storage::Basic')) +# || confess "Bad object ($obj) does not do MooseX::Storage::Basic role"; + ($obj->can('pack')) + || confess "Object does not have a &pack method, cannot collapse"; + $obj->pack(%$options); }, ); my %TYPES = ( - # These are boring ones, so they use the identity function ... - 'Int' => { expand => sub { shift }, collapse => sub { shift } }, - 'Num' => { expand => sub { shift }, collapse => sub { shift } }, + # NOTE: + # 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 ... '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 @@ -172,46 +225,46 @@ my %TYPES = ( # and add a custom handler. 'ArrayRef' => { expand => sub { - my $array = shift; + my ( $array, @args ) = @_; foreach my $i (0 .. $#{$array}) { next unless ref($array->[$i]) eq 'HASH' && exists $array->[$i]->{$CLASS_MARKER}; - $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i]) + $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i], @args); } $array; }, - collapse => sub { - my $array = shift; + collapse => sub { + my ( $array, @args ) = @_; # NOTE: # we need to make a copy cause # otherwise it will affect the # other real version. [ map { blessed($_) - ? $OBJECT_HANDLERS{collapse}->($_) + ? $OBJECT_HANDLERS{collapse}->($_, @args) : $_ } @$array ] } }, 'HashRef' => { expand => sub { - my $hash = shift; + my ( $hash, @args ) = @_; foreach my $k (keys %$hash) { next unless ref($hash->{$k}) eq 'HASH' && exists $hash->{$k}->{$CLASS_MARKER}; - $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}) + $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}, @args); } $hash; }, collapse => sub { - my $hash = shift; + my ( $hash, @args ) = @_; # NOTE: # we need to make a copy cause # otherwise it will affect the # other real version. +{ map { blessed($hash->{$_}) - ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_})) + ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args)) : ($_ => $hash->{$_}) } keys %$hash } } @@ -287,12 +340,12 @@ __END__ =head1 NAME -MooseX::Storage::Engine - -=head1 SYNOPSIS +MooseX::Storage::Engine - The meta-engine to handle collapsing and expanding objects =head1 DESCRIPTION +No user serviceable parts inside. If you really want to know, read the source :) + =head1 METHODS =head2 Accessors @@ -373,7 +426,7 @@ Stevan Little Estevan.little@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2007 by Infinity Interactive, Inc. +Copyright 2007-2008 by Infinity Interactive, Inc. L