lib/CatalystX/Declare/Controller/Meta/TypeConstraintMapping.pm

   1 use MooseX::Declare;
   2
   3 role CatalystX::Declare::Controller::Meta::TypeConstraintMapping {
   4
   5     use MooseX::Types::Moose qw( HashRef Object ArrayRef Str CodeRef );
   6
   7     use aliased 'Moose::Meta::TypeConstraint';
   8     use aliased 'MooseX::Method::Signatures::Meta::Method', 'MethodWithSignature';
   9
  10     has method_type_constraint_map => (
  11         metaclass   => 'Collection::Hash',
  12         is          => 'ro',
  13         isa         => HashRef[Object],
  14         required    => 1,
  15         lazy_build  => 1,
  16         handles    => {
  17             'get_method_type_constraint' => 'get',
  18             'set_method_type_constraint' => 'set,
  19         },
  20     );
  21
  22     has method_named_param_map => (
  23         metaclass   => 'Collection::Hash',
  24         is          => 'ro',
  25         isa         => HashRef[ArrayRef[Str]],
  26         required    => 1,
  27         lazy_build  => 1,
  28         handles    => {
  29             'get_method_named_params' => 'get',
  30             'set_method_named_params' => 'set',
  31         },
  32     );
  33
  34     has method_named_type_constraint_map => (
  35         metaclass   => 'Collection::Hash',
  36         is          => 'ro',
  37         isa         => HashRef[HashRef[Object]],
  38         required    => 1,
  39         lazy_build  => 1,
  40         handles    => {
  41             'get_method_named_type_constraint' => 'get',
  42             'set_method_named_type_constraint' => 'set',
  43         },
  44     );
  45
  46     method _build_method_type_constraint_map {
  47         return +{};
  48     }
  49
  50     method _build_method_named_type_constraint_map {
  51         return +{};
  52     }
  53
  54     method _build_method_named_param_map {
  55         return +{};
  56     }
  57
  58     around add_method ($method_name, $method) {
  59
  60         if (is_Object $method and $method->isa(MethodWithSignature)) {
  61
  62             my $tc = $method->type_constraint;
  63
  64             $self->set_method_type_constraint(
  65                 $method_name,
  66                 $tc,
  67             );
  68
  69             if ($method->parsed_signature->has_named_params) {
  70                 my $named = $method->parsed_signature->named_params;
  71
  72                 $self->set_method_named_params(
  73                     $method_name,
  74                     [ map $_->label, @$named ],
  75                 );
  76                 $self->set_method_named_type_constraint(
  77                     $method_name,
  78                     { map +($_->label, $_->meta_type_constraint), @$named },
  79                 );
  80             }
  81         }
  82
  83         return $self->$orig($method_name, $method);
  84     }
  85
  86     method _find_capable_classes (CodeRef $test) {
  87
  88         return
  89             grep { local $_ = $_; $_->$test }
  90             $self,
  91             map  { $_->meta }
  92             grep { $_->can('meta') }
  93                  $self->linearized_isa;
  94     }
  95
  96     method find_method_named_params (Str $name) {
  97
  98         my @parents = $self->_find_capable_classes(sub { $_->can('get_method_named_params') });
  99
 100         for my $isa (@parents) {
 101
 102             if (my $named = $isa->get_method_named_params($name)) {
 103                 return [@$named];
 104             }
 105         }
 106
 107         return undef;
 108     }
 109
 110     method find_method_named_type_constraint (Str $method, Str $param) {
 111
 112         my @parents = $self->_find_capable_classes(sub { $_->can('get_method_named_type_constraint') });
 113
 114         for my $isa (@parents) {
 115
 116             if (my $named = $isa->get_method_named_type_constraint($method)) {
 117                 return $named->{ $param };
 118             }
 119         }
 120
 121         return undef;
 122     }
 123
 124     method find_method_type_constraint (Str $name) {
 125
 126         my @parents = $self->_find_capable_classes(sub { $_->can('get_method_type_constraint') });
 127
 128         for my $isa (@parents) {
 129
 130             if (my $tc = $isa->get_method_type_constraint($name)) {
 131                 return $tc;
 132             }
 133         }
 134
 135         return undef;
 136     }
 137 }
 138