Commit | Line | Data |
e59193fb |
1 | |
2 | package MooseX::Storage::Engine; |
3 | use Moose; |
4 | |
5 | has 'storage' => ( |
6 | is => 'rw', |
7 | isa => 'HashRef', |
8 | default => sub {{}} |
9 | ); |
10 | |
11 | has 'object' => ( |
12 | is => 'rw', |
13 | isa => 'Object', |
14 | ); |
15 | |
16 | sub BUILD { |
17 | (shift)->collapse_object; |
18 | } |
19 | |
20 | sub collapse_object { |
21 | my $self = shift; |
22 | $self->process_attributes; |
23 | return $self->storage; |
24 | } |
25 | |
26 | sub extract_attributes { |
27 | my $self = shift; |
28 | return $self->object->meta->compute_all_applicable_attributes; |
29 | } |
30 | |
31 | sub process_attributes { |
32 | my $self = shift; |
33 | foreach my $attr ($self->extract_attributes) { |
34 | next if $attr->name eq '_storage'; |
35 | $self->process_attribute($attr); |
36 | } |
37 | } |
38 | |
39 | sub process_attribute { |
40 | my ($self, $attr) = @_; |
41 | $self->storage->{$attr->name} = $self->collapse_attribute($attr); |
42 | } |
43 | |
44 | my %TYPES = ( |
45 | 'Int' => sub { shift }, |
46 | 'Num' => sub { shift }, |
47 | 'Str' => sub { shift }, |
48 | 'ArrayRef' => sub { shift }, |
49 | 'HashRef' => sub { shift }, |
50 | 'GlobRef' => sub { confess "FOO" }, |
51 | 'CodeRef' => sub { confess "This should use B::Deparse" }, |
52 | 'Object' => sub { |
53 | my $obj = shift; |
54 | $obj || confess("Object Not Defined"); |
55 | ($obj->does('MooseX::Storage::Base')) |
56 | || confess "Bad object"; |
57 | $obj->pack(); |
58 | } |
59 | ); |
60 | |
61 | sub match_type { |
62 | my ($self, $type_constraint) = @_; |
63 | return $TYPES{$type_constraint->name} if exists $TYPES{$type_constraint->name}; |
64 | foreach my $type (keys %TYPES) { |
65 | return $TYPES{$type} |
66 | if $type_constraint->is_subtype_of($type); |
67 | } |
68 | } |
69 | |
70 | sub collapse_attribute { |
71 | my ($self, $attr) = @_; |
72 | my $value = $attr->get_value($self->object); |
73 | if (defined $value && $attr->has_type_constraint) { |
74 | my $type_converter = $self->match_type($attr->type_constraint); |
75 | (defined $type_converter) |
76 | || confess "Cannot convert " . $attr->type_constraint->name; |
77 | $value = $type_converter->($value); |
78 | } |
79 | return $value; |
80 | } |
81 | |
82 | 1; |
83 | __END__ |