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     if (defined $value && $attr->has_type_constraint) {
  45         my $type_converter = $self->match_type($attr->type_constraint);
  46         (defined $type_converter)
  47             || confess "Cannot convert " . $attr->type_constraint->name;
  48         $value = $type_converter->{collapse}->($value);
  49     }
  50         return $value;
  51 }
  52
  53 sub expand_attribute_value {
  54     my ($self, $attr, $value)  = @_;
  55     if (defined $value && $attr->has_type_constraint) {
  56         my $type_converter = $self->match_type($attr->type_constraint);
  57         $value = $type_converter->{expand}->($value);
  58     }
  59         return $value;
  60 }
  61
  62 # util methods ...
  63
  64 sub map_attributes {
  65     my ($self, $method_name, @args) = @_;
  66     map {
  67         $self->$method_name($_, @args)
  68     } ($self->object || $self->class)->meta->compute_all_applicable_attributes;
  69 }
  70
  71 ## ------------------------------------------------------------------
  72 ## Everything below here might need some re-thinking ...
  73 ## ------------------------------------------------------------------
  74
  75 # NOTE:
  76 # these are needed by the
  77 # ArrayRef and HashRef handlers
  78 # below, so I need easy access
  79 my %OBJECT_HANDLERS = (
  80     expand => sub {
  81         my $data = shift;
  82         (exists $data->{'__class__'})
  83             || confess "Serialized item has no class marker";
  84         $data->{'__class__'}->unpack($data);
  85     },
  86     collapse => sub {
  87         my $obj = shift;
  88         ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
  89             || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
  90         $obj->pack();
  91     },
  92 );
  93
  94
  95 my %TYPES = (
  96     'Int'      => { expand => sub { shift }, collapse => sub { shift } },
  97     'Num'      => { expand => sub { shift }, collapse => sub { shift } },
  98     'Str'      => { expand => sub { shift }, collapse => sub { shift } },
  99     'ArrayRef' => {
 100         # FIXME:
 101         # these should also probably be
 102         # recursive as well, so they
 103         # can handle arbitrarily deep
 104         # arrays and such. Or perhaps
 105         # we force the user to handle
 106         # the types in a custom way.
 107         # This would require a more
 108         # sophisticated way of handling
 109         # this %TYPES hash.
 110         expand => sub {
 111             my $array = shift;
 112             foreach my $i (0 .. $#{$array}) {
 113                 next unless ref($array->[$i]) eq 'HASH'
 114                          && exists $array->[$i]->{'__class__'};
 115                 $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i])
 116             }
 117             $array;
 118         },
 119         collapse => sub {
 120             my $array = shift;
 121             # NOTE:
 122             # we need to make a copy cause
 123             # otherwise it will affect the
 124             # other real version.
 125             [ map {
 126                 blessed($_)
 127                     ? $OBJECT_HANDLERS{collapse}->($_)
 128                     : $_
 129             } @$array ]
 130         }
 131     },
 132     'HashRef'  => {
 133         expand   => sub { shift },
 134         collapse => sub { shift }
 135     },
 136     'Object'   => \%OBJECT_HANDLERS,
 137     # NOTE:
 138     # The sanity of enabling this feature by
 139     # default is very questionable.
 140     # - SL
 141     #'CodeRef' => {
 142     #    expand   => sub {}, # use eval ...
 143     #    collapse => sub {}, # use B::Deparse ...
 144     #}
 145 );
 146
 147 sub match_type {
 148     my ($self, $type_constraint) = @_;
 149
 150     # this should handle most type usages
 151     # since they they are usually just
 152     # the standard set of built-ins
 153     return $TYPES{$type_constraint->name}
 154         if exists $TYPES{$type_constraint->name};
 155
 156     # the next possibility is they are
 157     # a subtype of the built-in types,
 158     # in which case this will DWIM in
 159     # most cases. It is probably not
 160     # 100% ideal though, but until I
 161     # come up with a decent test case
 162     # it will do for now.
 163     foreach my $type (keys %TYPES) {
 164         return $TYPES{$type}
 165             if $type_constraint->is_subtype_of($type);
 166     }
 167
 168     # NOTE:
 169     # the reason the above will work has to
 170     # do with the fact that custom subtypes
 171     # are mostly used for validation of
 172     # the guts of a type, and not for some
 173     # weird structural thing which would
 174     # need to be accomidated by the serializer.
 175     # Of course, mst or phaylon will probably
 176     # do something to throw this assumption
 177     # totally out the door ;)
 178     # - SL
 179
 180
 181         # To cover the last possibilities we
 182         # need a way for people to extend this
 183         # process. Which they can do by subclassing
 184         # this class and overriding the method
 185         # below to handle things.
 186         my $match = $self->_custom_type_match($type_constraint);
 187         return $match if defined $match;
 188
 189     # NOTE:
 190     # if this method hasnt returned by now
 191     # then we have no been able to find a
 192     # type constraint handler to match
 193     confess "Cannot handle type constraint (" . $type_constraint->name . ")";
 194 }
 195
 196 sub _custom_type_match {
 197     return;
 198     # my ($self, $type_constraint) = @_;
 199 }
 200
 201 1;
 202
 203 __END__
 204
 205 =pod
 206
 207 =head1 NAME
 208
 209 MooseX::Storage::Engine
 210
 211 =head1 SYNOPSIS
 212
 213 =head1 DESCRIPTION
 214
 215 =head1 METHODS
 216
 217 =head2 Accessors
 218
 219 =over 4
 220
 221 =item B<class>
 222
 223 =item B<object>
 224
 225 =item B<storage>
 226
 227 =back
 228
 229 =head2 API
 230
 231 =over 4
 232
 233 =item B<expand_object>
 234
 235 =item B<collapse_object>
 236
 237 =back
 238
 239 =head2 ...
 240
 241 =over 4
 242
 243 =item B<collapse_attribute>
 244
 245 =item B<collapse_attribute_value>
 246
 247 =item B<expand_attribute>
 248
 249 =item B<expand_attribute_value>
 250
 251 =item B<map_attributes>
 252
 253 =item B<match_type>
 254
 255 =back
 256
 257 =head2 Introspection
 258
 259 =over 4
 260
 261 =item B<meta>
 262
 263 =back
 264
 265 =head1 BUGS
 266
 267 All complex software has bugs lurking in it, and this module is no
 268 exception. If you find a bug please either email me, or add the bug
 269 to cpan-RT.
 270
 271 =head1 AUTHOR
 272
 273 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
 274
 275 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
 276
 277 =head1 COPYRIGHT AND LICENSE
 278
 279 Copyright 2007 by Infinity Interactive, Inc.
 280
 281 L<http://www.iinteractive.com>
 282
 283 This library is free software; you can redistribute it and/or modify
 284 it under the same terms as Perl itself.
 285
 286 =cut
 287
 288
 289