2 package MooseX::Storage::Engine;
4 use Scalar::Util qw(refaddr);
7 our $AUTHORITY = 'cpan:STEVAN';
9 # the class marker when
10 # serializing an object.
11 our $CLASS_MARKER = '__CLASS__';
21 isa => 'HashRef[Int]', # int is the refaddr
25 has 'object' => (is => 'rw', isa => 'Object', predicate => '_has_object');
26 has 'class' => (is => 'rw', isa => 'Str');
28 ## this is the API used by other modules ...
31 my ( $self, %options ) = @_;
34 # mark the root object as seen ...
35 $self->seen->{refaddr $self->object} = undef;
37 $self->map_attributes('collapse_attribute', \%options);
38 $self->storage->{$CLASS_MARKER} = $self->object->meta->identifier;
39 return $self->storage;
43 my ($self, $data, %options) = @_;
45 $options{check_version} = 1 unless exists $options{check_version};
46 $options{check_authority} = 1 unless exists $options{check_authority};
49 # mark the root object as seen ...
50 $self->seen->{refaddr $data} = undef;
52 $self->map_attributes('expand_attribute', $data, \%options);
53 return $self->storage;
56 ## this is the internal API ...
58 sub collapse_attribute {
59 my ($self, $attr, $options) = @_;
60 my $value = $self->collapse_attribute_value($attr, $options);
61 return if !defined($value);
62 $self->storage->{$attr->name} = $value;
65 sub expand_attribute {
66 my ($self, $attr, $data, $options) = @_;
67 my $value = $self->expand_attribute_value($attr, $data->{$attr->name}, $options);
68 $self->storage->{$attr->name} = defined $value ? $value : return;
71 sub collapse_attribute_value {
72 my ($self, $attr, $options) = @_;
73 # Faster, but breaks attributes without readers, do we care?
74 #my $value = $attr->get_read_method_ref->($self->object);
75 my $value = $attr->get_value($self->object);
78 # this might not be enough, we might
79 # need to make it possible for the
80 # cycle checker to return the value
81 $self->check_for_cycle_in_collapse($attr, $value)
84 if (defined $value && $attr->has_type_constraint) {
85 my $type_converter = $self->find_type_handler($attr->type_constraint, $value);
86 (defined $type_converter)
87 || confess "Cannot convert " . $attr->type_constraint->name;
88 $value = $type_converter->{collapse}->($value, $options);
93 sub expand_attribute_value {
94 my ($self, $attr, $value, $options) = @_;
97 # (see comment in method above ^^)
98 if( ref $value and not(
99 $options->{disable_cycle_check} or
100 $self->class->does('MooseX::Storage::Traits::DisableCycleDetection')
102 $self->check_for_cycle_in_collapse($attr, $value)
105 if (defined $value && $attr->has_type_constraint) {
106 my $type_converter = $self->find_type_handler($attr->type_constraint, $value);
107 $value = $type_converter->{expand}->($value, $options);
113 # possibly these two methods will
114 # be used by a cycle supporting
115 # engine. However, I am not sure
116 # if I can make a cycle one work
119 sub check_for_cycle_in_collapse {
120 my ($self, $attr, $value) = @_;
121 (!exists $self->seen->{refaddr $value})
122 || confess "Basic Engine does not support cycles in class("
123 . ($attr->associated_class->name) . ").attr("
124 . ($attr->name) . ") with $value";
125 $self->seen->{refaddr $value} = undef;
128 sub check_for_cycle_in_expansion {
129 my ($self, $attr, $value) = @_;
130 (!exists $self->seen->{refaddr $value})
131 || confess "Basic Engine does not support cycles in class("
132 . ($attr->associated_class->name) . ").attr("
133 . ($attr->name) . ") with $value";
134 $self->seen->{refaddr $value} = undef;
140 my ($self, $method_name, @args) = @_;
142 $self->$method_name($_, @args)
144 # Skip our special skip attribute :)
145 !$_->does('MooseX::Storage::Meta::Attribute::Trait::DoNotSerialize')
146 } ($self->_has_object ? $self->object : $self->class)->meta->get_all_attributes;
149 ## ------------------------------------------------------------------
150 ## This is all the type handler stuff, it is in a state of flux
151 ## right now, so this may change, or it may just continue to be
152 ## improved upon. Comments and suggestions are welcomed.
153 ## ------------------------------------------------------------------
156 # these are needed by the
157 # ArrayRef and HashRef handlers
158 # below, so I need easy access
159 my %OBJECT_HANDLERS = (
161 my ($data, $options) = @_;
162 (exists $data->{$CLASS_MARKER})
163 || confess "Serialized item has no class marker";
164 # check the class more thoroughly here ...
165 my ($class, $version, $authority) = (split '-' => $data->{$CLASS_MARKER});
166 my $meta = eval { $class->meta };
167 confess "Class ($class) is not loaded, cannot unpack" if $@;
169 if ($options->{check_version}) {
170 my $meta_version = $meta->version;
171 if (defined $meta_version && $version) {
172 if ($options->{check_version} eq 'allow_less_than') {
173 ($meta_version <= $version)
174 || confess "Class ($class) versions is not less than currently available."
175 . " got=($version) available=($meta_version)";
177 elsif ($options->{check_version} eq 'allow_greater_than') {
178 ($meta->version >= $version)
179 || confess "Class ($class) versions is not greater than currently available."
180 . " got=($version) available=($meta_version)";
183 ($meta->version == $version)
184 || confess "Class ($class) versions don't match."
185 . " got=($version) available=($meta_version)";
190 if ($options->{check_authority}) {
191 my $meta_authority = $meta->authority;
192 ($meta->authority eq $authority)
193 || confess "Class ($class) authorities don't match."
194 . " got=($authority) available=($meta_authority)"
195 if defined $meta_authority && defined $authority;
199 $class->unpack($data, %$options);
202 my ( $obj, $options ) = @_;
203 # ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
204 # || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
206 || confess "Object ($obj) does not have a &pack method, cannot collapse";
207 $obj->pack(%$options);
214 # we need to make sure that we properly numify the numbers
215 # before and after them being futzed with, because some of
216 # the JSON engines are stupid/annoying/frustrating
217 'Int' => { expand => sub { $_[0] + 0 }, collapse => sub { $_[0] + 0 } },
218 'Num' => { expand => sub { $_[0] + 0 }, collapse => sub { $_[0] + 0 } },
219 # These are boring ones, so they use the identity function ...
220 'Str' => { expand => sub { shift }, collapse => sub { shift } },
221 'Bool' => { expand => sub { shift }, collapse => sub { shift } },
222 # These are the trickier ones, (see notes)
224 # Because we are nice guys, we will check
225 # your ArrayRef and/or HashRef one level
226 # down and inflate any objects we find.
227 # But this is where it ends, it is too
228 # expensive to try and do this any more
229 # recursively, when it is probably not
230 # nessecary in most of the use cases.
231 # However, if you need more then this, subtype
232 # and add a custom handler.
235 my ( $array, @args ) = @_;
236 foreach my $i (0 .. $#{$array}) {
237 next unless ref($array->[$i]) eq 'HASH'
238 && exists $array->[$i]->{$CLASS_MARKER};
239 $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i], @args);
244 my ( $array, @args ) = @_;
246 # we need to make a copy cause
247 # otherwise it will affect the
248 # other real version.
251 ? $OBJECT_HANDLERS{collapse}->($_, @args)
258 my ( $hash, @args ) = @_;
259 foreach my $k (keys %$hash) {
260 next unless ref($hash->{$k}) eq 'HASH'
261 && exists $hash->{$k}->{$CLASS_MARKER};
262 $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}, @args);
267 my ( $hash, @args ) = @_;
269 # we need to make a copy cause
270 # otherwise it will affect the
271 # other real version.
274 ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args))
275 : ($_ => $hash->{$_})
279 'Object' => \%OBJECT_HANDLERS,
281 # The sanity of enabling this feature by
282 # default is very questionable.
285 # expand => sub {}, # use eval ...
286 # collapse => sub {}, # use B::Deparse ...
290 sub add_custom_type_handler {
291 my ($class, $type_name, %handlers) = @_;
292 (exists $handlers{expand} && exists $handlers{collapse})
293 || confess "Custom type handlers need an expand *and* a collapse method";
294 $TYPES{$type_name} = \%handlers;
297 sub remove_custom_type_handler {
298 my ($class, $type_name) = @_;
299 delete $TYPES{$type_name} if exists $TYPES{$type_name};
302 sub find_type_handler {
303 my ($self, $type_constraint, $value) = @_;
305 # check if the type is a Maybe and
306 # if its parent is not parameterized.
307 # If both is true recurse this method
308 # using ->type_parameter.
309 return $self->find_type_handler($type_constraint->type_parameter, $value)
310 if ($type_constraint->parent && $type_constraint->parent eq 'Maybe'
311 and not $type_constraint->parent->can('type_parameter'));
313 # find_type_for is a method of a union type. If we can call that method
314 # then we are dealign with a union and we need to ascertain which of
315 # the union's types we need to use for the value we are serializing.
316 if($type_constraint->can('find_type_for')) {
317 my $tc = $type_constraint->find_type_for($value);
318 return $self->find_type_handler($tc, $value) if defined($tc);
321 # this should handle most type usages
322 # since they they are usually just
323 # the standard set of built-ins
324 return $TYPES{$type_constraint->name}
325 if exists $TYPES{$type_constraint->name};
327 # the next possibility is they are
328 # a subtype of the built-in types,
329 # in which case this will DWIM in
330 # most cases. It is probably not
331 # 100% ideal though, but until I
332 # come up with a decent test case
333 # it will do for now.
334 foreach my $type (keys %TYPES) {
336 if $type_constraint->is_subtype_of($type);
340 # the reason the above will work has to
341 # do with the fact that custom subtypes
342 # are mostly used for validation of
343 # the guts of a type, and not for some
344 # weird structural thing which would
345 # need to be accomidated by the serializer.
346 # Of course, mst or phaylon will probably
347 # do something to throw this assumption
348 # totally out the door ;)
352 # if this method hasnt returned by now
353 # then we have no been able to find a
354 # type constraint handler to match
355 confess "Cannot handle type constraint (" . $type_constraint->name . ")";
358 sub find_type_handler_for {
359 my ($self, $type_handler_name) = @_;
360 $TYPES{$type_handler_name}
373 MooseX::Storage::Engine - The meta-engine to handle collapsing and expanding objects
377 There really aren't any major user serviceable parts here. However the typical
378 use case is adding new non-Moose classes to the type registry for
379 serialization. Here is an example of this for DateTime objects. This
380 assumes a C<DateTime> type has been registered.
382 MooseX::Storage::Engine->add_custom_type_handler(
384 expand => sub { DateTime->new(shift) },
385 collapse => sub { (shift)->iso8601 },
409 =item B<expand_object>
411 =item B<collapse_object>
419 =item B<collapse_attribute>
421 =item B<collapse_attribute_value>
423 =item B<expand_attribute>
425 =item B<expand_attribute_value>
427 =item B<check_for_cycle_in_collapse>
429 =item B<check_for_cycle_in_expansion>
431 =item B<map_attributes>
435 =head2 Type Constraint Handlers
439 =item B<find_type_handler ($type)>
441 =item B<find_type_handler_for ($name)>
443 =item B<add_custom_type_handler ($name, %handlers)>
445 =item B<remove_custom_type_handler ($name)>
459 All complex software has bugs lurking in it, and this module is no
460 exception. If you find a bug please either email me, or add the bug
465 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
467 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
469 =head1 COPYRIGHT AND LICENSE
471 Copyright 2007-2008 by Infinity Interactive, Inc.
473 L<http://www.iinteractive.com>
475 This library is free software; you can redistribute it and/or modify
476 it under the same terms as Perl itself.