Commit | Line | Data |
e59193fb |
1 | |
2 | package MooseX::Storage::Engine; |
3 | use Moose; |
4 | |
5 | has 'storage' => ( |
e9739624 |
6 | is => 'rw', |
7 | isa => 'HashRef', |
e59193fb |
8 | default => sub {{}} |
9 | ); |
10 | |
e9739624 |
11 | has 'object' => (is => 'rw', isa => 'Object'); |
12 | has 'class' => (is => 'rw', isa => 'Str'); |
e59193fb |
13 | |
e9739624 |
14 | ## this is the API used by other modules ... |
e59193fb |
15 | |
16 | sub collapse_object { |
17 | my $self = shift; |
e9739624 |
18 | $self->map_attributes('collapse_attribute'); |
19 | $self->storage->{'__class__'} = $self->object->meta->name; |
e59193fb |
20 | return $self->storage; |
21 | } |
22 | |
e9739624 |
23 | sub expand_object { |
24 | my ($self, $data) = @_; |
25 | $self->map_attributes('expand_attribute', $data); |
26 | return $self->storage; |
e59193fb |
27 | } |
28 | |
e9739624 |
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; |
e59193fb |
39 | } |
40 | |
e9739624 |
41 | sub collapse_attribute_value { |
e59193fb |
42 | my ($self, $attr) = @_; |
e9739624 |
43 | my $value = $attr->get_value($self->object); |
e9739624 |
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) = @_; |
e9739624 |
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; |
e59193fb |
69 | } |
70 | |
913d96dd |
71 | ## ------------------------------------------------------------------ |
72 | ## Everything below here might need some re-thinking ... |
73 | ## ------------------------------------------------------------------ |
74 | |
75 | # NOTE: |
76 | # these are needed by the |
77 | # ArrayRef and HashRef handlers |
78 | # below, so I need easy access |
79 | my %OBJECT_HANDLERS = ( |
80 | expand => sub { |
81 | my $data = shift; |
82 | (exists $data->{'__class__'}) |
83 | || confess "Serialized item has no class marker"; |
84 | $data->{'__class__'}->unpack($data); |
85 | }, |
86 | collapse => sub { |
87 | my $obj = shift; |
88 | ($obj->can('does') && $obj->does('MooseX::Storage::Basic')) |
89 | || confess "Bad object ($obj) does not do MooseX::Storage::Basic role"; |
90 | $obj->pack(); |
91 | }, |
92 | ); |
93 | |
94 | |
e59193fb |
95 | my %TYPES = ( |
e9739624 |
96 | 'Int' => { expand => sub { shift }, collapse => sub { shift } }, |
97 | 'Num' => { expand => sub { shift }, collapse => sub { shift } }, |
98 | 'Str' => { expand => sub { shift }, collapse => sub { shift } }, |
913d96dd |
99 | 'ArrayRef' => { |
100 | # FIXME: |
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 |
109 | # this %TYPES hash. |
e9739624 |
110 | expand => sub { |
913d96dd |
111 | my $array = shift; |
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]) |
116 | } |
117 | $array; |
118 | }, |
119 | collapse => sub { |
120 | my $array = shift; |
121 | # NOTE: |
122 | # we need to make a copy cause |
123 | # otherwise it will affect the |
124 | # other real version. |
125 | [ map { |
126 | blessed($_) |
127 | ? $OBJECT_HANDLERS{collapse}->($_) |
128 | : $_ |
129 | } @$array ] |
130 | } |
131 | }, |
132 | 'HashRef' => { |
133 | expand => sub { shift }, |
134 | collapse => sub { shift } |
e1bb45ff |
135 | }, |
913d96dd |
136 | 'Object' => \%OBJECT_HANDLERS, |
e1bb45ff |
137 | # NOTE: |
138 | # The sanity of enabling this feature by |
139 | # default is very questionable. |
140 | # - SL |
141 | #'CodeRef' => { |
142 | # expand => sub {}, # use eval ... |
143 | # collapse => sub {}, # use B::Deparse ... |
144 | #} |
e59193fb |
145 | ); |
146 | |
147 | sub match_type { |
148 | my ($self, $type_constraint) = @_; |
e1bb45ff |
149 | |
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}; |
155 | |
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. |
e59193fb |
163 | foreach my $type (keys %TYPES) { |
164 | return $TYPES{$type} |
165 | if $type_constraint->is_subtype_of($type); |
166 | } |
e1bb45ff |
167 | |
168 | # NOTE: |
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 ;) |
178 | # - SL |
179 | |
180 | |
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. |
913d96dd |
186 | my $match = $self->_custom_type_match($type_constraint); |
e1bb45ff |
187 | return $match if defined $match; |
bff7e5f7 |
188 | |
e9739624 |
189 | # NOTE: |
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 . ")"; |
e59193fb |
194 | } |
195 | |
913d96dd |
196 | sub _custom_type_match { |
e1bb45ff |
197 | return; |
198 | # my ($self, $type_constraint) = @_; |
199 | } |
200 | |
e59193fb |
201 | 1; |
e9739624 |
202 | |
203 | __END__ |
204 | |
205 | =pod |
206 | |
ec9c1923 |
207 | =head1 NAME |
208 | |
209 | MooseX::Storage::Engine |
210 | |
211 | =head1 SYNOPSIS |
212 | |
213 | =head1 DESCRIPTION |
214 | |
215 | =head1 METHODS |
216 | |
217 | =head2 Accessors |
218 | |
219 | =over 4 |
220 | |
221 | =item B<class> |
222 | |
223 | =item B<object> |
224 | |
225 | =item B<storage> |
226 | |
227 | =back |
228 | |
229 | =head2 API |
230 | |
231 | =over 4 |
232 | |
233 | =item B<expand_object> |
234 | |
235 | =item B<collapse_object> |
236 | |
237 | =back |
238 | |
239 | =head2 ... |
240 | |
241 | =over 4 |
242 | |
243 | =item B<collapse_attribute> |
244 | |
245 | =item B<collapse_attribute_value> |
246 | |
247 | =item B<expand_attribute> |
248 | |
249 | =item B<expand_attribute_value> |
250 | |
251 | =item B<map_attributes> |
252 | |
253 | =item B<match_type> |
254 | |
255 | =back |
256 | |
257 | =head2 Introspection |
258 | |
259 | =over 4 |
260 | |
261 | =item B<meta> |
262 | |
263 | =back |
264 | |
265 | =head1 BUGS |
266 | |
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 |
269 | to cpan-RT. |
270 | |
271 | =head1 AUTHOR |
272 | |
273 | Chris Prather E<lt>chris.prather@iinteractive.comE<gt> |
274 | |
275 | Stevan Little E<lt>stevan.little@iinteractive.comE<gt> |
276 | |
277 | =head1 COPYRIGHT AND LICENSE |
278 | |
279 | Copyright 2007 by Infinity Interactive, Inc. |
280 | |
281 | L<http://www.iinteractive.com> |
282 | |
283 | This library is free software; you can redistribute it and/or modify |
284 | it under the same terms as Perl itself. |
285 | |
e9739624 |
286 | =cut |
287 | |
288 | |
ec9c1923 |
289 | |