File Coverage

blib/lib/Module/Compile.pm
Criterion Covered Total %
statement 250 271 92.2
branch 64 94 68.0
condition 31 44 70.4
subroutine 35 40 87.5
pod 0 28 0.0
total 380 477 79.6


line stmt bran cond sub pod time code
1             # To Do:
2             #
3             # - Make preface part of parsed code, since it might contain `package`
4             # statements or other scoping stuff.
5             # - Build code into an AST.
6 9     9   8429 use strict; use warnings;
  9     9   26  
  9         238  
  9         46  
  9         17  
  9         424  
7             package Module::Compile;
8             our $VERSION = '0.38';
9              
10 9     9   4328 use Digest::SHA1();
  9         6541  
  9         5341  
11              
12             # A lexical hash to keep track of which files have already been filtered
13             my $filtered = {};
14              
15             # A map of digests to code blocks
16             my $digest_map = {};
17              
18             # All subroutines are prefixed with pmc_ so subclasses don't
19             # accidentally override things they didn't intend to.
20              
21             # Determine which stack frame points to the code we are filtering.
22             # This is a method in case it needs to be overridden.
23 3     3 0 18 sub pmc_caller_stack_frame { 0 };
24              
25             # This is called while parsing source code to determine if the
26             # module/class in a use/no line is part of the Module::Compile game.
27             #
28             # Return true if this class supports PMC compilation.
29             #
30             # The hope is that this will allow interoperability with modules that
31             # do not inherit from Module::Compile but still want to do this sort
32             # of thing.
33 11     11 0 44 sub pmc_is_compiler_module { 1 };
34              
35             sub new {
36 0     0 0 0 return bless {}, shift;
37             }
38              
39             # This is called to determine whether the meaning of use/no is reversed.
40 19     19 0 80 sub pmc_use_means_no { 0 }
41              
42             # This is called to determine whether the use line means a one line section.
43 6     6 0 25 sub pmc_use_means_now { 0 }
44              
45             # All Module::Compile based modules inherit this import routine.
46             sub import {
47 8     8   6171 my ($class) = @_;
48 8 50       27 return if $class->pmc_use_means_no;
49 8         16 goto &{$class->can('pmc_import')};
  8         74  
50             }
51              
52             # Treat unimport like import if use means no
53             sub unimport {
54 0     0   0 my ($class) = @_;
55 0 0       0 return unless $class->pmc_use_means_no;
56 0         0 goto &{$class->can('pmc_import')};
  0         0  
57             }
58              
59             sub pmc_import {
60 8     8 0 27 my ($class, @args) = @_;
61              
62             # Handler modules can do `use Module::Compile -base;`. Make them ISA
63             # Module::Compile and get the hell out of Dodge.
64 8 100       36 $class->pmc_set_base(@args) and return;
65              
66 3         11 my ($module, $line) = (caller($class->pmc_caller_stack_frame))[1, 2];
67              
68 3 50       18 return if $filtered->{$module}++;
69              
70             my $callback = sub {
71 3     3   14 my ($class, $content, $data) = @_;
72 3         30 my $output = $class->pmc_template($module, $content, $data);
73 3         13 $class->pmc_output($module, $output);
74 3         13 };
75              
76 3         15 $class->pmc_check_compiled_file($module);
77              
78 3         15 $class->pmc_filter($module, $line, $callback);
79              
80             # Is there a meaningful return value here?
81 3         71 return;
82             }
83              
84             # File might not be a module (.pm) and might be compiled already.
85             # If so, run the compiled file.
86             sub pmc_check_compiled_file {
87 3     3 0 7 my ($class, $file) = @_;
88              
89 3 100 66     35 if (defined $file and $file !~ /\.pm$/i) {
90             # Do the freshness check ourselves
91 1         3 my $pmc = $file.'c';
92 1 50 33     42 $class->pmc_run_compiled_file($pmc), die
93             if -s $pmc and (-M $pmc <= -M $file);
94             }
95             }
96              
97             sub pmc_run_compiled_file {
98 0     0 0 0 my ($class, $pmc) = @_;
99 0         0 my ($package) = caller($class->pmc_file_caller_frame());
100 0         0 eval "package $package; do \$pmc";
101 0 0       0 die $@ if $@;
102 0         0 exit 0;
103             }
104              
105 0     0 0 0 sub pmc_file_caller_frame { 2 }
106              
107             # Set up inheritance
108             sub pmc_set_base {
109 8     8 0 21 my ($class, $flag) = @_;
110              
111             # Handle the `use Module::Compile -base;` command.
112 8 100 66     105 if ($class->isa(__PACKAGE__) and defined $flag and $flag eq '-base') {
      66        
113 5         36 my $descendant = (caller 1)[0];;
114 9     9   72 no strict 'refs';
  9         20  
  9         8735  
115 5         14 push @{$descendant . '::ISA'}, $class;
  5         43  
116 5         525 return 1;
117             }
118              
119 3         9 return 0;
120             }
121              
122             # Generate the actual code that will go into the .pmc file.
123             sub pmc_template {
124 3     3 0 14 my ($class, $module, $content, $data) = @_;
125 3         5 my $base = __PACKAGE__;
126 3         12 my $check = $class->freshness_check($module);
127 3   100     51 my $version = $class->VERSION || '0';
128 3         28 return join "\n",
129             "# Generated by $class $version ($base $VERSION) - do not edit!",
130             "$check$content$data";
131             }
132              
133             # This returns a piece of Perl code to do a runtime check to see if the
134             # .pmc file is fresh. By default we use a 32-bit running checksum.
135             sub freshness_check {
136 3     3 0 8 my ($class, $module) = @_;
137 3         8 my $sum = sprintf('%08X', do {
138 3         13 local $/;
139 3 50       118 open my $fh, "<", $module
140             or die "Cannot open $module: $!";
141 3         32 binmode($fh, ':crlf'); # normalize CRLF for consistent checksum
142 3         217 unpack('%32N*', <$fh>);
143             });
144 3         20 return << "...";
145             ################((( 32-bit Checksum Validator III )))################
146             #line 1
147             BEGIN { use 5.006; local (*F, \$/); (\$F = __FILE__) =~ s!c\$!!; open(F)
148             or die "Cannot open \$F: \$!"; binmode(F, ':crlf'); if (unpack('%32N*',
149             \$F=readline(*F)) != 0x$sum) { use Filter::Util::Call; my \$f = \$F;
150             filter_add(sub { filter_del(); 1 while &filter_read; \$_ = \$f; 1; })}}
151             #line 1
152             ...
153             }
154              
155             # Write the output to the .pmc file
156             sub pmc_output {
157 3     3 0 10 my ($class, $module, $output) = @_;
158 3 50       11 $class->pmc_can_output($module)
159             or return 0;
160 3         9 my $pmc = $module . 'c';
161              
162             # If we can't open the file, just return. The filtering will not be cached,
163             # but that might be ok.
164 3 50       309 open my $fh, ">", $pmc
165             or return 0;
166              
167             # Protect against disk full or whatever else.
168 3         10 local $@;
169 3         6 eval {
170 3 50       16 print $fh $output
171             or die;
172 3 50       158 close $fh
173             or die;
174             };
175 3 50       16 if ( my $e = $@ ) {
176             # close $fh? die if unlink?
177 0 0       0 if ( -e $pmc ) {
178 0 0       0 unlink $pmc
179             or die "Can't delete errant $pmc: $!";
180             }
181 0         0 return 0;
182             }
183              
184 3         17 return 1;
185             }
186              
187             # Check whether output can be written.
188             sub pmc_can_output {
189 3     3 0 8 my ($class, $file_path) = @_;
190 3         9 return 1;
191             # return $file_path =~ /\.pm$/;
192             }
193              
194             # We use a source filter to get all the code for compiling.
195             sub pmc_filter {
196 3     3 0 11 my ($class, $module, $line_number, $post_process) = @_;
197              
198             # Read original module source code instead of taking from filter,
199             # because we need all the lines including the ones before the `use`
200             # statement, so we can parse Perl into packages and such.
201 3 50       118 open my $fh, $module
202             or die "Can't open $module for input:\n$!";
203 3         10 my $module_content = do { local $/; <$fh> };
  3         15  
  3         74  
204 3         30 close $fh;
205              
206             # Find the real __DATA__ or __END__ line. (Not one hidden in a Pod
207             # section or heredoc).
208 3         28 my $folded_content = $class->pmc_fold_blocks($module_content);
209 3         6 my $folded_data = '';
210 3 100       23 if ($folded_content =~ s/^((?:__(?:DATA|END)__$).*)//ms) {
211 2         7 $folded_data = $1;
212             }
213 3         13 my $real_content = $class->pmc_unfold_blocks($folded_content);
214 3         10 my $real_data = $class->pmc_unfold_blocks($folded_data);
215              
216             # Calculate the number of lines to skip in the source filter, since
217             # we already have them in $real_content.
218 3         52 my @lines = ($real_content =~ /(.*\n)/g);
219 3         8 my $lines_to_skip = @lines;
220 3         6 $lines_to_skip -= $line_number;
221              
222             # Use filter to skip past that many lines
223             # Leave __DATA__ section intact
224 3         5 my $done = 0;
225 3         528 require Filter::Util::Call;
226             Filter::Util::Call::filter_add(sub {
227 4 100   4   2798 return 0 if $done;
228 3         6 my $data_line = '';
229 3         12 while (1) {
230 38         79 my $status = Filter::Util::Call::filter_read();
231 38 100       64 last unless $status;
232 37 50       64 return $status if $status < 0;
233             # Skip lines up to the DATA section.
234 37 100       64 next if $lines_to_skip-- > 0;
235 2 50       12 if (/^__(?:END|DATA)__$/) {
236             # Don't filter the DATA section, or else the DATA file
237             # handle becomes invalid.
238              
239             # XXX - Maybe there is a way to simply recreate the DATA
240             # file handle, or at least seek back to the start of it.
241             # Needs investigation.
242              
243             # For now this means that we only allow compilation on
244             # the module content; not the DATA section. Because we
245             # want to make sure that the program runs the same way
246             # as both a .pm and a .pmc.
247              
248 2         5 $data_line = $_;
249 2         4 last;
250             }
251             }
252             continue {
253 35         48 $_ = '';
254             }
255              
256 3         9 $real_content =~ s/\r//g;
257 3         21 my $filtered_content = $class->pmc_process($real_content);
258 3         35 $class->$post_process($filtered_content, $real_data);
259              
260 3         64 $filtered_content =~ s/(.*\n){$line_number}//;
261              
262 3         12 $_ = $filtered_content . $data_line;
263              
264 3         177 $done = 1;
265 3         1135 });
266             }
267              
268 9     9   73 use constant TEXT => 0;
  9         19  
  9         715  
