File Coverage

blib/lib/Devel/Examine/Subs/Preprocessor.pm
Criterion Covered Total %
statement 146 146 100.0
branch 58 64 90.6
condition 4 6 66.6
subroutine 21 21 100.0
pod 4 6 66.6
total 233 243 95.8


line stmt bran cond sub pod time code
1             package Devel::Examine::Subs::Preprocessor;
2 57     57   906 use 5.008;
  57         126  
3 57     57   198 use strict;
  57         60  
  57         993  
4 57     57   178 use warnings;
  57         57  
  57         2056  
5              
6             our $VERSION = '1.68';
7              
8 57     57   191 use Carp;
  57         67  
  57         3011  
9 57     57   203 use Data::Dumper;
  57         61  
  57         2271  
10 57     57   19415 use Symbol qw(delete_package);
  57         30303  
  57         6185  
11              
12             BEGIN {
13              
14             # we need to do some trickery for DTS due to circular referencing,
15             # which broke CPAN installs.
16              
17 57     57   98 eval {
18 57         8740 require Devel::Trace::Subs;
19             };
20              
21 57         148 eval {
22 57         276 import Devel::Trace::Subs qw(trace);
23             };
24              
25 57 50       258 if (! defined &trace){
26 57     62   10322 *trace = sub {};
27             }
28             };
29              
30             sub new {
31              
32 51 100   51 0 1422 trace() if $ENV{TRACE};
33              
34 50         74 my $self = {};
35 50         74 bless $self, shift;
36              
37 50         57 my $struct = shift;
38              
39 50         115 $self->{pre_procs} = $self->_dt;
40              
41 50         92 return $self;
42             }
43             sub _dt {
44              
45 54 100   54   857 trace() if $ENV{TRACE};
46              
47 53         66 my $self = shift;
48              
49 53         300 my $dt = {
50             module => \&module,
51             inject => \&inject,
52             remove => \&remove,
53             replace => \&replace,
54             _test_bad => \&test_bad,
55             };
56              
57 53         153 return $dt;
58             }
59             sub exists {
60              
61 48 100   48 1 880 trace() if $ENV{TRACE};
62              
63 47         59 my $self = shift;
64 47         56 my $string = shift;
65              
66 47 100       117 if (exists $self->{pre_procs}{$string}){
67 45         127 return 1;
68             }
69             else {
70 2         11 return 0;
71             }
72             }
73             sub module {
74              
75 13 100   13 1 818 trace() if $ENV{TRACE};
76              
77             return sub {
78 11 100   11   21 trace() if $ENV{TRACE};
79              
80 57     57   260 no strict 'refs';
  57         58  
  57         51475  
81              
82 11         12 my $p = shift;
83              
84 11 100 66     40 if (! $p->{module} or $p->{module} eq '') {
85 3         6 return [];
86             }
87              
88 8         51 (my $module_file = $p->{module}) =~ s|::|/|g;
89 8         11 $module_file .= '.pm';
90              
91 8         12 my $module_is_loaded = 0;
92              
93 8 100       33 if (! $INC{$module_file}){
94 4         4 eval {
95 4         772 require "$module_file";
96             };
97              
98 4 100       274 if ($@) {
99 1         12 die "Problem loading $p->{module}: $@";
100             }
101             }
102             else {
103 4         5 $module_is_loaded = 1;
104             }
105              
106 7         13 my $namespace = "$p->{module}::";
107              
108 7         9 my @subs;
109              
110 7         63 for my $sub (keys %$namespace){
111 222 100       117 if (defined &{$namespace . $sub}){
  222         383  
112 187         146 push @subs, $sub;
113             }
114             }
115              
116 7 100       17 if (! $module_is_loaded){
117 3         8 delete_package($p->{module});
118 3         153 delete $INC{$module_file};
119             }
120              
121 7         15 return \@subs;
122 12         59 };
123             }
124             sub inject {
125              
126 7 100   7 1 412 trace() if $ENV{TRACE};
127              
128             return sub {
129              
130 5 50   5   12 trace() if $ENV{TRACE};
131              
132 5         6 my $p = shift;
133              
134 5         5 my @file_contents = @{ $p->{file_contents} };
  5         40  
135              
136             # after line number
137              
138 5         42 my $rw = File::Edit::Portable->new;
139              
140 5 100       33 if (defined $p->{line_num}){
    100          
    50          
141            
142             # inject after line number
143              
144             $rw->splice(
145             file => $p->{file},
146             line => $p->{line_num},
147             insert => $p->{code},
148             copy => $p->{copy},
149 2         13 );
150             }
151             elsif ($p->{inject_use}){
152            
153             # inject a use statement
154              
155 1         4 my $use = qr/use\s+\w+/;
156            
157 1         1 my $index;
158              
159             ($index) = grep {
160 1         3 $file_contents[$_] =~ $use
  51         66  
161             } 0..$#file_contents;
162              
163 1 50       4 if (!$index) {
164             ($index) = grep {
165 1         3 $file_contents[$_] =~ /^package\s+\w+/
  51         43  
166             } 0..$#file_contents;
167 1         3 $index++;
168             }
169              
170 1 50       4 if ($index) {
171             $rw->splice(
172             file => $p->{file},
173             line => $index,
174             insert => $p->{inject_use},
175             copy => $p->{copy},
176 1         7 );
177             }
178             }
179             elsif ($p->{inject_after_sub_def}){
180              
181             # inject code after sub definition
182              
183 2         4 my $code = $p->{inject_after_sub_def};
184              
185 2         3 my @new_file;
186              
187 2         7 my $single_line = qr/
188             sub\s+\w+\s*(?:\(.*?\)\s+)?\{\s*(?!\s*[\S])
189             |
190             sub\s+\{\s*(?!\s*[\S])
191             /x;
192              
193 2         5 my $multi_line = qr/sub\s+\w+\s*(?![\S])/;
194              
195 2         3 my $is_multi = 0;
196              
197 2         2 my $i = -1;
198              
199 2         4 for my $e (@file_contents){
200              
201 58         31 $i++;
202              
203 58         48 my $indent = '';
204              
205 58         31 my $count = $i;
206 58         35 $count++;
207              
208 58         76 while ($count < @file_contents){
209 60 100       104 if ($file_contents[$count] =~ /^(\s*)\S/){
210 56         60 $indent = $1;
211 56         46 last;
212             }
213             else {
214 4         6 $count++;
215             }
216             }
217              
218 58         43 push @new_file, $e;
219              
220 58 100       239 if ($e =~ $single_line) {
    100          
221 11         14 for (@$code){
222 11         20 push @new_file, $indent . $_;
223             }
224             }
225             elsif ($e =~ $multi_line) {
226 1 50       6 if ($file_contents[$count] =~ /\s*\{\s*(?!\s*[\S])/) {
227 1         1 $is_multi = 1;
228 1         2 next;
229             }
230             }
231              
232 57 100       81 if ($is_multi) {
233 1         3 for (@$code) {
234 4         6 push @new_file, $indent . $_;
235             }
236 1         2 $is_multi = 0;
237             }
238             }
239 2         25 $p->{write_file_contents} = \@new_file;
240             }
241             }
242 6         48 }
243             sub replace {
244              
245 23 100   23 0 775 trace() if $ENV{TRACE};
246              
247             return sub {
248              
249 21 100   21   51 trace() if $ENV{TRACE};
250              
251 21         21 my $p = shift;
252 21         28 my $exec = $p->{exec};
253 21 100       44 my $limit = defined $p->{limit} ? $p->{limit} : -1;
254              
255 21         28 my @file = @{ $p->{file_contents} };
  21         172  
256              
257 13 100 66     78 if (! $exec || ref $exec ne 'CODE'){
258 1         231 confess "\nDES::replace() requires 'exec => \$cref param\n";
259             }
260              
261 12         17 my $lines_changed;
262              
263 12         27 for (@file){
264 483         459 my $changed = $exec->($_);
265 483 100       1340 if ($changed){
266 146         74 $lines_changed++;
267 146         99 $limit--;
268 146 100       195 last if $limit == 0;
269             }
270             }
271              
272 12         22 $p->{write_file_contents} = \@file;
273 12         28 return $lines_changed;
274             }
275 22         144 }
276             sub remove {
277              
278 6 100   6 1 794 trace() if $ENV{TRACE};
279              
280             return sub {
281              
282 3 100   3   10 trace() if $ENV{TRACE};
283            
284 3         4 my $p = shift;
285 3         4 my @file = @{ $p->{file_contents}};
  3         28  
286              
287 1         2 my $delete = $p->{delete};
288              
289 1         12 for my $find (@$delete){
290 1         5 while (my ($index) = grep { $file[$_] =~ $find } 0..$#file){
  101         105  
291 1         3 splice @file, $index, 1;
292             }
293             }
294 1         5 $p->{write_file_contents} = \@file;
295             }
296 5         29 }
297 1     1   6 sub _vim_placeholder {1;}
298             1;
299             __END__