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