1 package MooseX::Storage::Engine;
3 use Scalar::Util qw(refaddr);
5 # the class marker when
6 # serializing an object.
7 our $CLASS_MARKER = '__CLASS__';
17 isa => 'HashRef[Int]', # int is the refaddr
21 has 'object' => (is => 'rw', isa => 'Object', predicate => '_has_object');
22 has 'class' => (is => 'rw', isa => 'Str');
24 ## this is the API used by other modules ...
27 my ( $self, %options ) = @_;
30 # mark the root object as seen ...
31 $self->seen->{refaddr $self->object} = undef;
33 $self->map_attributes('collapse_attribute', \%options);
34 $self->storage->{$CLASS_MARKER} = $self->object->meta->identifier;
35 return $self->storage;
39 my ($self, $data, %options) = @_;
41 $options{check_version} = 1 unless exists $options{check_version};
42 $options{check_authority} = 1 unless exists $options{check_authority};
45 # mark the root object as seen ...
46 $self->seen->{refaddr $data} = undef;
48 $self->map_attributes('expand_attribute', $data, \%options);
49 return $self->storage;
52 ## this is the internal API ...
54 sub collapse_attribute {
55 my ($self, $attr, $options) = @_;
56 my $value = $self->collapse_attribute_value($attr, $options);
57 return if !defined($value);
58 $self->storage->{$attr->name} = $value;
61 sub expand_attribute {
62 my ($self, $attr, $data, $options) = @_;
63 my $value = $self->expand_attribute_value($attr, $data->{$attr->name}, $options);
64 $self->storage->{$attr->name} = defined $value ? $value : return;
67 sub collapse_attribute_value {
68 my ($self, $attr, $options) = @_;
69 # Faster, but breaks attributes without readers, do we care?
70 #my $value = $attr->get_read_method_ref->($self->object);
71 my $value = $attr->get_value($self->object);
74 # this might not be enough, we might
75 # need to make it possible for the
76 # cycle checker to return the value
77 $self->check_for_cycle_in_collapse($attr, $value)
80 if (defined $value && $attr->has_type_constraint) {
81 my $type_converter = $self->find_type_handler($attr->type_constraint, $value);
82 (defined $type_converter)
83 || confess "Cannot convert " . $attr->type_constraint->name;
84 $value = $type_converter->{collapse}->($value, $options);
89 sub expand_attribute_value {
90 my ($self, $attr, $value, $options) = @_;
93 # (see comment in method above ^^)
94 if( ref $value and not(
95 $options->{disable_cycle_check} or
96 $self->class->does('MooseX::Storage::Traits::DisableCycleDetection')
98 $self->check_for_cycle_in_collapse($attr, $value)
101 if (defined $value && $attr->has_type_constraint) {
102 my $type_converter = $self->find_type_handler($attr->type_constraint, $value);
103 $value = $type_converter->{expand}->($value, $options);
109 # possibly these two methods will
110 # be used by a cycle supporting
111 # engine. However, I am not sure
112 # if I can make a cycle one work
115 sub check_for_cycle_in_collapse {
116 my ($self, $attr, $value) = @_;
117 (!exists $self->seen->{refaddr $value})
118 || confess "Basic Engine does not support cycles in class("
119 . ($attr->associated_class->name) . ").attr("
120 . ($attr->name) . ") with $value";
121 $self->seen->{refaddr $value} = undef;
124 sub check_for_cycle_in_expansion {
125 my ($self, $attr, $value) = @_;
126 (!exists $self->seen->{refaddr $value})
127 || confess "Basic Engine does not support cycles in class("
128 . ($attr->associated_class->name) . ").attr("
129 . ($attr->name) . ") with $value";
130 $self->seen->{refaddr $value} = undef;
136 my ($self, $method_name, @args) = @_;
138 $self->$method_name($_, @args)
140 # Skip our special skip attribute :)
141 !$_->does('MooseX::Storage::Meta::Attribute::Trait::DoNotSerialize')
142 } ($self->_has_object ? $self->object : $self->class)->meta->get_all_attributes;
145 ## ------------------------------------------------------------------
146 ## This is all the type handler stuff, it is in a state of flux
147 ## right now, so this may change, or it may just continue to be
148 ## improved upon. Comments and suggestions are welcomed.
149 ## ------------------------------------------------------------------
152 # these are needed by the
153 # ArrayRef and HashRef handlers
154 # below, so I need easy access
155 my %OBJECT_HANDLERS = (
157 my ($data, $options) = @_;
158 (exists $data->{$CLASS_MARKER})
159 || confess "Serialized item has no class marker";
160 # check the class more thoroughly here ...
161 my ($class, $version, $authority) = (split '-' => $data->{$CLASS_MARKER});
162 my $meta = eval { $class->meta };
163 confess "Class ($class) is not loaded, cannot unpack" if $@;
165 if ($options->{check_version}) {
166 my $meta_version = $meta->version;
167 if (defined $meta_version && $version) {
168 if ($options->{check_version} eq 'allow_less_than') {
169 ($meta_version <= $version)
170 || confess "Class ($class) versions is not less than currently available."
171 . " got=($version) available=($meta_version)";
173 elsif ($options->{check_version} eq 'allow_greater_than') {
174 ($meta->version >= $version)
175 || confess "Class ($class) versions is not greater than currently available."
176 . " got=($version) available=($meta_version)";
179 ($meta->version == $version)
180 || confess "Class ($class) versions don't match."
181 . " got=($version) available=($meta_version)";
186 if ($options->{check_authority}) {
187 my $meta_authority = $meta->authority;
188 ($meta->authority eq $authority)
189 || confess "Class ($class) authorities don't match."
190 . " got=($authority) available=($meta_authority)"
191 if defined $meta_authority && defined $authority;
195 $class->unpack($data, %$options);
198 my ( $obj, $options ) = @_;
199 # ($obj->can('does') && $obj->does('MooseX::Storage::Basic'))
200 # || confess "Bad object ($obj) does not do MooseX::Storage::Basic role";
202 || confess "Object ($obj) does not have a &pack method, cannot collapse";
203 $obj->pack(%$options);
210 # we need to make sure that we properly numify the numbers
211 # before and after them being futzed with, because some of
212 # the JSON engines are stupid/annoying/frustrating
213 'Int' => { expand => sub { $_[0] + 0 }, collapse => sub { $_[0] + 0 } },
214 'Num' => { expand => sub { $_[0] + 0 }, collapse => sub { $_[0] + 0 } },
215 # These are boring ones, so they use the identity function ...
216 'Str' => { expand => sub { shift }, collapse => sub { shift } },
217 'Bool' => { expand => sub { shift }, collapse => sub { shift } },
218 # These are the trickier ones, (see notes)
220 # Because we are nice guys, we will check
221 # your ArrayRef and/or HashRef one level
222 # down and inflate any objects we find.
223 # But this is where it ends, it is too
224 # expensive to try and do this any more
225 # recursively, when it is probably not
226 # nessecary in most of the use cases.
227 # However, if you need more then this, subtype
228 # and add a custom handler.
231 my ( $array, @args ) = @_;
232 foreach my $i (0 .. $#{$array}) {
233 next unless ref($array->[$i]) eq 'HASH'
234 && exists $array->[$i]->{$CLASS_MARKER};
235 $array->[$i] = $OBJECT_HANDLERS{expand}->($array->[$i], @args);
240 my ( $array, @args ) = @_;
242 # we need to make a copy cause
243 # otherwise it will affect the
244 # other real version.
247 ? $OBJECT_HANDLERS{collapse}->($_, @args)
254 my ( $hash, @args ) = @_;
255 foreach my $k (keys %$hash) {
256 next unless ref($hash->{$k}) eq 'HASH'
257 && exists $hash->{$k}->{$CLASS_MARKER};
258 $hash->{$k} = $OBJECT_HANDLERS{expand}->($hash->{$k}, @args);
263 my ( $hash, @args ) = @_;
265 # we need to make a copy cause
266 # otherwise it will affect the
267 # other real version.
270 ? ($_ => $OBJECT_HANDLERS{collapse}->($hash->{$_}, @args))
271 : ($_ => $hash->{$_})
275 'Object' => \%OBJECT_HANDLERS,
277 # The sanity of enabling this feature by
278 # default is very questionable.
281 # expand => sub {}, # use eval ...
282 # collapse => sub {}, # use B::Deparse ...
286 sub add_custom_type_handler {
287 my ($class, $type_name, %handlers) = @_;
288 (exists $handlers{expand} && exists $handlers{collapse})
289 || confess "Custom type handlers need an expand *and* a collapse method";
290 $TYPES{$type_name} = \%handlers;
293 sub remove_custom_type_handler {
294 my ($class, $type_name) = @_;
295 delete $TYPES{$type_name} if exists $TYPES{$type_name};
298 sub find_type_handler {
299 my ($self, $type_constraint, $value) = @_;
301 # check if the type is a Maybe and
302 # if its parent is not parameterized.
303 # If both is true recurse this method
304 # using ->type_parameter.
305 return $self->find_type_handler($type_constraint->type_parameter, $value)
306 if ($type_constraint->parent && $type_constraint->parent eq 'Maybe'
307 and not $type_constraint->parent->can('type_parameter'));
309 # find_type_for is a method of a union type. If we can call that method
310 # then we are dealign with a union and we need to ascertain which of
311 # the union's types we need to use for the value we are serializing.
312 if($type_constraint->can('find_type_for')) {
313 my $tc = $type_constraint->find_type_for($value);
314 return $self->find_type_handler($tc, $value) if defined($tc);
317 # this should handle most type usages
318 # since they they are usually just
319 # the standard set of built-ins
320 return $TYPES{$type_constraint->name}
321 if exists $TYPES{$type_constraint->name};
323 # the next possibility is they are
324 # a subtype of the built-in types,
325 # in which case this will DWIM in
326 # most cases. It is probably not
327 # 100% ideal though, but until I
328 # come up with a decent test case
329 # it will do for now.
330 foreach my $type (keys %TYPES) {
332 if $type_constraint->is_subtype_of($type);
336 # the reason the above will work has to
337 # do with the fact that custom subtypes
338 # are mostly used for validation of
339 # the guts of a type, and not for some
340 # weird structural thing which would
341 # need to be accomidated by the serializer.
342 # Of course, mst or phaylon will probably
343 # do something to throw this assumption
344 # totally out the door ;)
348 # if this method hasnt returned by now
349 # then we have no been able to find a
350 # type constraint handler to match
351 confess "Cannot handle type constraint (" . $type_constraint->name . ")";
354 sub find_type_handler_for {
355 my ($self, $type_handler_name) = @_;
356 $TYPES{$type_handler_name}
369 MooseX::Storage::Engine - The meta-engine to handle collapsing and expanding objects
373 There really aren't any major user serviceable parts here. However the typical
374 use case is adding new non-Moose classes to the type registry for
375 serialization. Here is an example of this for DateTime objects. This
376 assumes a C<DateTime> type has been registered.
378 MooseX::Storage::Engine->add_custom_type_handler(
380 expand => sub { DateTime->new(shift) },
381 collapse => sub { (shift)->iso8601 },
405 =item B<expand_object>
407 =item B<collapse_object>
415 =item B<collapse_attribute>
417 =item B<collapse_attribute_value>
419 =item B<expand_attribute>
421 =item B<expand_attribute_value>
423 =item B<check_for_cycle_in_collapse>
425 =item B<check_for_cycle_in_expansion>
427 =item B<map_attributes>
431 =head2 Type Constraint Handlers
435 =item B<find_type_handler ($type)>
437 =item B<find_type_handler_for ($name)>
439 =item B<add_custom_type_handler ($name, %handlers)>
441 =item B<remove_custom_type_handler ($name)>
455 All complex software has bugs lurking in it, and this module is no
456 exception. If you find a bug please either email me, or add the bug
461 Chris Prather E<lt>chris.prather@iinteractive.comE<gt>
463 Stevan Little E<lt>stevan.little@iinteractive.comE<gt>
465 =head1 COPYRIGHT AND LICENSE
467 Copyright 2007-2008 by Infinity Interactive, Inc.
469 L<http://www.iinteractive.com>
471 This library is free software; you can redistribute it and/or modify
472 it under the same terms as Perl itself.