lib/MooseX/Storage/Engine.pm

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