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 | |
71 | my %TYPES = ( |
e9739624 |
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 } }, |
77 | 'Object' => { |
78 | expand => sub { |
79 | my $data = shift; |
80 | (exists $data->{'__class__'}) |
81 | || confess "Serialized item has no class marker"; |
82 | $data->{'__class__'}->unpack($data); |
83 | }, |
84 | collapse => sub { |
85 | my $obj = shift; |
4d1850a6 |
86 | ($obj->can('does') && $obj->does('MooseX::Storage::Basic')) |
e1bb45ff |
87 | || confess "Bad object ($obj) does not do MooseX::Storage::Basic role"; |
e9739624 |
88 | $obj->pack(); |
89 | }, |
e1bb45ff |
90 | }, |
91 | # NOTE: |
92 | # The sanity of enabling this feature by |
93 | # default is very questionable. |
94 | # - SL |
95 | #'CodeRef' => { |
96 | # expand => sub {}, # use eval ... |
97 | # collapse => sub {}, # use B::Deparse ... |
98 | #} |
e59193fb |
99 | ); |
100 | |
101 | sub match_type { |
102 | my ($self, $type_constraint) = @_; |
e1bb45ff |
103 | |
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}; |
109 | |
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. |
e59193fb |
117 | foreach my $type (keys %TYPES) { |
118 | return $TYPES{$type} |
119 | if $type_constraint->is_subtype_of($type); |
120 | } |
e1bb45ff |
121 | |
122 | # NOTE: |
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 ;) |
132 | # - SL |
133 | |
134 | |
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; |
bff7e5f7 |
142 | |
e9739624 |
143 | # NOTE: |
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 . ")"; |
e59193fb |
148 | } |
149 | |
e1bb45ff |
150 | sub custom_type_match { |
151 | return; |
152 | # my ($self, $type_constraint) = @_; |
153 | } |
154 | |
e59193fb |
155 | 1; |
e9739624 |
156 | |
157 | __END__ |
158 | |
159 | =pod |
160 | |
ec9c1923 |
161 | =head1 NAME |
162 | |
163 | MooseX::Storage::Engine |
164 | |
165 | =head1 SYNOPSIS |
166 | |
167 | =head1 DESCRIPTION |
168 | |
169 | =head1 METHODS |
170 | |
171 | =head2 Accessors |
172 | |
173 | =over 4 |
174 | |
175 | =item B<class> |
176 | |
177 | =item B<object> |
178 | |
179 | =item B<storage> |
180 | |
181 | =back |
182 | |
183 | =head2 API |
184 | |
185 | =over 4 |
186 | |
187 | =item B<expand_object> |
188 | |
189 | =item B<collapse_object> |
190 | |
191 | =back |
192 | |
193 | =head2 ... |
194 | |
195 | =over 4 |
196 | |
197 | =item B<collapse_attribute> |
198 | |
199 | =item B<collapse_attribute_value> |
200 | |
201 | =item B<expand_attribute> |
202 | |
203 | =item B<expand_attribute_value> |
204 | |
205 | =item B<map_attributes> |
206 | |
207 | =item B<match_type> |
208 | |
209 | =back |
210 | |
211 | =head2 Introspection |
212 | |
213 | =over 4 |
214 | |
215 | =item B<meta> |
216 | |
217 | =back |
218 | |
219 | =head1 BUGS |
220 | |
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 |
223 | to cpan-RT. |
224 | |
225 | =head1 AUTHOR |
226 | |
227 | Chris Prather E<lt>chris.prather@iinteractive.comE<gt> |
228 | |
229 | Stevan Little E<lt>stevan.little@iinteractive.comE<gt> |
230 | |
231 | =head1 COPYRIGHT AND LICENSE |
232 | |
233 | Copyright 2007 by Infinity Interactive, Inc. |
234 | |
235 | L<http://www.iinteractive.com> |
236 | |
237 | This library is free software; you can redistribute it and/or modify |
238 | it under the same terms as Perl itself. |
239 | |
e9739624 |
240 | =cut |
241 | |
242 | |
ec9c1923 |
243 | |