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->find_type_handler($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->find_type_handler($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 ## This is all the type handler stuff, it is in a state of flux
  73 ## right now, so this may change, or it may just continue to be
  74 ## improved upon. Comments and suggestions are welcomed.
  75 ## ------------------------------------------------------------------
  76
  77 # NOTE:
  78 # these are needed by the
  79 # ArrayRef and HashRef handlers
  80 # below, so I need easy access
  81 my %OBJECT_HANDLERS = (
  82     expand => sub {
  83         my $data = shift;
  84         (exists $data->{'__class__'})
  85             || confess "Serialized item has no class marker";
  86         $data->{'__class__'}->unpack($data);
  87     },
  88     collapse => sub {
  89         my $obj = shift;
  90         ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
  91             || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
  92         $obj->pack();
  93     },
  94 );
  95
  96
  97 my %TYPES = (
  98     # These are boring ones, so they use the identity function ...
  99     'Int'      => { expand => sub { shift }, collapse => sub { shift } },
 100     'Num'      => { expand => sub { shift }, collapse => sub { shift } },
 101     'Str'      => { expand => sub { shift }, collapse => sub { shift } },
 102     # These are the trickier ones, (see notes)
 103     # NOTE:
 104     # Because we are nice guys, we will check
 105     # your ArrayRef and/or HashRef one level
 106     # down and inflate any objects we find.
 107     # But this is where it ends, it is too
 108     # expensive to try and do this any more
 109     # recursively, when it is probably not
 110     # nessecary in most of the use cases.
 111     # However, if you need more then this, subtype
 112     # and add a custom handler.
 113     'ArrayRef' => {
 114         expand => sub {
 115             my $array = shift;
 116             foreach my $i (0 .. $#{$array}) {
 117                 next unless ref($array->[$i]) eq 'HASH'
 118                          && exists $array->[$i]->{'__class__'};
 119                 $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i])
 120             }
 121             $array;
 122         },
 123         collapse => sub {
 124             my $array = shift;
 125             # NOTE:
 126             # we need to make a copy cause
 127             # otherwise it will affect the
 128             # other real version.
 129             [ map {
 130                 blessed($_)
 131                     ? $OBJECT_HANDLERS{collapse}->($_)
 132                     : $_
 133             } @$array ]
 134         }
 135     },
 136     'HashRef'  => {
 137         expand   => sub {
 138             my $hash = shift;
 139             foreach my $k (keys %$hash) {
 140                 next unless ref($hash->{$k}) eq 'HASH'
 141                          && exists $hash->{$k}->{'__class__'};
 142                 $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k})
 143             }
 144             $hash;
 145         },
 146         collapse => sub {
 147             my $hash = shift;
 148             # NOTE:
 149             # we need to make a copy cause
 150             # otherwise it will affect the
 151             # other real version.
 152             +{ map {
 153                 blessed($_)
 154                     ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}))
 155                     : ($_ => $hash->{$_})
 156             } keys %$hash }
 157         }
 158     },
 159     'Object'   => \%OBJECT_HANDLERS,
 160     # NOTE:
 161     # The sanity of enabling this feature by
 162     # default is very questionable.
 163     # - SL
 164     #'CodeRef' => {
 165     #    expand   => sub {}, # use eval ...
 166     #    collapse => sub {}, # use B::Deparse ...
 167     #}
 168 );
 169
 170 sub add_custom_type_handler {
 171     my ($class, $type_name, %handlers) = @_;
 172     (exists $handlers{expand} && exists $handlers{collapse})
 173         || confess "Custom type handlers need an expand *and* a collapse method";
 174     $TYPES{$type_name} = \%handlers;
 175 }
 176
 177 sub remove_custom_type_handler {
 178     my ($class, $type_name) = @_;
 179     delete $TYPES{$type_name} if exists $TYPES{$type_name};
 180 }
 181
 182 sub find_type_handler {
 183     my ($self, $type_constraint) = @_;
 184
 185     # this should handle most type usages
 186     # since they they are usually just
 187     # the standard set of built-ins
 188     return $TYPES{$type_constraint->name}
 189         if exists $TYPES{$type_constraint->name};
 190
 191     # the next possibility is they are
 192     # a subtype of the built-in types,
 193     # in which case this will DWIM in
 194     # most cases. It is probably not
 195     # 100% ideal though, but until I
 196     # come up with a decent test case
 197     # it will do for now.
 198     foreach my $type (keys %TYPES) {
 199         return $TYPES{$type}
 200             if $type_constraint->is_subtype_of($type);
 201     }
 202
 203     # NOTE:
 204     # the reason the above will work has to
 205     # do with the fact that custom subtypes
 206     # are mostly used for validation of
 207     # the guts of a type, and not for some
 208     # weird structural thing which would
 209     # need to be accomidated by the serializer.
 210     # Of course, mst or phaylon will probably
 211     # do something to throw this assumption
 212     # totally out the door ;)
 213     # - SL
 214
 215     # NOTE:
 216     # if this method hasnt returned by now
 217     # then we have no been able to find a
 218     # type constraint handler to match
 219     confess "Cannot handle type constraint (" . $type_constraint->name . ")";
 220 }
 221
 222 1;
 223
 224 __END__
 225
 226 =pod
 227
 228 =head1 NAME
 229
 230 MooseX::Storage::Engine
 231
 232 =head1 SYNOPSIS
 233
 234 =head1 DESCRIPTION
 235
 236 =head1 METHODS
 237
 238 =head2 Accessors
 239
 240 =over 4
 241
 242 =item B<class>
 243
 244 =item B<object>
 245
 246 =item B<storage>
 247
 248 =back
 249
 250 =head2 API
 251
 252 =over 4
 253
 254 =item B<expand_object>
 255
 256 =item B<collapse_object>
 257
 258 =back
 259
 260 =head2 ...
 261
 262 =over 4
 263
 264 =item B<collapse_attribute>
 265
 266 =item B<collapse_attribute_value>
 267
 268 =item B<expand_attribute>
 269
 270 =item B<expand_attribute_value>
 271
 272 =item B<map_attributes>
 273
 274 =back
 275
 276 =head2 Type Constraint Handlers
 277
 278 =over 4
 279
 280 =item B<find_type_handler>
 281
 282 =item B<add_custom_type_handler>
 283
 284 =item B<remove_custom_type_handler>
 285
 286 =back
 287
 288 =head2 Introspection
 289
 290 =over 4
 291
 292 =item B<meta>
 293
 294 =back
 295
 296 =head1 BUGS
 297
 298 All complex software has bugs lurking in it, and this module is no
 299 exception. If you find a bug please either email me, or add the bug
 300 to cpan-RT.
 301
 302 =head1 AUTHOR
 303
 304 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
 305
 306 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
 307
 308 =head1 COPYRIGHT AND LICENSE
 309
 310 Copyright 2007 by Infinity Interactive, Inc.
 311
 312 L<http://www.iinteractive.com>
 313
 314 This library is free software; you can redistribute it and/or modify
 315 it under the same terms as Perl itself.
 316
 317 =cut
 318
 319
 320