2 package MooseX::Storage::Engine;
11 has 'object' => (is => 'rw', isa => 'Object');
12 has 'class' => (is => 'rw', isa => 'Str');
14 ## this is the API used by other modules ...
18 $self->map_attributes('collapse_attribute');
19 $self->storage->{'__class__'} = $self->object->meta->name;
20 return $self->storage;
24 my ($self, $data) = @_;
25 $self->map_attributes('expand_attribute', $data);
26 return $self->storage;
29 ## this is the internal API ...
31 sub collapse_attribute {
32 my ($self, $attr) = @_;
33 $self->storage->{$attr->name} = $self->collapse_attribute_value($attr) || return;
36 sub expand_attribute {
37 my ($self, $attr, $data) = @_;
38 $self->storage->{$attr->name} = $self->expand_attribute_value($attr, $data->{$attr->name}) || return;
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);
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);
65 my ($self, $method_name, @args) = @_;
67 $self->$method_name($_, @args)
68 } ($self->object || $self->class)->meta->compute_all_applicable_attributes;
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 } },
80 (exists $data->{'__class__'})
81 || confess "Serialized item has no class marker";
82 $data->{'__class__'}->unpack($data);
86 ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
87 || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
92 # The sanity of enabling this feature by
93 # default is very questionable.
96 # expand => sub {}, # use eval ...
97 # collapse => sub {}, # use B::Deparse ...
102 my ($self, $type_constraint) = @_;
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};
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) {
119 if $type_constraint->is_subtype_of($type);
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 ;)
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;
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 . ")";
150 sub custom_type_match {
152 # my ($self, $type_constraint) = @_;
163 MooseX::Storage::Engine
187 =item B<expand_object>
189 =item B<collapse_object>
197 =item B<collapse_attribute>
199 =item B<collapse_attribute_value>
201 =item B<expand_attribute>
203 =item B<expand_attribute_value>
205 =item B<map_attributes>
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
227 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
229 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
231 =head1 COPYRIGHT AND LICENSE
233 Copyright 2007 by Infinity Interactive, Inc.
235 L<http://www.iinteractive.com>
237 This library is free software; you can redistribute it and/or modify
238 it under the same terms as Perl itself.