269 9     9   62 use constant CONTEXT => 1;
  9         19  
  9         823  
270 9     9   65 use constant CLASSES => 2;
  9         20  
  9         14092  
271             # Break the code into blocks. Compile the blocks.
272             # Fold out heredocs etc
273             # Parse the code into packages, blocks and subs
274             # Parse the code by `use/no *::Compiler`
275             # Build an AST
276             # Reduce the AST until fully reduced
277             # Return the result
278             sub pmc_process {
279 5     5 0 21 my $class = shift;
280 5         13 my $data = shift;
281 5         19 my @blocks = $class->pmc_parse_blocks($data);
282 5         28 while (@blocks = $class->pmc_reduce(@blocks)) {
283 19 100 66     66 if (@blocks == 1 and @{$blocks[0][CLASSES]} == 0) {
  5         20  
284 5         12 my $content = $blocks[0][TEXT];
285 5 50       33 $content .= "\n" unless $content =~ /\n\z/;
286 5         26 return $content;
287             }
288             }
289 0         0 die "How did I get here?!?";
290             }
291              
292             # Analyze the remaining blocks and determine which compilers to call to reduce
293             # the problem.
294             #
295             # XXX This routine must do some kind of reduction each pass, or infinite loop
296             # will ensue. It is not yet certain if this is the case.
297             sub pmc_reduce {
298 19     19 0 31 my $class = shift;
299 19         38 my @blocks;
300             my $prev;
301 19         80 while (@_) {
302 44         75 my $block = shift;
303 44         57 my $next = $_[TEXT];
304 44 100 100     116 if ($next and "@{$block->[CLASSES]}" eq "@{$next->[CLASSES]}") {
  32 100 100     66  
  32   100     161  
      66        
305 13         27 shift;
306 13         32 $block->[TEXT] .= $next->[TEXT];
307             }
308             elsif (
309             (not $prev or @{$prev->[CLASSES]} < @{$block->[CLASSES]}) and
310             (not $next or @{$next->[CLASSES]} < @{$block->[CLASSES]})
311             ) {
312 8 50       28 my $prev_len = $prev ? @{$prev->[CLASSES]} : 0;
  8         14  
313 8 100       21 my $next_len = $next ? @{$next->[CLASSES]} : 0;
  5         8  
314 8 50       21 my $offset = ($prev_len > $next_len) ? $prev_len : $next_len;
315 8         12 my $length = @{$block->[CLASSES]} - $offset;
  8         16  
316 8         24 $class->pmc_call($block, $offset, $length);
317             }
318 44         90 push @blocks, $block;
319 44         100 $prev = $block;
320             }
321 19         71 return @blocks;
322             }
323              
324             # Call a set of compilers on a piece of source code.
325             sub pmc_call {
326 8     8 0 19 my $class = shift;
327 8         16 my $block = shift;
328 8         12 my $offset = shift;
329 8         12 my $length = shift;
330              
331 8         14 my $text = $block->[TEXT];
332 8         12 my $context = $block->[CONTEXT];
333 8         14 my @classes = splice(@{$block->[CLASSES]}, $offset, $length);
  8         75  
334 8         22 for my $klass (@classes) {
335 8         14 local $_ = $text;
336 8   50     110 my $return = $klass->pmc_compile($text, ($context->{$klass} || {}));
337 8 100 66     126 $text = (defined $return and $return !~ /^\d+\z/)
338             ? $return
339             : $_;
340             }
341 8         29 $block->[TEXT] = $text;
342             }
343              
344             # Divide a Perl module into blocks. This code divides a module based on
345             # lines that use/no a Module::Compile subclass.
346             sub pmc_parse_blocks {
347 5     5 0 10 my $class = shift;
348 5         10 my $data = shift;
349 5         9 my @blocks = ();
350 5         9 my @classes = ();
351 5         9 my $context = {};
352 5         10 my $text = '';
353 5         80 my @parts = split /^([^\S\n]*(?:use|no)[^\S\n]+[\w\:\']+[^\n]*\n)/m, $data;
354 5         19 for my $part (@parts) {
355 35 100       167 if ($part =~ /^[^\S\n]*(use|no)[^\S\n]+([\w\:\']+)[^\n]*\n/) {
356 15         64 my ($use, $klass, $file) = ($1, $2, $2);
357 15         70 $file =~ s{(?:::|')}{/}g;
358 15 50       58 if ($klass =~ /^\d+$/) {
359 0         0 $text .= $part;
360 0         0 next;
361             }
362             {
363 15         24 local $@;
  15         25  
364 15         24 eval { require "$file.pm" };
  15         2230  
365 15 50 66     70852 die $@ if $@ and "$@" !~ /^Can't locate /;
366             }
367 15 100 66     144 if ($klass->can('pmc_is_compiler_module') and
368             $klass->pmc_is_compiler_module) {
369 11         80 push @blocks, [$text, {%$context}, [@classes]];
370 11         24 $text = '';
371 11         25 @classes = grep {$_ ne $klass} @classes;
  7         23  
372 11 100 50     45 if (($use eq 'use') xor $klass->pmc_use_means_no) {
373 8         33 push @classes, $klass;
374 8 50       15 $context->{$klass} = {%{$context->{$klass} || {}}};
  8         53  
375 8         39 $context->{$klass}{use} = $part;
376 8 100       86 if ($klass->pmc_use_means_now) {
377 2         9 push @blocks, ['', {%$context}, [@classes]];
378 2         5 @classes = grep {$_ ne $klass} @classes;
  2         7  
379 2         7 delete $context->{$klass};
380             }
381             }
382             else {
383 3         10 delete $context->{$klass};
384             }
385             }
386             else {
387 4         15 $text .= $part;
388             }
389             }
390             else {
391 20         56 $text .= $part;
392             }
393             }
394 5 50       34 push @blocks, [$text, {%$context}, [@classes]]
395             if length $text;
396 5         38 return @blocks;
397             }
398              
399             # Compile/Filter some source code into something else. This is almost
400             # always overridden in a subclass.
401             sub pmc_compile {
402 2     2 0 6 my ($class, $source_code_string, $context_hashref) = @_;
403 2         43 return $source_code_string;
404             }
405              
406             # Regexp fragments for matching heredoc, pod section, comment block and
407             # data section.
408             my $re_here = qr/
409             (?: # Heredoc starting line
410             ^ # Start of some line
411             ((?-s:.*?)) # $2 - text before heredoc marker
412             <<(?!=) # heredoc marker
413             [\t\x20]* # whitespace between marker and quote
414             ((?>['"]?)) # $3 - possible left quote
415             ([\w\-\.]*) # $4 - heredoc terminator
416             (\3 # $5 - possible right quote
417             (?-s:.*\n)) # and rest of the line
418             (.*?\n) # $6 - Heredoc content
419             (?
420             (\4\n) # $7 - Heredoc terminating line
421             )
422             /xsm;
423              
424             my $re_pod = qr/
425             (?:
426             (?-s:^=(?!cut\b)\w+.*\n) # Pod starter line
427             .*? # Pod lines
428             (?:(?-s:^=cut\b.*\n)|\z) # Pod terminator
429             )
430             /xsm;
431              
432             my $re_comment = qr/
433             (?:
434             (?m-s:^[^\S\n]*\#.*\n)+ # one or more comment lines
435             )
436             /xsm;
437              
438             my $re_data = qr/
439             (?:
440             ^(?:__END__|__DATA__)\n # DATA starter line
441             .* # Rest of lines
442             )
443             /xsm;
444              
445             # Fold each heredoc, pod section, comment block and data section, each
446             # into a single line containing a digest of the original content.
447             #
448             # This makes further dividing of Perl code less troublesome.
449             sub pmc_fold_blocks {
450 12     12 0 57 my ($class, $source) = @_;
451              
452 12         40 $source =~ s/(~{3,})/$1~/g;
453 12         27 $source =~ s/(^'{3,})/$1'/gm;
454 12         20 $source =~ s/(^`{3,})/$1`/gm;
455 12         22 $source =~ s/(^={3,})/$1=/gm;
456              
457 12         19 while (1) {
458 9     9   77 no warnings;
  9         50  
  9         8237  
459 32 100       1921 $source =~ s/
460             (
461             $re_pod |
462             $re_comment |
463             $re_here |
464             $re_data
465             )
466             /
467 20         67 my $result = $1;
468 20 50       529 $result =~ m{\A($re_data)} ? $class->pmc_fold_data() :
    100          
    100          
    100          
469             $result =~ m{\A($re_pod)} ? $class->pmc_fold_pod() :
470             $result =~ m{\A($re_comment)} ? $class->pmc_fold_comment() :
471             $result =~ m{\A($re_here)} ? $class->pmc_fold_here() :
472             die "'$result' didn't match '$re_comment'";
473             /ex or last;
474             }
475              
476 12         62 $source =~ s/(?
477 12         125 $source =~ s/^'''(?!') /__DATA__\n/gm;
478 12         30 $source =~ s/^```(?!`)/#/gm;
479 12         32 $source =~ s/^===(?!=)/=/gm;
480              
481 12         22 $source =~ s/^(={3,})=/$1/gm;
482 12         24 $source =~ s/^('{3,})'/$1/gm;
483 12         18 $source =~ s/^(`{3,})`/$1/gm;
484 12         24 $source =~ s/(~{3,})~/$1/g;
485              
486 12         45 return $source;
487             }
488              
489             sub pmc_unfold_blocks {
490 6     6 0 15 my ($class, $source) = @_;
491              
492 6         58 $source =~ s/
493             (
494             ^__DATA__\n[0-9a-fA-F]{40}\n
495             |
496             ^=pod\s[0-9a-fA-F]{40}\n=cut\n
497             )
498             /
499 3         9 my $match = $1;
500 3 50       18 $match =~ s!.*?([0-9a-fA-F]{40}).*!$1!s or die;
501 3         19 $digest_map->{$match}
502             /xmeg;
503              
504 6         14 return $source;
505             }
506              
507             # Fold a heredoc's content but don't fold other heredocs from the
508             # same line.
509             sub pmc_fold_here {
510 10     10 0 22 my $class = shift;
511 10         45 my $result = "$2~~~$3$4$5";
512 10         14 my $preface = '';
513 10         20 my $text = $6;
514 10         16 my $stop = $7;
515 10         14 while (1) {
516 12 100       31 if ($text =~ s!^(([0-9a-fA-F]{40})\n.*\n)!!) {
517 2 50       9 if (defined $digest_map->{$2}) {
518 2         5 $preface .= $1;
519 2         5 next;
520             }
521             else {
522 0         0 $text = $1 . $text;
523 0         0 last;
524             }
525             }
526 10         16 last;
527             }
528 10         22 my $digest = $class->pmc_fold($text);
529 10         43 $result = "$result$preface$digest\n$stop";
530 10         57 $result;
531             }
532              
533             sub pmc_fold_pod {
534 3     3 0 8 my $class = shift;
535 3         8 my $text = $1;
536 3         10 my $digest = $class->pmc_fold($text);
537 3         22 return qq{===pod $digest\n===cut\n};
538             }
539              
540             sub pmc_fold_comment {
541 4     4 0 12 my $class = shift;
542 4         10 my $text = $1;
543 4         10 my $digest = $class->pmc_fold($text);
544 4         29 return qq{``` $digest\n};
545             }
546              
547             sub pmc_fold_data {
548 3     3 0 9 my $class = shift;
549 3         8 my $text = $1;
550 3         12 my $digest = $class->pmc_fold($text);
551 3         21 return qq{''' $digest\n};
552             }
553              
554             # Fold a piece of code into a unique string.
555             sub pmc_fold {
556 20     20 0 103 require Digest::SHA1;
557 20         47 my ($class, $text) = @_;
558 20         154 my $digest = Digest::SHA1::sha1_hex($text);
559 20         58 $digest_map->{$digest} = $text;
560 20         49 return $digest;
561             }
562              
563             # Expand folded code into original content.
564             sub pmc_unfold {
565 0     0 0   my ($class, $digest) = @_;
566 0           return $digest_map->{$digest};
567             }
568              
569             1;