lib/MooseX/Storage/Engine.pm

   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__