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); |
44 | # TODO: |
45 | # we want to explicitly disallow |
46 | # cycles here, because the base |
47 | # storage engine does not support |
48 | # them |
49 | if (defined $value && $attr->has_type_constraint) { |
50 | my $type_converter = $self->match_type($attr->type_constraint); |
51 | (defined $type_converter) |
52 | || confess "Cannot convert " . $attr->type_constraint->name; |
53 | $value = $type_converter->{collapse}->($value); |
54 | } |
55 | return $value; |
56 | } |
57 | |
58 | sub expand_attribute_value { |
59 | my ($self, $attr, $value) = @_; |
60 | # TODO: |
61 | # we need to check $value here to |
62 | # make sure that we do not have |
63 | # a cycle here. |
64 | if (defined $value && $attr->has_type_constraint) { |
65 | my $type_converter = $self->match_type($attr->type_constraint); |
66 | $value = $type_converter->{expand}->($value); |
67 | } |
68 | return $value; |
69 | } |
70 | |
71 | # util methods ... |
72 | |
73 | sub map_attributes { |
74 | my ($self, $method_name, @args) = @_; |
75 | map { |
76 | $self->$method_name($_, @args) |
77 | } ($self->object || $self->class)->meta->compute_all_applicable_attributes; |
e59193fb |
78 | } |
79 | |
80 | my %TYPES = ( |
e9739624 |
81 | 'Int' => { expand => sub { shift }, collapse => sub { shift } }, |
82 | 'Num' => { expand => sub { shift }, collapse => sub { shift } }, |
83 | 'Str' => { expand => sub { shift }, collapse => sub { shift } }, |
84 | 'ArrayRef' => { expand => sub { shift }, collapse => sub { shift } }, |
85 | 'HashRef' => { expand => sub { shift }, collapse => sub { shift } }, |
86 | 'Object' => { |
87 | expand => sub { |
88 | my $data = shift; |
89 | (exists $data->{'__class__'}) |
90 | || confess "Serialized item has no class marker"; |
91 | $data->{'__class__'}->unpack($data); |
92 | }, |
93 | collapse => sub { |
94 | my $obj = shift; |
4d1850a6 |
95 | ($obj->can('does') && $obj->does('MooseX::Storage::Basic')) |
e9739624 |
96 | || confess "Bad object ($obj) does not do MooseX::Storage::Base role"; |
97 | $obj->pack(); |
98 | }, |
99 | } |
e59193fb |
100 | ); |
101 | |
102 | sub match_type { |
103 | my ($self, $type_constraint) = @_; |
104 | return $TYPES{$type_constraint->name} if exists $TYPES{$type_constraint->name}; |
105 | foreach my $type (keys %TYPES) { |
106 | return $TYPES{$type} |
107 | if $type_constraint->is_subtype_of($type); |
108 | } |
e9739624 |
109 | # TODO: |
110 | # from here we can expand this to support the following: |
111 | # - if it is subtype of Ref |
112 | # -- if it is a subtype of Object |
113 | # --- treat it like an object |
114 | # -- else |
115 | # --- treat it like any other Ref |
116 | # - else |
117 | # -- if it is a subtype of Num or Str |
118 | # --- treat it like Num or Str |
119 | # -- else |
120 | # --- pass it on |
121 | # this should cover 80% of all use cases |
e59193fb |
122 | |
bff7e5f7 |
123 | # CHRIS: To cover the last 20% we need a way |
124 | # for people to extend this process. |
125 | |
e9739624 |
126 | # NOTE: |
127 | # if this method hasnt returned by now |
128 | # then we have no been able to find a |
129 | # type constraint handler to match |
130 | confess "Cannot handle type constraint (" . $type_constraint->name . ")"; |
e59193fb |
131 | } |
132 | |
133 | 1; |
e9739624 |
134 | |
135 | __END__ |
136 | |
137 | =pod |
138 | |
ec9c1923 |
139 | =head1 NAME |
140 | |
141 | MooseX::Storage::Engine |
142 | |
143 | =head1 SYNOPSIS |
144 | |
145 | =head1 DESCRIPTION |
146 | |
147 | =head1 METHODS |
148 | |
149 | =head2 Accessors |
150 | |
151 | =over 4 |
152 | |
153 | =item B<class> |
154 | |
155 | =item B<object> |
156 | |
157 | =item B<storage> |
158 | |
159 | =back |
160 | |
161 | =head2 API |
162 | |
163 | =over 4 |
164 | |
165 | =item B<expand_object> |
166 | |
167 | =item B<collapse_object> |
168 | |
169 | =back |
170 | |
171 | =head2 ... |
172 | |
173 | =over 4 |
174 | |
175 | =item B<collapse_attribute> |
176 | |
177 | =item B<collapse_attribute_value> |
178 | |
179 | =item B<expand_attribute> |
180 | |
181 | =item B<expand_attribute_value> |
182 | |
183 | =item B<map_attributes> |
184 | |
185 | =item B<match_type> |
186 | |
187 | =back |
188 | |
189 | =head2 Introspection |
190 | |
191 | =over 4 |
192 | |
193 | =item B<meta> |
194 | |
195 | =back |
196 | |
197 | =head1 BUGS |
198 | |
199 | All complex software has bugs lurking in it, and this module is no |
200 | exception. If you find a bug please either email me, or add the bug |
201 | to cpan-RT. |
202 | |
203 | =head1 AUTHOR |
204 | |
205 | Chris Prather E<lt>chris.prather@iinteractive.comE<gt> |
206 | |
207 | Stevan Little E<lt>stevan.little@iinteractive.comE<gt> |
208 | |
209 | =head1 COPYRIGHT AND LICENSE |
210 | |
211 | Copyright 2007 by Infinity Interactive, Inc. |
212 | |
213 | L<http://www.iinteractive.com> |
214 | |
215 | This library is free software; you can redistribute it and/or modify |
216 | it under the same terms as Perl itself. |
217 | |
e9739624 |
218 | =cut |
219 | |
220 | |
ec9c1923 |
221 | |