File Coverage

blib/lib/Mason/Compilation.pm
Criterion Covered Total %
statement 555 560 99.1
branch 145 160 90.6
condition 50 62 80.6
subroutine 149 149 100.0
pod n/a
total 899 931 96.5


line stmt bran cond sub pod time code
1             # Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
2             # This program is free software; you can redistribute it and/or modify it
3             # under the same terms as Perl itself.
4              
5             package Mason::Compilation;
6             $Mason::Compilation::VERSION = '2.24';
7 19     19   13786 use File::Basename qw(dirname);
  19         36  
  19         1389  
8 19     19   91 use Guard;
  19         26  
  19         787  
9 19     19   7107 use Mason::Component::ClassMeta;
  19         375  
  19         929  
10 19     19   152 use Mason::Util qw(dump_one_line json_encode read_file taint_is_on trim);
  19         31  
  19         1632  
11 19     19   97 use Mason::Moose;
  19         36  
  19         169  
12              
13             # Passed attributes
14             has 'interp' => ( required => 1, weak_ref => 1 );
15             has 'path' => ( required => 1 );
16             has 'source_file' => ( required => 1 );
17              
18             # Derived attributes - most of these should be class attributes :(
19             has 'bad_attribute_hash' => ( lazy_build => 1, init_arg => undef );
20             has 'bad_method_hash' => ( lazy_build => 1, init_arg => undef );
21             has 'dir_path' => ( lazy_build => 1, init_arg => undef );
22             has 'named_block_regex' => ( lazy_build => 1, init_arg => undef );
23             has 'unnamed_block_regex' => ( lazy_build => 1, init_arg => undef );
24             has 'valid_flags_hash' => ( lazy_build => 1, init_arg => undef );
25              
26             # Valid Perl identifier
27             my $identifier = qr/[[:alpha:]_]\w*/;
28              
29             #
30             # BUILD
31             #
32              
33 19     19   41550 method BUILD () {
  237     237   392  
  237         330  
34              
35             # Initialize state
36 237         586 $self->{blocks} = {};
37 237         712 $self->{blocks}->{class} = '';
38 237         8111 $self->{source} = read_file( $self->source_file );
39 237         861 $self->{source} =~ s/\r\n?/\n/g;
40 237         680 $self->{line_number} = 1;
41 237         1316 $self->{methods} = { main => $self->_new_method_hash( name => 'main' ) };
42 237         1130 $self->{current_method} = $self->{methods}->{main};
43 237         8847 $self->{is_pure_perl} = $self->interp->is_pure_perl_comp_path( $self->path );
44             }
45              
46 19     19   7566 method _build_bad_attribute_hash () {
  2     2   3  
  2         2  
47 2         3 return { map { ( $_, 1 ) } @{ $self->bad_attribute_names } };
  14         66  
  2         8  
48             }
49              
50 19     19   5995 method _build_bad_method_hash () {
  13     13   19  
  13         19  
51 13         19 return { map { ( $_, 1 ) } @{ $self->bad_method_names } };
  39         399  
  13         65  
52             }
53              
54 19     19   5845 method _build_dir_path () {
  211     211   390  
  211         269  
55 211         5309 return dirname( $self->path );
56             }
57              
58 19     19   5782 method _build_named_block_regex () {
  184     184   301  
  184         270  
59 184         302 my $re = join '|', @{ $self->named_block_types };
  184         740  
60 184         6584 return qr/$re/i;
61             }
62              
63 19     19   5942 method _build_unnamed_block_regex () {
  237     237   554  
  237         328  
64 237         390 my $re = join '|', @{ $self->unnamed_block_types };
  237         905  
65 237         8581 return qr/$re/i;
66             }
67              
68 19     19   6193 method _build_valid_flags_hash () {
  8     8   13  
  8         10  
69 8         15 return { map { ( $_, 1 ) } @{ $self->valid_flags } };
  8         237  
  8         34  
70             }
71              
72             #
73             # MODIFIABLE METHODS
74             #
75              
76 19     19   6243 method bad_attribute_names () {
  2     2   3  
  2         3  
77 2         9 return [qw(args m cmeta handle render wrap main)];
78             }
79              
80 19     19   5635 method bad_method_names () {
  13     13   17  
  13         13  
81 13         53 return [qw(args m cmeta)];
82             }
83              
84 19     19   5508 method compile () {
  237     237   4819  
  237         335  
85 237         890 $self->parse();
86 211         1037 return $self->_output_compiled_component();
87             }
88              
89 19     19   6048 method named_block_types () {
  184     184   302  
  184         247  
90 184         1117 return [qw(after augment around before filter method override)];
91             }
92              
93 19     19   5615 method output_class_footer () {
  211     211   396  
  211         284  
94 211         534 return "";
95             }
96              
97 19     19   5324 method output_class_header () {
  211     211   354  
  211         275  
98 211         6486 return $self->interp->class_header;
99             }
100              
101 19     19   5530 method parse () {
  285     285   454  
  285         316  
102              
103             # We need to untaint the component source or else the regexes may fail.
104             #
105 285 50       932 ( $self->{source} ) = ( ( delete $self->{source} ) =~ /(.*)/s )
106             if taint_is_on();
107              
108 285 100       825 if ( $self->{is_pure_perl} ) {
109 15         65 $self->{source} = "<%class> " . $self->{source} . " </%class>";
110 15         52 delete( $self->{methods}->{main} );
111             }
112              
113 285         540 my $lm = '';
114 285         442 my $iter = 0;
115 285         363 while (1) {
116 998 50       2030 $self->_throw_syntax_error("parse loop iterated >1000 times - infinite loop?")
117             if ++$iter > 1000;
118 998         1406 $self->{last_match} = $lm;
119 998 100       2345 $self->_match_end && last;
120 762 100       1872 $self->_match_apply_filter_end && last;
121 739 100 100     1699 $self->_match_unnamed_block && ( $lm = 'unnamed_block' ) && next;
122 625 100 100     1904 $self->_match_named_block && ( $lm = 'named_block' ) && next;
123 592 50 50     2065 $self->_match_unknown_block && ( $lm = 'unknown_block' ) && next;
124 590 100 100     1495 $self->_match_apply_filter && ( $lm = 'apply_filter' ) && next;
125 567 100 100     1331 $self->_match_substitution && ( $lm = 'substitution' ) && next;
126 383 100 100     1127 $self->_match_component_call && ( $lm = 'component_call' ) && next;
127 350 100 100     1023 $self->_match_perl_line && ( $lm = 'perl_line' ) && next;
128 304 50 50     837 $self->_match_bad_close_tag && ( $lm = 'bad_close_tag' ) && next;
129 302 50 50     785 $self->_match_plain_text && ( $lm = 'plain_text' ) && next;
130              
131 0         0 $self->_throw_syntax_error(
132             "could not parse next element at position " . pos( $self->{source} ) );
133             }
134             }
135              
136 19     19   9645 method process_perl_code ($coderef) {
  383     383   2989  
  383         493  
  383         374  
137 383         757 return $coderef;
138             }
139              
140 19     19   5795 method unnamed_block_types () {
  237     237   339  
  237         299  
141 237         1517 return [qw(args class doc flags init perl shared text)];
142             }
143              
144 19     19   5590 method valid_flags () {
  8     8   11  
  8         16  
145 8         28 return [qw(extends)];
146             }
147              
148             #
149             # PRIVATE METHODS
150             #
151              
152 19     19   5810 method _add_to_class_block ($text) {
  4     4   5  
  4         5  
  4         3  
153              
154             # Don't add a line number comment when following a perl-line.
155             # We know a perl-line is always _one_ line, so we know that the
156             # line numbers are going to match up as long as the first line in
157             # a series has a line number comment before it. Adding a comment
158             # can break certain constructs like qw() list that spans multiple
159             # perl-lines.
160 4 100       10 if ( $self->{last_match} ne 'perl_line' ) {
161 1         2 $text = $self->_output_line_number_comment . $text;
162             }
163 4         11 $self->{blocks}->{class} .= $text;
164             }
165              
166 19     19   6236 method _add_to_current_method ($text) {
  615     615   858  
  615         829  
  615         565  
167 615 100       1622 if ( $self->{last_match} ne 'perl_line' ) {
168 589         1371 $text = $self->_output_line_number_comment . $text;
169             }
170              
171 615         2245 $self->{current_method}->{body} .= $text;
172             }
173              
174 19     19   6349 method _assert_not_nested ($block_type) {
  27     27   39  
  27         31  
  27         27  
175 27 100       75 $self->_throw_syntax_error(
176             "Cannot nest <%$block_type> block inside <%$self->{in_recursive_parse}> block")
177             if $self->{in_recursive_parse};
178             }
179              
180 19     19   6524 method _attribute_declaration ($name, $params, $line_number) {
  10     10   10  
  10         18  
  10         8  
181 10 50       287 $self->_throw_syntax_error("'$name' is reserved and cannot be used as an attribute name")
182             if $self->bad_attribute_hash->{$name};
183 10         22 return $self->_processed_perl_code(
184             sprintf(
185             "%shas '%s' => %s",
186             $self->_output_line_number_comment($line_number),
187             $name, $params
188             )
189             );
190             }
191              
192 19     19   6911 method _handle_after_block () { $self->_handle_method_modifier_block( 'after', @_ ) }
  3     3   5  
  3         4  
  3         16  
