lib/MooseX/Storage/Engine.pm

   1
   2 package MooseX::Storage::Engine;
   3 use Moose;
   4
   5 our $VERSION = '0.01';
   6
   7 # the class marker when
   8 # serializing an object.
   9 our $CLASS_MARKER = '__CLASS__';
  10
  11 has 'storage' => (
  12     is      => 'ro',
  13     isa     => 'HashRef',
  14     default => sub {{}}
  15 );
  16
  17 has 'seen' => (
  18     is      => 'ro',
  19     isa     => 'HashRef',
  20     default => sub {{}}
  21 );
  22
  23 has 'object' => (is => 'rw', isa => 'Object');
  24 has 'class'  => (is => 'rw', isa => 'Str');
  25
  26 ## this is the API used by other modules ...
  27
  28 sub collapse_object {
  29         my $self = shift;
  30
  31         # NOTE:
  32         # mark the root object as seen ...
  33         $self->seen->{$self->object} = undef;
  34
  35     $self->map_attributes('collapse_attribute');
  36     $self->storage->{$CLASS_MARKER} = $self->object->meta->name;
  37         return $self->storage;
  38 }
  39
  40 sub expand_object {
  41     my ($self, $data) = @_;
  42
  43         # NOTE:
  44         # mark the root object as seen ...
  45         $self->seen->{$data} = undef;
  46
  47     $self->map_attributes('expand_attribute', $data);
  48         return $self->storage;
  49 }
  50
  51 ## this is the internal API ...
  52
  53 sub collapse_attribute {
  54     my ($self, $attr)  = @_;
  55     $self->storage->{$attr->name} = $self->collapse_attribute_value($attr) || return;
  56 }
  57
  58 sub expand_attribute {
  59     my ($self, $attr, $data)  = @_;
  60     $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}) || return;
  61 }
  62
  63 sub collapse_attribute_value {
  64     my ($self, $attr)  = @_;
  65         my $value = $attr->get_value($self->object);
  66
  67         # NOTE:
  68         # this might not be enough, we might
  69         # need to make it possible for the
  70         # cycle checker to return the value
  71     $self->check_for_cycle_in_collapse($value)
  72         if ref $value;
  73
  74     if (defined $value && $attr->has_type_constraint) {
  75         my $type_converter = $self->find_type_handler($attr->type_constraint);
  76         (defined $type_converter)
  77             || confess "Cannot convert " . $attr->type_constraint->name;
  78         $value = $type_converter->{collapse}->($value);
  79     }
  80         return $value;
  81 }
  82
  83 sub expand_attribute_value {
  84     my ($self, $attr, $value)  = @_;
  85
  86         # NOTE:
  87         # (see comment in method above ^^)
  88     $self->check_for_cycle_in_expansion($value)
  89         if ref $value;
  90
  91     if (defined $value && $attr->has_type_constraint) {
  92         my $type_converter = $self->find_type_handler($attr->type_constraint);
  93         $value = $type_converter->{expand}->($value);
  94     }
  95         return $value;
  96 }
  97
  98 # NOTE:
  99 # possibly these two methods will
 100 # be used by a cycle supporting
 101 # engine. However, I am not sure
 102 # if I can make a cycle one work
 103 # anyway.
 104
 105 sub check_for_cycle_in_collapse {
 106     my ($self, $value) = @_;
 107     (!exists $self->seen->{$value})
 108         || confess "Basic Engine does not support cycles";
 109     $self->seen->{$value} = undef;
 110 }
 111
 112 sub check_for_cycle_in_expansion {
 113     my ($self, $value) = @_;
 114     (!exists $self->seen->{$value})
 115         || confess "Basic Engine does not support cycles";
 116     $self->seen->{$value} = undef;
 117 }
 118
 119 # util methods ...
 120
 121 sub map_attributes {
 122     my ($self, $method_name, @args) = @_;
 123     map {
 124         $self->$method_name($_, @args)
 125     } grep {
 126         # Skip our special skip attribute :)
 127         !$_->isa('MooseX::Storage::Meta::Attribute::DoNotSerialize')
 128     } ($self->object || $self->class)->meta->compute_all_applicable_attributes;
 129 }
 130
 131 ## ------------------------------------------------------------------
 132 ## This is all the type handler stuff, it is in a state of flux
 133 ## right now, so this may change, or it may just continue to be
 134 ## improved upon. Comments and suggestions are welcomed.
 135 ## ------------------------------------------------------------------
 136
 137 # NOTE:
 138 # these are needed by the
 139 # ArrayRef and HashRef handlers
 140 # below, so I need easy access
 141 my %OBJECT_HANDLERS = (
 142     expand => sub {
 143         my $data = shift;
 144         (exists $data->{$CLASS_MARKER})
 145             || confess "Serialized item has no class marker";
 146         $data->{$CLASS_MARKER}->unpack($data);
 147     },
 148     collapse => sub {
 149         my $obj = shift;
 150         ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
 151             || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
 152         $obj->pack();
 153     },
 154 );
 155
 156
 157 my %TYPES = (
 158     # These are boring ones, so they use the identity function ...
 159     'Int'      => { expand => sub { shift }, collapse => sub { shift } },
 160     'Num'      => { expand => sub { shift }, collapse => sub { shift } },
 161     'Str'      => { expand => sub { shift }, collapse => sub { shift } },
 162     # These are the trickier ones, (see notes)
 163     # NOTE:
 164     # Because we are nice guys, we will check
 165     # your ArrayRef and/or HashRef one level
 166     # down and inflate any objects we find.
 167     # But this is where it ends, it is too
 168     # expensive to try and do this any more
 169     # recursively, when it is probably not
 170     # nessecary in most of the use cases.
 171     # However, if you need more then this, subtype
 172     # and add a custom handler.
 173     'ArrayRef' => {
 174         expand => sub {
 175             my $array = shift;
 176             foreach my $i (0 .. $#{$array}) {
 177                 next unless ref($array->[$i]) eq 'HASH'
 178                          && exists $array->[$i]->{$CLASS_MARKER};
 179                 $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i])
 180             }
 181             $array;
 182         },
 183         collapse => sub {
 184             my $array = shift;
 185             # NOTE:
 186             # we need to make a copy cause
 187             # otherwise it will affect the
 188             # other real version.
 189             [ map {
 190                 blessed($_)
 191                     ? $OBJECT_HANDLERS{collapse}->($_)
 192                     : $_
 193             } @$array ]
 194         }
 195     },
 196     'HashRef'  => {
 197         expand   => sub {
 198             my $hash = shift;
 199             foreach my $k (keys %$hash) {
 200                 next unless ref($hash->{$k}) eq 'HASH'
 201                          && exists $hash->{$k}->{$CLASS_MARKER};
 202                 $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k})
 203             }
 204             $hash;
 205         },
 206         collapse => sub {
 207             my $hash = shift;
 208             # NOTE:
 209             # we need to make a copy cause
 210             # otherwise it will affect the
 211             # other real version.
 212             +{ map {
 213                 blessed($hash->{$_})
 214                     ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}))
 215                     : ($_ => $hash->{$_})
 216             } keys %$hash }
 217         }
 218     },
 219     'Object'   => \%OBJECT_HANDLERS,
 220     # NOTE:
 221     # The sanity of enabling this feature by
 222     # default is very questionable.
 223     # - SL
 224     #'CodeRef' => {
 225     #    expand   => sub {}, # use eval ...
 226     #    collapse => sub {}, # use B::Deparse ...
 227     #}
 228 );
 229
 230 sub add_custom_type_handler {
 231     my ($class, $type_name, %handlers) = @_;
 232     (exists $handlers{expand} && exists $handlers{collapse})
 233         || confess "Custom type handlers need an expand *and* a collapse method";
 234     $TYPES{$type_name} = \%handlers;
 235 }
 236
 237 sub remove_custom_type_handler {
 238     my ($class, $type_name) = @_;
 239     delete $TYPES{$type_name} if exists $TYPES{$type_name};
 240 }
 241
 242 sub find_type_handler {
 243     my ($self, $type_constraint) = @_;
 244
 245     # this should handle most type usages
 246     # since they they are usually just
 247     # the standard set of built-ins
 248     return $TYPES{$type_constraint->name}
 249         if exists $TYPES{$type_constraint->name};
 250
 251     # the next possibility is they are
 252     # a subtype of the built-in types,
 253     # in which case this will DWIM in
 254     # most cases. It is probably not
 255     # 100% ideal though, but until I
 256     # come up with a decent test case
 257     # it will do for now.
 258     foreach my $type (keys %TYPES) {
 259         return $TYPES{$type}
 260             if $type_constraint->is_subtype_of($type);
 261     }
 262
 263     # NOTE:
 264     # the reason the above will work has to
 265     # do with the fact that custom subtypes
 266     # are mostly used for validation of
 267     # the guts of a type, and not for some
 268     # weird structural thing which would
 269     # need to be accomidated by the serializer.
 270     # Of course, mst or phaylon will probably
 271     # do something to throw this assumption
 272     # totally out the door ;)
 273     # - SL
 274
 275     # NOTE:
 276     # if this method hasnt returned by now
 277     # then we have no been able to find a
 278     # type constraint handler to match
 279     confess "Cannot handle type constraint (" . $type_constraint->name . ")";
 280 }
 281
 282 1;
 283
 284 __END__
 285
 286 =pod
 287
 288 =head1 NAME
 289
 290 MooseX::Storage::Engine
 291
 292 =head1 SYNOPSIS
 293
 294 =head1 DESCRIPTION
 295
 296 =head1 METHODS
 297
 298 =head2 Accessors
 299
 300 =over 4
 301
 302 =item B<class>
 303
 304 =item B<object>
 305
 306 =item B<storage>
 307
 308 =item B<seen>
 309
 310 =back
 311
 312 =head2 API
 313
 314 =over 4
 315
 316 =item B<expand_object>
 317
 318 =item B<collapse_object>
 319
 320 =back
 321
 322 =head2 ...
 323
 324 =over 4
 325
 326 =item B<collapse_attribute>
 327
 328 =item B<collapse_attribute_value>
 329
 330 =item B<expand_attribute>
 331
 332 =item B<expand_attribute_value>
 333
 334 =item B<check_for_cycle_in_collapse>
 335
 336 =item B<check_for_cycle_in_expansion>
 337
 338 =item B<map_attributes>
 339
 340 =back
 341
 342 =head2 Type Constraint Handlers
 343
 344 =over 4
 345
 346 =item B<find_type_handler>
 347
 348 =item B<add_custom_type_handler>
 349
 350 =item B<remove_custom_type_handler>
 351
 352 =back
 353
 354 =head2 Introspection
 355
 356 =over 4
 357
 358 =item B<meta>
 359
 360 =back
 361
 362 =head1 BUGS
 363
 364 All complex software has bugs lurking in it, and this module is no
 365 exception. If you find a bug please either email me, or add the bug
 366 to cpan-RT.
 367
 368 =head1 AUTHOR
 369
 370 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
 371
 372 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
 373
 374 =head1 COPYRIGHT AND LICENSE
 375
 376 Copyright 2007 by Infinity Interactive, Inc.
 377
 378 L<http://www.iinteractive.com>
 379
 380 This library is free software; you can redistribute it and/or modify
 381 it under the same terms as Perl itself.
 382
 383 =cut
 384
 385
 386