File Coverage

blib/lib/Sub/Lexical.pm
Criterion Covered Total %
statement 39 42 92.8
branch 4 10 40.0
condition 2 5 40.0
subroutine 8 9 88.8
pod 3 3 100.0
total 56 69 81.1


line stmt bran cond sub pod time code
1             #!/usr/bin/perl
2            
3             package Sub::Lexical;
4            
5             $VERSION = 0.81;
6            
7 2     2   74668 use strict;
  2         5  
  2         187  
8 2     2   18 eval q(use warnings) or local $^W = 1;
  2         7  
  2         55  
9            
10 2     2   4206 use Regexp::Common;
  2         17894  
  2         13  
11 2     2   315448 use Carp qw(croak cluck);
  2         9  
  2         180  
12            
13 2     2   13 use constant DEBUG => 1;
  2         3  
  2         2466  
14            
15             sub new {
16 2     2 1 6 my $class = shift;
17 2 50       15 croak('Sub::Lexical constructor must be called as a class method')
18             if $class ne __PACKAGE__;
19            
20 2 50       13 cluck("arguments passed to new() aren't in pair form")
21             if @_ % 2 != 0;
22            
23             ## don't stuff list in if it don't fit
24 2 50       12 my $self = { @_ % 2 == 0 ? @_ : () };
25            
26 2         18 bless($self, $class);
27             }
28            
29             sub subs_found {
30 0     0 1 0 my $self = shift;
31 0 0       0 return [] unless defined $self->{info};
32 0         0 return $self->{info};
33             }
34            
35             my $brackets_re = $RE{balanced}{-parens => '{}'};
36             my $paren_re = $RE{balanced}{-parens => '()'};
37            
38             ## regex for fully qualified names which I don't want/need
39             # my $sub_fullname_re = qr/[_a-zA-Z](?:(?:\w*)(?:(?:'|::)(?:\w+)+)?)*/;
40            
41             my $sub_name_re = qr{[_a-zA-Z](?:[\w_]+)?};
42             my $sub_proto_re = qr{\([\$%\\@&\s]*\)};
43             my $sub_attrib_re = qr{(?:\s*:\s*$sub_name_re\s*(?:$paren_re)?)*}o;
44             ## my sub foobar (proto) : attrib { "code" }
45             my $sub_match_re = qr/
46             my # literal 'my'
47             \s+ # 1> whitespace
48             sub # literal 'my'
49             \s+ # 1> whitespace
50             ($sub_name_re) # group 1
51             \s* # 0> whitespace
52             ( # group 2
53             $sub_proto_re ? # optional $sub_proto_re
54             $sub_attrib_re ? # optional $sub_attrib_re
55             ) ? # optional group 2
56             \s* # 0> whitespace
57             ( # group 3
58             $brackets_re # match balanced brackets
59             ) ? # optional group 3
60             (?:
61             \s* # 0> whitespace
62             ; # optional literal ';'
63             ) ?
64             /xo;
65            
66             ## core functions which may expect a function e.g goto &foo
67             my $core_funcs = join '|', qw(do defined eval goto grep map sort undef);
68             ## things that *can't* come before or go after a bareword
69             my $ops_before = qr/(?! -> )/x;
70            
71             sub filter_code {
72 2     2 1 5 my $self = shift;
73 2 50 33     35 croak('filter_code() must be called as an object method')
74             if not defined $self or $self eq __PACKAGE__;
75            
76 2         6 my $code = shift;
77 2         30 study $code;
78            
79 2         42 while(my($subname, $subextra, $subcode) = $code =~ /$sub_match_re/) {
80 2         4 push @{$self->{info}}, {
  2         16  
81             name => $subname,
82             extra => $subextra,
83             code => $subcode
84             };
85            
86 2         6 my $lexname = "\$LEXSUB_${subname}";
87             ## 'my sub name {}' => 'my $name; $name = sub {};'
88 2         138 $code =~ s<$sub_match_re>
89             g;
90            
91             ## '&name()' => '$name->()'
92 2         23 $code =~ s<
93             &? # optional &
94 4   50     6271 $subname # 'subname'
95             \s* # 0+ whitespace
96             ( # group $1
97             $paren_re # balanced parens
98             ) # optional group $1
99             >{"$lexname->" . ($1 || '()')}exg;
100            
101             ## 'goto &name' => 'goto &$name'
102 2         270 $code =~ s<($core_funcs) \s* &$subname\b>
103             {$1 &$lexname}xg;
104            
105             ## '&name' => '$name->(@_)'
106 2         198 $code =~ s{ (?
107             {$lexname->(\@_)}xg;
108            
109             ## '\&name' => '$name'
110 2         193 $code =~ s<(?: \\ \s*)+ &($sub_name_re)\b>
111             <\$LEXSUB_$1>xg;
112            
113             ## 'name' => '$name->()'
114 2         1574 $code =~ s{(?: ^ | (?
115             $subname \b }
116             {$1$lexname->()}xmg;
117             }
118 2         92 return $code;
119             }
120            
121 2     2   18633 use Filter::Simple;
  2         141652  
  2         20  
122            
123             FILTER_ONLY code => sub {
124             $_ = Sub::Lexical->new()->filter_code($_);
125             };
126            
127             q(package activated);
128            
129             __END__