local-lib5/lib/perl5/MooseX/MethodAttributes/Role/Meta/Class.pm

   1 package MooseX::MethodAttributes::Role::Meta::Class;
   2 our $VERSION = '0.18';
   3
   4 # ABSTRACT: metaclass role for storing code attributes
   5
   6 use Moose::Role;
   7 use Moose::Util qw/find_meta does_role/;
   8
   9 use namespace::clean -except => 'meta';
  10
  11 with qw/
  12     MooseX::MethodAttributes::Role::Meta::Map
  13 /;
  14
  15
  16 sub get_method_with_attributes_list {
  17     my ($self) = @_;
  18     my @methods = map { $self->get_method($_) } $self->get_method_list;
  19     my %order;
  20
  21     {
  22         my $i = 0;
  23         $order{$_} = $i++ for @{ $self->_method_attribute_list };
  24     }
  25
  26     return map {
  27         $_->[1]
  28     } sort {
  29         $order{ $a->[0] } <=> $order{ $b->[0] }
  30     } map {
  31         my $addr = 0 + $_->_get_attributed_coderef;
  32         exists $self->_method_attribute_map->{$addr}
  33         ? [$addr, $_]
  34         : ()
  35     } grep {
  36         $_->can('_get_attributed_coderef')
  37     } @methods;
  38 }
  39
  40
  41 sub get_all_methods_with_attributes {
  42     my ($self) = @_;
  43     my %seen;
  44
  45     return reverse grep {
  46         !$seen{ $_->name }++
  47     } reverse map {
  48         my $meth;
  49         my $meta = find_meta($_);
  50         ($meta && ($meth = $meta->can('get_method_with_attributes_list')))
  51             ? $meta->$meth
  52             : ()
  53     } reverse $self->linearized_isa;
  54 }
  55
  56
  57 sub get_nearest_methods_with_attributes {
  58     my ($self) = @_;
  59     my @list = map {
  60         my $m = $self->find_method_by_name($_->name);
  61         my $meth = $m->can('attributes');
  62         my $attrs = $meth ? $m->$meth() : [];
  63         scalar @{ $attrs } ? ( $m ) : ( );
  64     } $self->get_all_methods_with_attributes;
  65     return @list;
  66 }
  67
  68 foreach my $type (qw/after before around/) {
  69     around "add_${type}_method_modifier" => sub {
  70         my $orig = shift;
  71         my $meta = shift;
  72         my ($method_name) = @_;
  73
  74                 # Ensure the correct metaclass
  75         $meta = MooseX::MethodAttributes->init_meta( for_class => $meta->name );
  76
  77         my $code = $meta->$orig(@_);
  78         my $method = $meta->get_method($method_name);
  79         if (
  80             does_role($method->get_original_method, 'MooseX::MethodAttributes::Role::Meta::Method')
  81             || does_role($method->get_original_method, 'MooseX::MethodAttributes::Role::Meta::Method::Wrapped')
  82         ) {
  83             MooseX::MethodAttributes::Role::Meta::Method::Wrapped->meta->apply($method);
  84         }
  85         return $code;
  86     }
  87 }
  88
  89 1;
  90
  91
  92 __END__
  93
  94 =pod
  95
  96 =head1 NAME
  97
  98 MooseX::MethodAttributes::Role::Meta::Class - metaclass role for storing code attributes
  99
 100 =head1 VERSION
 101
 102 version 0.18
 103
 104 =head1 METHODS
 105
 106 =head2 get_method_with_attributes_list
 107
 108 Gets the list of meta methods for local methods of this class that have
 109 attributes in the order they have been registered.
 110
 111
 112
 113 =head2 get_all_methods_with_attributes
 114
 115 Gets the list of meta methods of local and inherited methods of this class,
 116 that have attributes. Baseclass methods come before subclass methods. Methods
 117 of one class have the order they have been declared in.
 118
 119
 120
 121 =head2 get_nearest_methods_with_attributes
 122
 123 The same as get_all_methods_with_attributes, except that methods from parent classes
 124 are not included if there is an attributeless method in a child class.
 125
 126 For example, given:
 127
 128     package BaseClass;
 129
 130     sub foo : Attr {}
 131
 132     sub bar : Attr {}
 133
 134     package SubClass;
 135     use base qw/BaseClass/;
 136
 137     sub foo {}
 138
 139     after bar => sub {}
 140
 141 C<< SubClass->meta->get_all_methods_with_attributes >> will return
 142 C<< BaseClass->meta->get_method('foo') >> for the above example, but
 143 this method will not, and will return the wrapped bar method, wheras
 144 C<< get_all_methods_with_attributes >> will return the original method.
 145
 146
 147
 148 =head1 AUTHORS
 149
 150   Florian Ragwitz <rafl@debian.org>
 151   Tomas Doran <bobtfish@bobtfish.net>
 152
 153 =head1 COPYRIGHT AND LICENSE
 154
 155 This software is copyright (c) 2009 by Florian Ragwitz.
 156
 157 This is free software; you can redistribute it and/or modify it under
 158 the same terms as perl itself.
 159
 160 =cut
 161
 162