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 my %TYPES = (
  72     'Int'      => { expand => sub { shift }, collapse => sub { shift } },
  73     'Num'      => { expand => sub { shift }, collapse => sub { shift } },
  74     'Str'      => { expand => sub { shift }, collapse => sub { shift } },
  75     'ArrayRef' => { expand => sub { shift }, collapse => sub { shift } },
  76     'HashRef'  => { expand => sub { shift }, collapse => sub { shift } },
  77     'Object'   => {
  78         expand => sub {
  79             my $data = shift;
  80             (exists $data->{'__class__'})
  81                 || confess "Serialized item has no class marker";
  82             $data->{'__class__'}->unpack($data);
  83         },
  84         collapse => sub {
  85             my $obj = shift;
  86             ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
  87                 || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
  88             $obj->pack();
  89         },
  90     },
  91     # NOTE:
  92     # The sanity of enabling this feature by
  93     # default is very questionable.
  94     # - SL
  95     #'CodeRef' => {
  96     #    expand   => sub {}, # use eval ...
  97     #    collapse => sub {}, # use B::Deparse ...
  98     #}
  99 );
 100
 101 sub match_type {
 102     my ($self, $type_constraint) = @_;
 103
 104     # this should handle most type usages
 105     # since they they are usually just
 106     # the standard set of built-ins
 107     return $TYPES{$type_constraint->name}
 108         if exists $TYPES{$type_constraint->name};
 109
 110     # the next possibility is they are
 111     # a subtype of the built-in types,
 112     # in which case this will DWIM in
 113     # most cases. It is probably not
 114     # 100% ideal though, but until I
 115     # come up with a decent test case
 116     # it will do for now.
 117     foreach my $type (keys %TYPES) {
 118         return $TYPES{$type}
 119             if $type_constraint->is_subtype_of($type);
 120     }
 121
 122     # NOTE:
 123     # the reason the above will work has to
 124     # do with the fact that custom subtypes
 125     # are mostly used for validation of
 126     # the guts of a type, and not for some
 127     # weird structural thing which would
 128     # need to be accomidated by the serializer.
 129     # Of course, mst or phaylon will probably
 130     # do something to throw this assumption
 131     # totally out the door ;)
 132     # - SL
 133
 134
 135         # To cover the last possibilities we
 136         # need a way for people to extend this
 137         # process. Which they can do by subclassing
 138         # this class and overriding the method
 139         # below to handle things.
 140         my $match = $self->custom_type_match($type_constraint);
 141         return $match if defined $match;
 142
 143     # NOTE:
 144     # if this method hasnt returned by now
 145     # then we have no been able to find a
 146     # type constraint handler to match
 147     confess "Cannot handle type constraint (" . $type_constraint->name . ")";
 148 }
 149
 150 sub custom_type_match {
 151     return;
 152     # my ($self, $type_constraint) = @_;
 153 }
 154
 155 1;
 156
 157 __END__
 158
 159 =pod
 160
 161 =head1 NAME
 162
 163 MooseX::Storage::Engine
 164
 165 =head1 SYNOPSIS
 166
 167 =head1 DESCRIPTION
 168
 169 =head1 METHODS
 170
 171 =head2 Accessors
 172
 173 =over 4
 174
 175 =item B<class>
 176
 177 =item B<object>
 178
 179 =item B<storage>
 180
 181 =back
 182
 183 =head2 API
 184
 185 =over 4
 186
 187 =item B<expand_object>
 188
 189 =item B<collapse_object>
 190
 191 =back
 192
 193 =head2 ...
 194
 195 =over 4
 196
 197 =item B<collapse_attribute>
 198
 199 =item B<collapse_attribute_value>
 200
 201 =item B<expand_attribute>
 202
 203 =item B<expand_attribute_value>
 204
 205 =item B<map_attributes>
 206
 207 =item B<match_type>
 208
 209 =back
 210
 211 =head2 Introspection
 212
 213 =over 4
 214
 215 =item B<meta>
 216
 217 =back
 218
 219 =head1 BUGS
 220
 221 All complex software has bugs lurking in it, and this module is no
 222 exception. If you find a bug please either email me, or add the bug
 223 to cpan-RT.
 224
 225 =head1 AUTHOR
 226
 227 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
 228
 229 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
 230
 231 =head1 COPYRIGHT AND LICENSE
 232
 233 Copyright 2007 by Infinity Interactive, Inc.
 234
 235 L<http://www.iinteractive.com>
 236
 237 This library is free software; you can redistribute it and/or modify
 238 it under the same terms as Perl itself.
 239
 240 =cut
 241
 242
 243