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; |
95 | ($obj->can('does') && $obj->does('MooseX::Storage::Base')) |
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 | |
139 | =cut |
140 | |
141 | |