193 19     19   5820 method _handle_around_block () { $self->_handle_method_modifier_block( 'around', @_ ) }
  2     2   3  
  2         7  
  2         10  
194 19     19   5846 method _handle_augment_block () { $self->_handle_method_modifier_block( 'augment', @_ ) }
  2     2   4  
  2         2  
  2         9  
195 19     19   5738 method _handle_before_block () { $self->_handle_method_modifier_block( 'before', @_ ) }
  5     5   6  
  5         9  
  5         17  
196              
197 19     19   5626 method _handle_override_block () {
  2     2   3  
  2         2  
198 2         5 $self->_handle_method_modifier_block( 'override', @_ );
199             }
200              
201 19     19   5714 method _handle_method_modifier_block ($block_type, $contents, $name) {
  14     14   17  
  14         21  
  14         13  
202 14         15 my $modifier = $block_type;
203              
204 14 100       195 $self->_throw_syntax_error("Invalid method modifier name '$name'")
205             if $name !~ /^$identifier$/;
206              
207 13         37 $self->_assert_not_nested($block_type);
208              
209 12         22 my $method_key = "$block_type $name";
210              
211 12 100       46 $self->_throw_syntax_error("Duplicate definition of method modifier '$method_key'")
212             if exists $self->{methods}->{"$method_key"};
213              
214 11         30 my $method =
215             $self->_new_method_hash( name => $name, type => 'modifier', modifier => $modifier );
216 11         26 $self->{methods}->{"$method_key"} = $method;
217              
218 11         31 $self->_recursive_parse( $block_type, $contents, $method );
219             }
220              
221 19     19   8200 method _handle_apply_filter ($filter_expr) {
  23     23   31  
  23         30  
  23         25  
222 23         62 my $rest = substr( $self->{source}, pos( $self->{source} ) );
223 23         57 my $method = $self->_new_method_hash( type => 'apply_filter' );
224 23         54 local $self->{end_parse} = undef;
225 23         87 $self->_recursive_parse( 'filter', $rest, $method );
226 23 100       100 if ( my $incr = $self->{end_parse} ) {
227 22         58 pos( $self->{source} ) += $incr;
228             }
229             else {
230 1         5 $self->_throw_syntax_error("'{{' without matching '}}'");
231             }
232 22         58 my $code = sprintf(
233             "\$self->m->_apply_filters_to_output(%s, %s);\n",
234             $self->_processed_perl_code($filter_expr),
235             $self->_output_method($method)
236             );
237 22         59 $self->_add_to_current_method($code);
238             }
239              
240 19     19   7803 method _handle_args_block ($contents) {
  1     1   2  
  1         1  
  1         3  
241 1         6 $self->_handle_attributes_list( $contents, 'args' );
242             }
243              
244 19     19   6147 method _handle_attributes_list ($contents, $attr_type) {
  2     2   2  
  2         3  
  2         3  
245 2         11 my @lines = split( "\n", $contents );
246 2         2 my @attributes;
247 2         5 my $line_number = $self->{line_number} - 1;
248 2         4 foreach my $line (@lines) {
249 16         14 $line_number++;
250 16         32 trim($line);
251 16 100 100     82 next if $line =~ /^\#/ || $line !~ /\S/;
252 10 50       49 if (
253             my ( $name, $rest ) = (
254             $line =~ /
255             ^
256             \s* # optional whitespace
257             (?: \$\.)? # optional $. prefix
258             ([^\W\d]\w*) # valid Perl variable name
259             (?:\s*=>\s*(.*))? # optional arrow then default or attribute params
260             /x
261             )
262             )
263             {
264 10         8 my ($params);
265 10 100 66     33 if ( defined($rest) && length($rest) ) {
266 7 100       20 if ( $rest =~ /^\s*\(/ ) {
267 3         7 $params = "$rest\n;";
268             }
269             else {
270 4         12 $params = sprintf( "(default => %s\n);", $rest );
271             }
272             }
273             else {
274 3         5 $params = '();';
275             }
276 10 100       17 if ( $attr_type eq 'shared' ) {
277 3         6 $params = '(' . 'init_arg => undef, ' . substr( $params, 1 );
278             }
279 10         26 push( @attributes, $self->_attribute_declaration( $name, $params, $line_number ) );
280             }
281             else {
282 0         0 $self->{line_number} = $line_number;
283 0         0 $self->_throw_syntax_error("Invalid attribute line '$line'");
284             }
285             }
286 2         20 $self->{blocks}->{attributes} .= join( "\n", @attributes ) . "\n";
287             }
288              
289 19     19   22289 method _handle_class_block ($contents) {
  49     49   98  
  49         85  
  49         67  
290 49         265 $self->{blocks}->{class} .=
291             $self->_output_line_number_comment . $self->_processed_perl_code($contents);
292             }
293              
294 19     19   6100 method _handle_component_call ($contents) {
  32     32   45  
  32         51  
  32         34  
295 32         131 my ( $prespace, $call, $postspace ) = ( $contents =~ /(\s*)(.*)(\s*)/s );
296 32 100       108 if ( $call =~ m,^[\w/.], ) {
297 29         78 my $comma = index( $call, ',' );
298 29 100       68 $comma = length $call if $comma == -1;
299 29         154 ( my $comp = substr( $call, 0, $comma ) ) =~ s/\s+$//;
300 29         84 $call = "'$comp'" . substr( $call, $comma );
301             }
302 32         101 $call = $self->_processed_perl_code($call);
303 32         91 my $code = "\$m->comp( $prespace $call $postspace \n); ";
304              
305 32         103 $self->_add_to_current_method($code);
306             }
307              
308 19     19   8825 method _handle_doc_block () {
  2     2   3  
  2         4  
309              
310             # Don't do anything - just discard the comment.
311             }
312              
313 19     19   5722 method _handle_filter_block ($contents, $name, $arglist) {
  3     3   7  
  3         7  
  3         4  
314 3         13 my $new_contents = join( '',
315             '<%perl>',
316             'return Mason::DynamicFilter->new(',
317             'filter => sub {',
318             'my $yield = shift;',
319             '$m->capture(sub {',
320             '</%perl>', $contents, '<%perl>}); });</%perl>',
321             );
322 3         18 $self->_handle_method_block( $new_contents, $name, $arglist );
323             }
324              
325 19     19   6783 method _handle_flags_block ($contents) {
  9     9   17  
  9         15  
  9         11  
326 9         23 my $ending = qr, (?: \n | # newline or
327             (?= </%flags> ) ) # end of block (don't consume it)
328             ,ix;
329              
330 9         1460 while (
331             $contents =~ /
332             \G
333             [ \t]*
334             ([\w_]+) # identifier
335             [ \t]*=>[ \t]* # separator
336             (\S[^\n]*?) # value ( must start with a non-space char)
337             $ending
338             |
339             \G\n # a plain empty line
340             |
341             \G
342             [ \t]* # an optional comment
343             \#
344             [^\n]*
345             $ending
346             |
347             \G[ \t]+?
348             $ending
349             /xgc
350             )
351             {
352 16         169 my ( $flag, $value ) = ( $1, $2 );
353 16 50 66     164 if ( defined $flag && defined $value && length $flag && length $value ) {
      66        
      33        
354 8 100       273 if ( $self->valid_flags_hash->{$flag} ) {
355 7         442 $self->{blocks}->{flags}->{$flag} = eval($value);
356 7 100       117 die $@ if $@;
357             }
358             else {
359 1         6 $self->_throw_syntax_error("Invalid flag '$flag'");
360             }
361             }
362             }
363             }
364              
365 19     19   8803 method _handle_init_block ($contents) {
  8     8   14  
  8         15  
  8         7  
366 8         30 $self->{current_method}->{init} =
367             $self->_output_line_number_comment . $self->_processed_perl_code($contents);
368             }
369              
370 19     19   6039 method _handle_method_block ($contents, $name, $arglist) {
  17     17   25  
  17         31  
  17         24  
371 17 100       321 $self->_throw_syntax_error("Invalid method name '$name'")
372             if $name !~ /^$identifier$/;
373              
374 16 100       525 $self->_throw_syntax_error("'$name' is reserved and cannot be used as a method name")
375             if $self->bad_method_hash->{$name};
376              
377 15 100       50 $self->_throw_syntax_error("Duplicate definition of method '$name'")
378             if exists $self->{methods}->{$name};
379              
380 14         64 $self->_assert_not_nested('method');
381              
382 14         38 my $method = $self->_new_method_hash( name => $name, arglist => $arglist );
383 14         34 $self->{methods}->{$name} = $method;
384              
385 14         57 $self->_recursive_parse( 'method', $contents, $method );
386             }
387              
388 19     19   7998 method _handle_perl_block ($contents) {
  40     40   73  
  40         140  
  40         59  
389 40         153 $self->_add_to_current_method( $self->_processed_perl_code($contents) );
390             }
391              
392 19     19   5967 method _handle_perl_line ($type, $contents) {
  45     45   63  
  45         81  
  45         56  
393 45         190 my $code = $self->_processed_perl_code( $contents . "\n" );
394              
395 45 100       125 if ( $type eq 'perl' ) {
396 41         127 $self->_add_to_current_method($code);
397             }
398             else {
399 4         16 $self->_add_to_class_block($code);
400             }
401             }
402              
403 19     19   6627 method _handle_plain_text ($text) {
  301     301   359  
  301         550  
  301         303  
404              
405             # Escape single quotes and backslashes
406             #
407 301         667 $text =~ s,([\'\\]),\\$1,g;
408              
409 301         712 my $code = "\$\$_m_buffer .= '$text';\n";
410 301         847 $self->_add_to_current_method($code);
411             }
412              
413 19     19   7074 method _handle_shared_block ($contents) {
  1     1   3  
  1         2  
  1         1  
414 1         5 $self->_handle_attributes_list( $contents, 'shared' );
415             }
416              
417 19     19   6080 method _handle_substitution ($text, $filter_list) {
  178     178   250  
  178         362  
  178         193  
418              
419             # This is a comment tag if all lines of text contain only whitespace
420             # or start with whitespace and a comment marker, e.g.
421             #
422             # <%
423             # #
424             # # foo
425             # %>
426             #
427 178         983 my @lines = split( /\n/, $text );
428 178 100       305 unless ( grep { /^\s*[^\s\#]/ } @lines ) {
  180         998  
429 1         3 return;
430             }
431              
432 177         625 $text = $self->_processed_perl_code($text);
433              
434 177 100       490 if ($filter_list) {
435 12 50       30 if ( my @filters = grep { /\S/ } split( /\s*,\s*/, $filter_list ) ) {
  16         57  
436 12         14 my $filter_call_list = join( ", ", map { "\$self->$_()" } @filters );
  16         46  
437 12         43 $text =
438             sprintf( '$self->m->_apply_filters(%s, sub { local $_ = %s; defined($_) ? $_ : "" })',
439             $filter_call_list, $text );
440             }
441             }
442              
443 177         473 my $code = "for (scalar($text)) { \$\$_m_buffer .= \$_ if defined }\n";
444              
445 177         519 $self->_add_to_current_method($code);
446             }
447              
448 19     19   9829 method _handle_text_block ($contents) {
  2     2   3  
  2         3  
  2         2  
449 2         5 $contents =~ s/^\n//;
450 2         4 $contents =~ s,([\'\\]),\\$1,g;
451              
452 2         10 $self->_add_to_current_method("\$\$_m_buffer .= '$contents';\n");
453             }
454              
455 19     19   6876 method _match_apply_filter () {
  590     590   618  
  590         657  
456 590         951 my $pos = pos( $self->{source} );
457              
458             # Match % ... {{ at beginning of line
459 590 100       1707 if ( $self->{source} =~ / \G (?<=^) % ([^\n]*) \{\{ [^\S\n]* (?:\#.*)? \n /gcmx ) {
460 20         57 my ($filter_expr) = ($1);
461 20         96 $self->_handle_apply_filter($filter_expr);
462 19         102 return 1;
463             }
464              
465             # Old syntax, for backward compatibility
466             # Match <% ... { %>
467 570 100       2549 if ( $self->{source} =~ /\G(\n)? <% (.+?) (\s*\{\s*) %>(\n)?/xcgs ) {
468 5         16 my ( $preceding_newline, $filter_expr, $opening_brace, $following_newline ) =
469             ( $1, $2, $3, $4 );
470              
471             # and make sure we didn't go through a %>
472 5 100       13 if ( $filter_expr !~ /%>/ ) {
473 3         17 for ( $preceding_newline, $filter_expr, $following_newline ) {
474 9 100       21 $self->{line_number} += tr/\n// if defined($_);
475             }
476 3         9 $self->_handle_apply_filter($filter_expr);
477              
478 3         14 return 1;
479             }
480             else {
481 2         5 pos( $self->{source} ) = $pos;
482             }
483             }
484              
485 567         1618 return 0;
486             }
487              
488 19     19   9310 method _match_apply_filter_end () {
  762     762   1294  
  762         678  
489 762 100       2456 if ( $self->{source} =~ / \G (?<=^) % [ \t]+ \}\} [^\S\n]* (?:\#.*)? (?:\n\n?|\z) /gmcx ) {
490 20 100       61 if ( $self->{current_method}->{type} eq 'apply_filter' ) {
491 19         35 $self->{end_parse} = pos( $self->{source} );
492 19         123 return 1;
493             }
494             else {
495 1         5 $self->_throw_syntax_error("'}}' without matching '{{'");
496             }
497             }
498              
499             # Old syntax - <% } %> and </%> - for backward compatibility
500 742 100 100     2389 if ( $self->{current_method}->{type} eq 'apply_filter'
501             && $self->{source} =~ /\G (?: (?: <% [ \t]* \} [ \t]* %> ) | (?: <\/%> ) ) (\n?\n?)/gcx )
502             {
503 3         6 $self->{end_parse} = pos( $self->{source} );
504 3         18 return 1;
505             }
506              
507 739         1659 return 0;
508             }
509              
510 19     19   8235 method _match_block ($block_regex, $named) {
  1364     1364   1602  
  1364         1575  
  1364         1272  
511 1364         80763 my $regex = qr/
512             \G(\n?)
513             <% ($block_regex)
514             (?: \s+ ([^\s\(>]+) ([^>]*) )?
515             >
516             /x;
517 1364 100       11727 if ( $self->{source} =~ /$regex/gcs ) {
518 147         589 my ( $preceding_newline, $block_type, $name, $arglist ) = ( $1, $2, $3, $4 );
519              
520 147 100 100     585 $self->_throw_syntax_error("<%$block_type> block requires a name")
521             if ( $named && !defined($name) );
522              
523 145 100 100     694 $self->_throw_syntax_error("<%$block_type> block does not take a name")
524             if ( !$named && defined($name) );
525              
526 144         354 my $block_method = "_handle_${block_type}_block";
527              
528 144 100       318 $self->{line_number}++ if $preceding_newline;
529              
530 144         562 my ( $block_contents, $nl ) = $self->_match_block_end($block_type);
531              
532 143         726 $self->$block_method( $block_contents, $name, $arglist );
533              
534 134         575 $self->{line_number} += $block_contents =~ tr/\n//;
535 134 100       371 $self->{line_number} += length($nl) if $nl;
536              
537 134         1015 return 1;
538             }
539 1217         5289 return 0;
540             }
541              
542 19     19   8732 method _match_block_end ($block_type) {
  144     144   217  
  144         229  
  144         165  
543 144         1962 my $re = qr,\G(.*?)</%\Q$block_type\E>(\n?\n?),is;
544 144 100       1069 if ( $self->{source} =~ /$re/gc ) {
545 143         737 return ( $1, $2 );
546             }
547             else {
548 1         6 $self->_throw_syntax_error("<%$block_type> without matching </%$block_type>");
549             }
550             }
551              
552 19     19   6658 method _match_component_call () {
  383     383   463  
  383         378  
553 383 100       2095 if ( $self->{source} =~ /\G<&(?!\|)/gcs ) {
554 33 100       178 if ( $self->{source} =~ /\G(.*?)&>/gcs ) {
555 32         69 my $body = $1;
556 32         131 $self->_handle_component_call($body);
557 32         92 $self->{line_number} += $body =~ tr/\n//;
558              
559 32         175 return 1;
560             }
561             else {
562 1         5 $self->_throw_syntax_error("'<&' without matching '&>'");
563             }
564             }
565             }
566              
567 19     19   7220 method _match_end () {
  998     998   1116  
  998         875  
568 998 100       3510 if ( $self->{source} =~ /(\G\z)/gcs ) {
569 236         611 $self->{line_number} += $1 =~ tr/\n//;
570 236 50 33     1993 return defined $1 && length $1 ? $1 : 1;
571             }
572 762         1698 return 0;
573             }
574              
575 19     19   6728 method _match_named_block () {
  625     625   737  
  625         696  
576 625         20212 $self->_match_block( $self->named_block_regex, 1 );
577             }
578              
579 19     19   5405 method _match_perl_line () {
  350     350   474  
  350         435  
580 350 100       1104 if ( $self->{source} =~ /\G(?<=^)(%%?)([^\n]*)(?:\n|\z)/gcm ) {
581 46         150 my ( $percents, $line ) = ( $1, $2 );
582 46 100 100     307 if ( length($line) && $line !~ /^\s/ ) {
583 1         5 $self->_throw_syntax_error("$percents must be followed by whitespace or EOL");
584             }
585 45 100       117 if ( $percents eq '%%' ) {
586 4 50 66     20 if ( $line =~ /\{\s*$/ && $self->{source} =~ /\G(?!%%)/gcm ) {
587 0         0 $self->_throw_syntax_error("%%-lines cannot be used to surround content");
588             }
589             }
590 45 100       257 $self->_handle_perl_line( ( $percents eq '%' ? 'perl' : 'class' ), $line );
591 45         67 $self->{line_number}++;
592              
593 45         252 return 1;
594             }
595 304         904 return 0;
596             }
597              
598 19     19   8283 method _match_plain_text () {
  302     302   360  
  302         326  
599              
600             # Most of these terminator patterns actually belong to the next
601             # lexeme in the source, so we use a lookahead if we don't want to
602             # consume them. We use a lookbehind when we want to consume
603             # something in the matched text, like the newline before a '%'.
604              
605 302 50       2322 if (
606             $self->{source} =~ m{
607             \G
608             (.*?) # anything, followed by:
609             (
610             (?<=\n)(?=%) # an eval line - consume the \n
611             |
612             (?=<%\s) # a substitution tag
613             |
614             (?=[%&]>) # an end substitution or component call
615             |
616             (?=</?[%&]) # a block or call start or end
617             # - don't consume
618             |
619             \\\n # an escaped newline - throw away
620             |
621             \z # end of string
622             )
623             }xcgs
624             )
625             {
626 302         859 my ( $orig_text, $swallowed ) = ( $1, $2 );
627 302         517 my $text = $orig_text;
628              
629             # Chomp newline before block start
630             #
631 302 100       1450 if ( substr( $self->{source}, pos( $self->{source} ), 3 ) =~ /<%[a-z]/ ) {
632 15         34 chomp($text);
633             }
634 302 100       1294 $self->_handle_plain_text($text) if length $text;
635              
636             # Not checking definedness seems to cause extra lines to be
637             # counted with Perl 5.00503. I'm not sure why - dave
638 302         2028 $self->{line_number} += tr/\n// foreach grep defined, ( $orig_text, $swallowed );
639              
640 302         1725 return 1;
641             }
642              
643 0         0 return 0;
644             }
645              
646 19     19   9113 method _match_substitution () {
  567     567   651  
  567         536  
647              
648 567 100       2625 return 0 unless $self->{source} =~ /\G<%/gcs;
649              
650 184 100       4043 if (
651             $self->{source} =~ m{
652             \G
653             (\s*) # Initial whitespace
654             (.*?) # Substitution body ($1)
655             (
656             \s*
657             (?<!\|) # Not preceded by a '|'
658             \| # A '|'
659             \s*
660             ( # (Start $3)
661             $identifier # A filter name
662             (?:\s*,\s*$identifier)* # More filter names, with comma separators
663             )
664             )?
665             (\s*) # Final whitespace
666             %> # Closing tag
667             }xcigs
668             )
669             {
670 183         1073 my ( $start_ws, $body, $after_body, $filters, $end_ws ) = ( $1, $2, $3, $4, $5 );
671 183 100       1079 $self->_throw_syntax_error("found empty '<% %>' tag") unless $body =~ /\S/;
672 180 100       474 $self->_throw_syntax_error("whitespace required after '<%'") unless length($start_ws);
673             $self->{line_number} += tr/\n//
674 179         1351 foreach grep defined, ( $start_ws, $body, $after_body, $end_ws );
675 179 100       491 $self->_throw_syntax_error("whitespace required before '%>'") unless length($end_ws);
676              
677 178         725 $self->_handle_substitution( $body, $filters );
678              
679 178         1058 return 1;
680             }
681             else {
682 1         5 $self->_throw_syntax_error("'<%' without matching '%>'");
683             }
684             }
685              
686 19     19   8569 method _match_unknown_block () {
  592     592   712  
  592         750  
687 592 100       3244 if ( $self->{source} =~ /\G(?:\n?)<%([A-Za-z_]+)>/gc ) {
688 2         11 $self->_throw_syntax_error("unknown block '<%$1>'");
689             }
690             }
691              
692 19     19   6790 method _match_unnamed_block () {
  739     739   855  
  739         728  
693 739         23469 $self->_match_block( $self->unnamed_block_regex, 0 );
694             }
695              
696 19     19   5612 method _match_bad_close_tag () {
  304     304   426  
  304         393  
697 304 100       2074 if ( my ($end_tag) = ( $self->{source} =~ /\G\s*(%>|&>)/gc ) ) {
698 2         9 ( my $begin_tag = reverse($end_tag) ) =~ s/>/</;
699 2         18 $self->_throw_syntax_error("'$end_tag' without matching '$begin_tag'");
700             }
701             }
702              
703 19     19   7083 method _new_method_hash () {
  285     285   652  
  285         342  
704 285         2296 return { body => '', init => '', type => 'method', @_ };
705             }
706              
707 19     19   5522 method _output_attributes () {
  211     211   385  
  211         241  
708 211   100     1742 return $self->{blocks}->{attributes} || '';
709             }
710              
711 19     19   5958 method _output_class_block () {
  211     211   337  
  211         272  
712 211   100     1561 return $self->{blocks}->{class} || '';
713             }
714              
715 19     19   5501 method _output_class_initialization () {
  211     211   368  
  211         262  
716 211         1794 return join(
717             "\n",
718             "our (\$_class_cmeta, \$m, \$_m_buffer, \$_interp);",
719             "BEGIN { ",
720             "local \$_interp = Mason::Interp->current_load_interp;",
721             "\$_interp->component_moose_class->import;",
722             "\$_interp->component_import_class->import;",
723             "}",
724             "*m = \\\$Mason::Request::current_request;",
725             "*_m_buffer = \\\$Mason::Request::current_buffer;",
726              
727             # Must be defined here since inner relies on caller()
728             "sub _inner { inner() }"
729             );
730             }
731              
732 19     19   6182 method _output_cmeta () {
  211     211   683  
  211         315  
733 211     844   1194 my $q = sub { "'$_[0]'" };
  844         17899  
734 211         6336 my %cmeta_info = (
735             dir_path => $q->( $self->dir_path ),
736             is_top_level => $q->( $self->interp->is_top_level_comp_path( $self->path ) ),
737             path => $q->( $self->path ),
738             source_file => $q->( $self->source_file ),
739             object_file => '__FILE__',
740             class => 'CLASS',
741             interp => '$interp',
742             );
743 1477         5524 return join(
744             "\n",
745             "method _set_class_cmeta (\$interp) {",
746             "\$_class_cmeta = \$interp->component_class_meta_class->new(",
747             (
748 211         1754 map { sprintf( "'%s' => %s,", $_, $cmeta_info{$_} ) }
749             sort( keys(%cmeta_info) )
750             ),
751             ');', '}',
752             'sub _unset_class_cmeta { undef $_class_cmeta }',
753             'sub _class_cmeta { $_class_cmeta }'
754             );
755             }
756              
757 19     19   7790 method _output_compiled_component () {
  211     211   333  
  211         315  
758 678         1627 return join(
759             "\n",
760 211 100       949 map { trim($_) } grep { defined($_) && length($_) } (
  1899         4683  
761             $self->_output_flag_comment, $self->_output_class_initialization,
762             $self->output_class_header, $self->_output_global_declarations,
763             $self->_output_cmeta, $self->_output_attributes,
764             $self->_output_class_block, $self->_output_methods,
765             $self->output_class_footer,
766             )
767             ) . "\n";
768             }
769              
770 19     19   7120 method _output_flag_comment () {
  211     211   333  
  211         271  
771 211 100       1411 if ( my $flags = $self->{blocks}->{flags} ) {
772 6 50       20 if (%$flags) {
773 6         25 ( my $json = json_encode($flags) ) =~ s/\n//g;
774 6         90 return "# FLAGS: $json\n\n";
775             }
776             }
777             }
778              
779 19     19   7836 method _output_global_declaration ($spec) {
  4     4   6  
  4         5  
  4         4  
780 4         87 my ( $sigil, $name ) = $self->interp->_parse_global_spec($spec);
781 4         87 return sprintf( 'our %s%s; *%s = \%s%s::%s;' . "\n",
782             $sigil, $name, $name, $sigil, $self->interp->globals_package, $name );
783             }
784              
785 19     19   6531 method _output_global_declarations () {
  211     211   365  
  211         317  
786             return
787 211         334 join( "\n", map { $self->_output_global_declaration($_) } @{ $self->interp->allow_globals } );
  4         15  
  211         5279  
788             }
789              
790 19     19   6281 method _output_line_number_comment ($line_number) {
  657     657   721  
  657         765  
  657         629  
791 657 100       20647 if ( !$self->interp->no_source_line_numbers ) {
792 652   66     2646 $line_number ||= $self->{line_number};
793 652 50       1179 if ($line_number) {
794 652         17779 my $comment = sprintf( qq{#line %s "%s"\n}, $line_number, $self->source_file );
795 652         2008 return $comment;
796             }
797             }
798 5         12 return "";
799             }
800              
801 19     19   7167 method _output_method ($method) {
  240     240   413  
  240         387  
  240         246  
802 240         7040 my $path = $self->path;
803              
804 240         513 my $name = $method->{name};
805 240         419 my $type = $method->{type};
806 240   100     1090 my $modifier = $method->{modifier} || '';
807 240   100     1007 my $arglist = $method->{arglist} || '';
808 240         687 my $contents = join( "\n", grep { /\S/ } ( $method->{init}, $method->{body} ) );
  480         1507  
809              
810 240 100       1562 my $start =
    100          
    100          
811             $type eq 'apply_filter' ? "sub {"
812             : $modifier eq 'around' ? "around '$name' => sub {\nmy \$orig = shift; my \$self = shift;"
813             : $type eq 'modifier' ? "$modifier '$name' => sub {\nmy \$self = shift;"
814             : "method $name $arglist {";
815 240 100       568 my $end = $modifier ? "};" : "}";
816              
817 240         1934 return join(
818             "\n",
819             $start,
820              
821             # do not add a block around this, it introduces
822             # a separate scope and might break cleanup
823             # blocks (or all sort of other things!)
824             $contents,
825              
826             # don't return values explicitly. semi before return will help catch
827             # syntax errors in component body.
828             ";return;",
829             $end,
830             );
831             }
832              
833 19     19   8525 method _output_methods () {
  211     211   346  
  211         280  
834              
835             # Sort methods so that modifiers come after
836             #
837 32 50       117 my @sorted_methods_keys =
838 211         336 sort { ( index( $a, ' ' ) <=> index( $b, ' ' ) ) || $a cmp $b } keys( %{ $self->{methods} } );
  211         1156  
839             return
840 211         544 join( "\n", map { $self->_output_method( $self->{methods}->{$_} ) } @sorted_methods_keys );
  218         850  
841             }
842              
843 19     19   7306 method _processed_perl_code ($code) {
  383     383   534  
  383         650  
  383         392  
844 383         553 my $coderef = \$code;
845 383         1774 $self->process_perl_code($coderef);
846 383         2477 return $$coderef;
847             }
848              
849 19     19   6188 method _recursive_parse ($block_type, $contents, $method) {
  48     48   70  
  48         70  
  48         45  
850              
851             # Save current regex position, then locally set source to the contents and
852             # recursively parse.
853             #
854 48         104 local $self->{in_recursive_parse} = $block_type;
855              
856 48         70 my $save_pos = pos( $self->{source} );
857 48     48   252 scope_guard { pos( $self->{source} ) = $save_pos };
  48         276  
858             {
859 48         57 local $self->{source} = $contents;
  48         102  
860 48         75 local $self->{current_method} = $method;
861 48         79 local $self->{line_number} = $self->{line_number};
862 48         115 $self->parse();
863             }
864             }
865              
866 19     19   7506 method _throw_syntax_error ($msg) {
  25     25   29  
  25         36  
  25         18  
867 25         668 die sprintf( "%s at %s line %d\n", $msg, $self->source_file, $self->{line_number} );
868             }
869              
870             __PACKAGE__->meta->make_immutable();
871              
872             1;
873              
874             __END__
875              
876             =pod
877              
878             =head1 NAME
879              
880             Mason::Compilation - Performs compilation of a single component
881              
882             =head1 DESCRIPTION
883              
884             A new C<Mason::Compilation> object is created by L<Mason::Interp> to compile
885             each component.
886              
887             This class has no public API at this time.
888              
889             =head1 MODIFIABLE METHODS
890              
891             These methods are not intended to be called externally, but may be useful to
892             modify with method modifiers in L<plugins|Mason::Manual::Plugins> and
893             L<subclasses|Mason::Manual::Subclasses>. Their APIs will be kept as stable as
894             possible.
895              
896             =over
897              
898             =item bad_attribute_names ()
899              
900             A list of attribute names that should not be used because they are reserved for
901             built-in attributes or methods: C<args>, C<m>, C<cmeta>, C<render>, C<main>,
902             etc.
903              
904             =item bad_method_names ()
905              
906             A list of method names that should not be used because they are reserved for
907             built-in attributes: C<args>, C<m>, C<cmeta>, etc. Not as extensive as
908             bad_attribute_names above because methods like C<render> and C<main> can be
909             overridden but make no sense as attributes.
910              
911             =item compile ()
912              
913             The top-level method called to compile the component. Returns the generated
914             component class.
915              
916             =item named_block_types ()
917              
918             An arrayref of valid named block types: C<after>, C<filter>, C<method>, etc.
919             Add to this list if you want to create your own named blocks (i.e. blocks that
920             take a name argument).
921              
922             =item output_class_footer ()
923              
924             Perl code to be added at the bottom of the class. Empty by default.
925              
926             =item output_class_header ()
927              
928             Perl code to be added at the top of the class, just after initialization of
929             Moose, C<$m> and other required pieces. By default it consults the
930             L<class_header parameter|Mason::Interp/class_header>.
931              
932             # Add to the top of every component class:
933             # use Modern::Perl;
934             # use JSON::XS qw(encode_json decode_json);
935             #
936             override 'output_class_header' => sub {
937             return join( "\n",
938             super(),
939             'use Modern::Perl;',
940             'use JSON::XS qw(encode_json decode_json);' );
941             };
942              
943             =item process_perl_code ($coderef)
944              
945             This method is called on each distinct piece of Perl code in the component.
946             I<$coderef> is a reference to a string containing the code; the method can
947             modify the code as desired. See L<Mason::Plugin::DollarDot> for a sample usage.
948              
949             =item unnamed_block_types ()
950              
951             An arrayref of valid unnamed block types: C<args>, C<class>, C<init>, etc. Add
952             to this list if you want to create your own unnamed blocks.
953              
954             =item valid_flags ()
955              
956             An arrayref of valid flags: contains only C<extends> at time of writing. Add to
957             this list if you want to create your own flags.
958              
959             =back
960              
961             =head1 SEE ALSO
962              
963             L<Mason|Mason>
964              
965             =head1 AUTHOR
966              
967             Jonathan Swartz <swartz@pobox.com>
968              
969             =head1 COPYRIGHT AND LICENSE
970              
971             This software is copyright (c) 2012 by Jonathan Swartz.
972              
973             This is free software; you can redistribute it and/or modify it under
974             the same terms as the Perl 5 programming language system itself.
975              
976             =cut