File Coverage

blib/lib/MOP/Method/Attribute.pm
Criterion Covered Total %
statement 39 40 97.5
branch 3 6 50.0
condition 3 7 42.8
subroutine 14 14 100.0
pod 6 6 100.0
total 65 73 89.0


line stmt bran cond sub pod time code
1             package MOP::Method::Attribute;
2             # ABSTRACT: The Method Attribute object
3              
4 33     33   232 use strict;
  33         75  
  33         1015  
5 33     33   200 use warnings;
  33         68  
  33         915  
6              
7 33     33   199 use Carp ();
  33         66  
  33         623  
8              
9 33     33   185 use UNIVERSAL::Object::Immutable;
  33         113  
  33         2129  
10              
11             our $VERSION = '0.12';
12             our $AUTHORITY = 'cpan:STEVAN';
13              
14 33     33   2504 our @ISA; BEGIN { @ISA = ('UNIVERSAL::Object::Immutable') }
15             our %HAS; BEGIN {
16             %HAS = (
17 0         0 original => sub { die '`original` is required' },
18             )
19 33     33   16699 }
20              
21             # NOTE:
22             # we are not terribly sophisticated, but
23             # we accept `foo` calls (no-parens) and
24             # we accept `foo(1, 2, 3)` calls (parens
25             # with comma seperated args).
26              
27             sub BUILDARGS {
28 2     2 1 140 my $class = shift;
29 2 50 33     12 Carp::confess('You must pass only a simple string')
30             unless scalar(@_) == 1 && not ref $_[0];
31 2         6 return +{ original => $_[0] };
32             }
33              
34 2     2 1 4 sub REPR { \(my $x) }
35              
36             sub CREATE {
37 2     2 1 27 my ($class, $proto) = @_;
38 2         4 my $self = $class->REPR;
39 2         5 $$self = $proto->{original};
40 2         5 $self;
41             }
42              
43 1     1 1 2 sub original { ${ $_[0] } }
  1         4  
44              
45             sub name {
46 2     2 1 53 my ($self) = @_;
47 2         8 my ($name) = ($$self =~ m/^([a-zA-Z_]*)/);
48 2         11 return $name;
49             }
50              
51             sub args {
52 1     1 1 4 my ($self, $arg_splitter, $arg_processor) = @_;
53 1         6 my ($args) = ($$self =~ m/^[a-zA-Z_]*\(\s*(.*)\)/ms);
54 1 50       5 return unless $args;
55              
56             # NOTE:
57             # These parses arguments badly,
58             # but they are just the defaults.
59             # it makes no attempt to enforce
60             # anything, just splits on the
61             # comma, both skinny and fat,
62             # then strips away any quotes
63             # and treats everything as a
64             # simple string.
65 1   50 1   8 $arg_splitter ||= sub { split /\s*(?:\,|\=\>)\s*/ => $_[0] };
  1         7  
66             $arg_processor ||= sub {
67             # NOTE:
68             # None of the args are eval-ed and they are
69             # basically just a list of strings, with the
70             # one exception of the string "undef", which
71             # will be turned into undef
72 2     2   4 my $arg = $_[0];
73 2         7 $arg =~ s/\s*$//;
74 2         5 $arg =~ s/^['"]//;
75 2         22 $arg =~ s/['"]$//;
76 2 50       24 $arg eq 'undef' ? undef : $arg;
77 1   50     6 };
78              
79 1         3 return [ map $arg_processor->( $_ ), $arg_splitter->( $args ) ];
80             }
81              
82             1;
83              
84             __END__