X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FStorage%2FEngine.pm;h=fb172e8057ddd2f48f711ea903886e63aa09692c;hb=f6e1331f9a610298585caaffe32ef3eb69768722;hp=ec96c707c7a318aa94ad37aaf8b37fcfd00f7ec9;hpb=45d9a73cb319d9cd4d3e30d07526d72cb3e11ad2;p=gitmo%2FMooseX-Storage.git diff --git a/lib/MooseX/Storage/Engine.pm b/lib/MooseX/Storage/Engine.pm index ec96c70..fb172e8 100644 --- a/lib/MooseX/Storage/Engine.pm +++ b/lib/MooseX/Storage/Engine.pm @@ -26,62 +26,65 @@ 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) = @_; + $self->storage->{$attr->name} = $self->collapse_attribute_value($attr, $options) || return; } 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) = @_; + $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}, $options) || 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($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); (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 ^^) @@ -90,7 +93,7 @@ sub expand_attribute_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; } @@ -106,7 +109,7 @@ sub check_for_cycle_in_collapse { my ($self, $attr, $value) = @_; (!exists $self->seen->{$value}) || confess "Basic Engine does not support cycles in class(" - . ($attr->associated_metaclass->name) . ").attr(" + . ($attr->associated_class->name) . ").attr(" . ($attr->name) . ") with $value"; $self->seen->{$value} = undef; } @@ -115,7 +118,7 @@ sub check_for_cycle_in_expansion { my ($self, $attr, $value) = @_; (!exists $self->seen->{$value}) || confess "Basic Engine does not support cycles in class(" - . ($attr->associated_metaclass->name) . ").attr(" + . ($attr->associated_class->name) . ").attr(" . ($attr->name) . ") with $value"; $self->seen->{$value} = undef; } @@ -144,16 +147,51 @@ 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->pack(%$options); }, ); @@ -176,46 +214,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 } }