lib/MooseX/Storage/Engine.pm

   1
   2 package MooseX::Storage::Engine;
   3 use Moose;
   4
   5 has 'storage' => (
   6     is      => 'rw',
   7     isa     => 'HashRef',
   8     default => sub {{}}
   9 );
  10
  11 has 'object' => (is => 'rw', isa => 'Object');
  12 has 'class'  => (is => 'rw', isa => 'Str');
  13
  14 ## this is the API used by other modules ...
  15
  16 sub collapse_object {
  17         my $self = shift;
  18     $self->map_attributes('collapse_attribute');
  19     $self->storage->{'__class__'} = $self->object->meta->name;
  20         return $self->storage;
  21 }
  22
  23 sub expand_object {
  24     my ($self, $data) = @_;
  25     $self->map_attributes('expand_attribute', $data);
  26         return $self->storage;
  27 }
  28
  29 ## this is the internal API ...
  30
  31 sub collapse_attribute {
  32     my ($self, $attr)  = @_;
  33     $self->storage->{$attr->name} = $self->collapse_attribute_value($attr) || return;
  34 }
  35
  36 sub expand_attribute {
  37     my ($self, $attr, $data)  = @_;
  38     $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}) || return;
  39 }
  40
  41 sub collapse_attribute_value {
  42     my ($self, $attr)  = @_;
  43         my $value = $attr->get_value($self->object);
  44         # TODO:
  45         # we want to explicitly disallow
  46         # cycles here, because the base
  47         # storage engine does not support
  48         # them
  49     if (defined $value && $attr->has_type_constraint) {
  50         my $type_converter = $self->match_type($attr->type_constraint);
  51         (defined $type_converter)
  52             || confess "Cannot convert " . $attr->type_constraint->name;
  53         $value = $type_converter->{collapse}->($value);
  54     }
  55         return $value;
  56 }
  57
  58 sub expand_attribute_value {
  59     my ($self, $attr, $value)  = @_;
  60     # TODO:
  61     # we need to check $value here to
  62     # make sure that we do not have
  63     # a cycle here.
  64     if (defined $value && $attr->has_type_constraint) {
  65         my $type_converter = $self->match_type($attr->type_constraint);
  66         $value = $type_converter->{expand}->($value);
  67     }
  68         return $value;
  69 }
  70
  71 # util methods ...
  72
  73 sub map_attributes {
  74     my ($self, $method_name, @args) = @_;
  75     map {
  76         $self->$method_name($_, @args)
  77     } ($self->object || $self->class)->meta->compute_all_applicable_attributes;
  78 }
  79
  80 my %TYPES = (
  81     'Int'      => { expand => sub { shift }, collapse => sub { shift } },
  82     'Num'      => { expand => sub { shift }, collapse => sub { shift } },
  83     'Str'      => { expand => sub { shift }, collapse => sub { shift } },
  84     'ArrayRef' => { expand => sub { shift }, collapse => sub { shift } },
  85     'HashRef'  => { expand => sub { shift }, collapse => sub { shift } },
  86     'Object'   => {
  87         expand => sub {
  88             my $data = shift;
  89             (exists $data->{'__class__'})
  90                 || confess "Serialized item has no class marker";
  91             $data->{'__class__'}->unpack($data);
  92         },
  93         collapse => sub {
  94             my $obj = shift;
  95             ($obj->can('does') && $obj->does('MooseX::Storage::Base'))
  96                 || confess "Bad object ($obj) does not do MooseX::Storage::Base role";
  97             $obj->pack();
  98         },
  99     }
 100 );
 101
 102 sub match_type {
 103     my ($self, $type_constraint) = @_;
 104     return $TYPES{$type_constraint->name} if exists $TYPES{$type_constraint->name};
 105     foreach my $type (keys %TYPES) {
 106         return $TYPES{$type}
 107             if $type_constraint->is_subtype_of($type);
 108     }
 109     # TODO:
 110     # from here we can expand this to support the following:
 111     # - if it is subtype of Ref
 112     # -- if it is a subtype of Object
 113     # --- treat it like an object
 114     # -- else
 115     # --- treat it like any other Ref
 116     # - else
 117     # -- if it is a subtype of Num or Str
 118     # --- treat it like Num or Str
 119     # -- else
 120     # --- pass it on
 121     # this should cover 80% of all use cases
 122
 123         # CHRIS: To cover the last 20% we need a way
 124         # for people to extend this process.
 125
 126     # NOTE:
 127     # if this method hasnt returned by now
 128     # then we have no been able to find a
 129     # type constraint handler to match
 130     confess "Cannot handle type constraint (" . $type_constraint->name . ")";
 131 }
 132
 133 1;
 134
 135 __END__
 136
 137 =pod
 138
 139 =cut
 140
 141