Skip Menu |
 

This queue is for tickets about the MooseX-Storage CPAN distribution.

Report information
The Basics
Id: 81236
Status: resolved
Priority: 0/
Queue: MooseX-Storage

People
Owner: Nobody in particular
Requestors: dim0xff [...] gmail.com
Cc:
AdminCc:

Bug Information
Severity: Important
Broken in: 0.31
Fixed in: 0.49



Subject: Wrong 'pack' with deep nested objects
Download (untitled) / with headers
text/plain 782b
Hello! Problem is that HASH and ARRAY actually can be a deeply nested structures, and MooseX::Storage::Engine collapses object just up to the second level (not deeper) Example. StorableClass - class, which use MooseX::Storage and with Storage (so can('pack') for StorableClass instances is true). f1 - rw field in StorableClass. ... my $obj = StorableClass->new( f1 => { key1 => [ StorableClass->new(f1 => 'value'), ... ], ... } ); my $hashref = $obj->pack; ... So $hashref has blessed value, instead of "plain" collapsed hash. Of course it can be resolved by adding custom type handler for ArrayRef and HashRef, but it is better to have it "from the box". I attached patch which fix it (also it includes simple test).
Subject: nested.patch
Download nested.patch
text/x-diff 6.3k
diff -rupN MooseX-Storage-0.31/lib/MooseX/Storage/Engine.pm MooseX-Storage-dim0xff/lib/MooseX/Storage/Engine.pm --- MooseX-Storage-0.31/lib/MooseX/Storage/Engine.pm 2012-02-29 03:22:46.000000000 +0400 +++ MooseX-Storage-dim0xff/lib/MooseX/Storage/Engine.pm 2012-11-16 14:50:31.000000000 +0400 @@ -83,6 +83,7 @@ sub collapse_attribute_value { if (defined $value && $attr->has_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); @@ -208,8 +209,8 @@ my %OBJECT_HANDLERS = ( }, ); - -my %TYPES = ( +my %TYPES; +%TYPES = ( # NOTE: # we need to make sure that we properly numify the numbers # before and after them being futzed with, because some of @@ -234,9 +235,17 @@ my %TYPES = ( expand => sub { 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], @args); + if (ref($array->[$i]) eq 'HASH') { + if (exists $array->[$i]->{$CLASS_MARKER}) { + $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i], @args); + } + else { + $array->[$i] = $TYPES{HASH}->{expand}->($array->[$i], @args) + } + } + elsif (ref($array->[$i]) eq 'ARRAY') { + $array->[$i] = $TYPES{ARRAY}->{expand}->($array->[$i], @args) + } } $array; }, @@ -249,7 +258,9 @@ my %TYPES = ( [ map { blessed($_) ? $OBJECT_HANDLERS{collapse}->($_, @args) - : $_ + : $TYPES{ ref($_) } + ? $TYPES{ ref($_) }->{collapse}->($_, @args) + : $_ } @$array ] } }, @@ -257,11 +268,19 @@ my %TYPES = ( expand => sub { 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}, @args); + if (ref($hash->{$k}) eq 'HASH') { + if (exists $hash->{$k}->{$CLASS_MARKER}) { + $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}, @args); + } + else { + $hash->{$k} = $TYPES{HASH}->{expand}->($hash->{$k}, @args) + } + } + elsif (ref($hash->{$k}) eq 'ARRAY') { + $hash->{$k} = $TYPES{ARRAY}->{expand}->($hash->{$k}, @args) + } } - $hash; + $hash; }, collapse => sub { my ( $hash, @args ) = @_; @@ -272,7 +291,10 @@ my %TYPES = ( +{ map { blessed($hash->{$_}) ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args)) - : ($_ => $hash->{$_}) + : $TYPES{ ref( $hash->{$_} ) } + ? ($_ => $TYPES{ ref( $hash->{$_} ) }->{collapse}->($hash->{$_}, @args)) + : ($_ => $hash->{$_}) + } keys %$hash } } }, @@ -287,6 +309,12 @@ my %TYPES = ( #} ); +%TYPES = ( + %TYPES, + 'HASH' => $TYPES{HashRef}, + 'ARRAY' => $TYPES{ArrayRef}, +); + sub add_custom_type_handler { my ($class, $type_name, %handlers) = @_; (exists $handlers{expand} && exists $handlers{collapse}) @@ -323,7 +351,7 @@ sub find_type_handler { # the standard set of built-ins 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 diff -rupN MooseX-Storage-0.31/t/003_basic_deep_nested.t MooseX-Storage-dim0xff/t/003_basic_deep_nested.t --- MooseX-Storage-0.31/t/003_basic_deep_nested.t 1970-01-01 03:00:00.000000000 +0300 +++ MooseX-Storage-dim0xff/t/003_basic_deep_nested.t 2012-11-16 14:55:57.616757432 +0400 @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Scalar::Util qw(blessed); +use Test::Exception; + +use lib qw(lib); + +package StorableClass; + +use Moose; +use MooseX::Storage; +use MooseX::Types::Moose qw/ArrayRef HashRef/; + +use Carp; + +use namespace::autoclean; + +with( Storage, ); + +has id => ( + is => 'rw', + default => sub { + int( rand(9999) ) . time; + }, +); + +has hh => ( + is => 'rw', + isa => HashRef, +); + +package main; + + +my $obj = StorableClass->new( + hh => { + h => { map { $_->id => $_ } @{ get_storables() } }, + hh => { + h => { map { $_->id => $_ } @{ get_storables() } }, + hh => { + h => { map { $_->id => $_ } @{ get_storables() } }, + hh => { + h => { map { $_->id => $_ } @{ get_storables() } }, + hh => {}, + a => get_storables(), + aa => [ map { [$_] } @{ get_storables() } ], + }, + a => get_storables(), + aa => [ map { [$_] } @{ get_storables() } ], + }, + a => get_storables(), + aa => [ map { [$_] } @{ get_storables() } ], + }, + a => get_storables(), + aa => [ map { [$_] } @{ get_storables() } ], + }, +); + +is( blessed( $obj->pack->{hh}->{hh}->{hh}->{hh}->{a}->[0] ), + undef, 'Storage::Engine => the deepest element is not blessed' ); + +my $unpacked_obj = StorableClass->unpack($obj->pack); + +is_deeply( $obj, $unpacked_obj, 'Storage::Engine => obj == unpacked_obj' ); +is_deeply( $obj->pack, $unpacked_obj->pack, + 'Storage::Engine => packed obj == packed unpacked_obj' ); + +done_testing(); + +sub get_storables { + return [ + map { + StorableClass->new( + hh => { map { 'field_' . $_ => $_ } ( 0 .. ( rand(10) + 1 ) ) } ), + } ( 0 .. ( rand(5) + 1 ) ) + ]; +}
thanks, PR#7 is merged, and is released in 0.49!


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.