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;
71 ## ------------------------------------------------------------------
72 ## Everything below here might need some re-thinking ...
73 ## ------------------------------------------------------------------
76 # these are needed by the
77 # ArrayRef and HashRef handlers
78 # below, so I need easy access
79 my %OBJECT_HANDLERS = (
82 (exists $data->{'__class__'})
83 || confess "Serialized item has no class marker";
84 $data->{'__class__'}->unpack($data);
88 ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
89 || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
96 'Int' => { expand => sub { shift }, collapse => sub { shift } },
97 'Num' => { expand => sub { shift }, collapse => sub { shift } },
98 'Str' => { expand => sub { shift }, collapse => sub { shift } },
101 # these should also probably be
102 # recursive as well, so they
103 # can handle arbitrarily deep
104 # arrays and such. Or perhaps
105 # we force the user to handle
106 # the types in a custom way.
107 # This would require a more
108 # sophisticated way of handling
112 foreach my $i (0 .. $#{$array}) {
113 next unless ref($array->[$i]) eq 'HASH'
114 && exists $array->[$i]->{'__class__'};
115 $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i])
122 # we need to make a copy cause
123 # otherwise it will affect the
124 # other real version.
127 ? $OBJECT_HANDLERS{collapse}->($_)
133 expand => sub { shift },
134 collapse => sub { shift }
136 'Object' => \%OBJECT_HANDLERS,
138 # The sanity of enabling this feature by
139 # default is very questionable.
142 # expand => sub {}, # use eval ...
143 # collapse => sub {}, # use B::Deparse ...
148 my ($self, $type_constraint) = @_;
150 # this should handle most type usages
151 # since they they are usually just
152 # the standard set of built-ins
153 return $TYPES{$type_constraint->name}
154 if exists $TYPES{$type_constraint->name};
156 # the next possibility is they are
157 # a subtype of the built-in types,
158 # in which case this will DWIM in
159 # most cases. It is probably not
160 # 100% ideal though, but until I
161 # come up with a decent test case
162 # it will do for now.
163 foreach my $type (keys %TYPES) {
165 if $type_constraint->is_subtype_of($type);
169 # the reason the above will work has to
170 # do with the fact that custom subtypes
171 # are mostly used for validation of
172 # the guts of a type, and not for some
173 # weird structural thing which would
174 # need to be accomidated by the serializer.
175 # Of course, mst or phaylon will probably
176 # do something to throw this assumption
177 # totally out the door ;)
181 # To cover the last possibilities we
182 # need a way for people to extend this
183 # process. Which they can do by subclassing
184 # this class and overriding the method
185 # below to handle things.
186 my $match = $self->_custom_type_match($type_constraint);
187 return $match if defined $match;
190 # if this method hasnt returned by now
191 # then we have no been able to find a
192 # type constraint handler to match
193 confess "Cannot handle type constraint (" . $type_constraint->name . ")";
196 sub _custom_type_match {
198 # my ($self, $type_constraint) = @_;
209 MooseX::Storage::Engine
233 =item B<expand_object>
235 =item B<collapse_object>
243 =item B<collapse_attribute>
245 =item B<collapse_attribute_value>
247 =item B<expand_attribute>
249 =item B<expand_attribute_value>
251 =item B<map_attributes>
267 All complex software has bugs lurking in it, and this module is no
268 exception. If you find a bug please either email me, or add the bug
273 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
275 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
277 =head1 COPYRIGHT AND LICENSE
279 Copyright 2007 by Infinity Interactive, Inc.
281 L<http://www.iinteractive.com>
283 This library is free software; you can redistribute it and/or modify
284 it under the same terms as Perl itself.