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.23';
7 19     19   39634 use File::Basename qw(dirname);
  19         40  
  19         1498  
8 19     19   97 use Guard;
  19         30  
  19         914  
9 19     19   6984 use Mason::Component::ClassMeta;
  19         58  
  19         867  
10 19     19   154 use Mason::Util qw(dump_one_line json_encode read_file taint_is_on trim);
  19         29  
  19         1656  
11 19     19   119 use Mason::Moose;
  19         40  
  19         167  
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   43417 method BUILD () {
  237     237   419  
  237         377  
34              
35             # Initialize state
36 237         590 $self->{blocks} = {};
37 237         734 $self->{blocks}->{class} = '';
38 237         7773 $self->{source} = read_file( $self->source_file );
39 237         758 $self->{source} =~ s/\r\n?/\n/g;
40 237         525 $self->{line_number} = 1;
41 237         1288 $self->{methods} = { main => $self->_new_method_hash( name => 'main' ) };
42 237         915 $self->{current_method} = $self->{methods}->{main};
43 237         8100 $self->{is_pure_perl} = $self->interp->is_pure_perl_comp_path( $self->path );
44             }
45              
46 19     19   8492 method _build_bad_attribute_hash () {
  2     2   6  
  2         3  
47 2         8 return { map { ( $_, 1 ) } @{ $self->bad_attribute_names } };
  14         107  
  2         14  
48             }
49              
50 19     19   6274 method _build_bad_method_hash () {
  13     13   20  
  13         21  
51 13         20 return { map { ( $_, 1 ) } @{ $self->bad_method_names } };
  39         464  
  13         81  
52             }
53              
54 19     19   6096 method _build_dir_path () {
  211     211   349  
  211         310  
55 211         5136 return dirname( $self->path );
56             }
57              
58 19     19   6190 method _build_named_block_regex () {
  184     184   294  
  184         265  
59 184         275 my $re = join '|', @{ $self->named_block_types };
  184         675  
60 184         6487 return qr/$re/i;
61             }
62              
63 19     19   6251 method _build_unnamed_block_regex () {
  237     237   395  
  237         322  
64 237         331 my $re = join '|', @{ $self->unnamed_block_types };
  237         893  
65 237         9253 return qr/$re/i;
66             }
67              
68 19     19   6433 method _build_valid_flags_hash () {
  8     8   14  
  8         9  
69 8         10 return { map { ( $_, 1 ) } @{ $self->valid_flags } };
  8         226  
  8         32  
70             }
71              
72             #
73             # MODIFIABLE METHODS
74             #
75              
76 19     19   6762 method bad_attribute_names () {
  2     2   4  
  2         3  
77 2         14 return [qw(args m cmeta handle render wrap main)];
78             }
79              
80 19     19   5979 method bad_method_names () {
  13     13   23  
  13         17  
81 13         63 return [qw(args m cmeta)];
82             }
83              
84 19     19   5877 method compile () {
  237     237   412  
  237         323  
85 237         881 $self->parse();
86 211         1030 return $self->_output_compiled_component();
87             }
88              
89 19     19   6424 method named_block_types () {
  184     184   313  
  184         297  
90 184         1111 return [qw(after augment around before filter method override)];
91             }
92              
93 19     19   6043 method output_class_footer () {
  211     211   316  
  211         274  
94 211         482 return "";
95             }
96              
97 19     19   5911 method output_class_header () {
  211     211   329  
  211         263  
98 211         5844 return $self->interp->class_header;
99             }
100              
101 19     19   6194 method parse () {
  285     285   427  
  285         338  
102              
103             # We need to untaint the component source or else the regexes may fail.
104             #
105 285 50       905 ( $self->{source} ) = ( ( delete $self->{source} ) =~ /(.*)/s )
106             if taint_is_on();
107              
108 285 100       838 if ( $self->{is_pure_perl} ) {
109 15         65 $self->{source} = "<%class> " . $self->{source} . " </%class>";
110 15         40 delete( $self->{methods}->{main} );
111             }
112              
113 285         460 my $lm = '';
114 285         442 my $iter = 0;
115 285         344 while (1) {
116 998 50       2088 $self->_throw_syntax_error("parse loop iterated >1000 times - infinite loop?")
117             if ++$iter > 1000;
118 998         1411 $self->{last_match} = $lm;
119 998 100       2196 $self->_match_end && last;
120 762 100       1842 $self->_match_apply_filter_end && last;
121 739 100 100     1784 $self->_match_unnamed_block && ( $lm = 'unnamed_block' ) && next;
122 625 100 100     1756 $self->_match_named_block && ( $lm = 'named_block' ) && next;
123 592 50 50     1700 $self->_match_unknown_block && ( $lm = 'unknown_block' ) && next;
124 590 100 100     1356 $self->_match_apply_filter && ( $lm = 'apply_filter' ) && next;
125 567 100 100     1255 $self->_match_substitution && ( $lm = 'substitution' ) && next;
126 383 100 100     971 $self->_match_component_call && ( $lm = 'component_call' ) && next;
127 350 100 100     946 $self->_match_perl_line && ( $lm = 'perl_line' ) && next;
128 304 50 50     740 $self->_match_bad_close_tag && ( $lm = 'bad_close_tag' ) && next;
129 302 50 50     762 $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   10577 method process_perl_code ($coderef) {
  383     383   2806  
  383         500  
  383         348  
137 383         748 return $coderef;
138             }
139              
140 19     19   6149 method unnamed_block_types () {
  237     237   330  
  237         356  
141 237         1542 return [qw(args class doc flags init perl shared text)];
142             }
143              
144 19     19   5704 method valid_flags () {
  8     8   13  
  8         10  
145 8         28 return [qw(extends)];
146             }
147              
148             #
149             # PRIVATE METHODS
150             #
151              
152 19     19   6122 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   7071 method _add_to_current_method ($text) {
  615     615   839  
  615         773  
  615         563  
167 615 100       1594 if ( $self->{last_match} ne 'perl_line' ) {
168 589         1299 $text = $self->_output_line_number_comment . $text;
169             }
170              
171 615         2150 $self->{current_method}->{body} .= $text;
172             }
173              
174 19     19   6891 method _assert_not_nested ($block_type) {
  27     27   40  
  27         39  
  27         26  
175 27 100       95 $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   7027 method _attribute_declaration ($name, $params, $line_number) {
  10     10   13  
  10         16  
  10         9  
181 10 50       349 $self->_throw_syntax_error("'$name' is reserved and cannot be used as an attribute name")
182             if $self->bad_attribute_hash->{$name};
183 10         31 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   7036 method _handle_after_block () { $self->_handle_method_modifier_block( 'after', @_ ) }
  3     3   7  
  3         6  
  3         18  
193 19     19   6024 method _handle_around_block () { $self->_handle_method_modifier_block( 'around', @_ ) }
  2     2   4  
  2         4  
  2         10  
194 19     19   6103 method _handle_augment_block () { $self->_handle_method_modifier_block( 'augment', @_ ) }
  2     2   4  
  2         4  
  2         10  
195 19     19   5852 method _handle_before_block () { $self->_handle_method_modifier_block( 'before', @_ ) }
  5     5   9  
  5         8  
  5         28  
196              
197 19     19   5679 method _handle_override_block () {
  2     2   5  
  2         4  
198 2         5 $self->_handle_method_modifier_block( 'override', @_ );
199             }
200              
201 19     19   5929 method _handle_method_modifier_block ($block_type, $contents, $name) {
  14     14   20  
  14         33  
  14         16  
202 14         16 my $modifier = $block_type;
203              
204 14 100       223 $self->_throw_syntax_error("Invalid method modifier name '$name'")
205             if $name !~ /^$identifier$/;
206              
207 13         46 $self->_assert_not_nested($block_type);
208              
209 12         27 my $method_key = "$block_type $name";
210              
211 12 100       50 $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         32 $self->{methods}->{"$method_key"} = $method;
217              
218 11         69 $self->_recursive_parse( $block_type, $contents, $method );
219             }
220              
221 19     19   8144 method _handle_apply_filter ($filter_expr) {
  23     23   28  
  23         41  
  23         20  
222 23         69 my $rest = substr( $self->{source}, pos( $self->{source} ) );
223 23         69 my $method = $self->_new_method_hash( type => 'apply_filter' );
224 23         56 local $self->{end_parse} = undef;
225 23         95 $self->_recursive_parse( 'filter', $rest, $method );
226 23 100       192 if ( my $incr = $self->{end_parse} ) {
227 22         53 pos( $self->{source} ) += $incr;
228             }
229             else {
230 1         8 $self->_throw_syntax_error("'{{' without matching '}}'");
231             }
232 22         65 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         141 $self->_add_to_current_method($code);
238             }
239              
240 19     19   8435 method _handle_args_block ($contents) {
  1     1   3  
  1         2  
  1         2  
241 1         8 $self->_handle_attributes_list( $contents, 'args' );
242             }
243              
244 19     19   6739 method _handle_attributes_list ($contents, $attr_type) {
  2     2   4  
  2         6  
  2         3  
245 2         14 my @lines = split( "\n", $contents );
246 2         4 my @attributes;
247 2         6 my $line_number = $self->{line_number} - 1;
248 2         5 foreach my $line (@lines) {
249 16         20 $line_number++;
250 16         75 trim($line);
251 16 100 100     100 next if $line =~ /^\#/ || $line !~ /\S/;
252 10 50       62 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         13 my ($params);
265 10 100 66     35 if ( defined($rest) && length($rest) ) {
266 7 100       20 if ( $rest =~ /^\s*\(/ ) {
267 3         7 $params = "$rest\n;";
268             }
269             else {
270 4         15 $params = sprintf( "(default => %s\n);", $rest );
271             }
272             }
273             else {
274 3         34 $params = '();';
275             }
276 10 100       24 if ( $attr_type eq 'shared' ) {
277 3         7 $params = '(' . 'init_arg => undef, ' . substr( $params, 1 );
278             }
279 10         29 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         22 $self->{blocks}->{attributes} .= join( "\n", @attributes ) . "\n";
287             }
288              
289 19     19   22545 method _handle_class_block ($contents) {
  49     49   82  
  49         90  
  49         75  
290 49         295 $self->{blocks}->{class} .=
291             $self->_output_line_number_comment . $self->_processed_perl_code($contents);
292             }
293              
294 19     19   6600 method _handle_component_call ($contents) {
  32     32   40  
  32         55  
  32         35  
295 32         140 my ( $prespace, $call, $postspace ) = ( $contents =~ /(\s*)(.*)(\s*)/s );
296 32 100       121 if ( $call =~ m,^[\w/.], ) {
297 29         74 my $comma = index( $call, ',' );
298 29 100       115 $comma = length $call if $comma == -1;
299 29         132 ( my $comp = substr( $call, 0, $comma ) ) =~ s/\s+$//;
300 29         94 $call = "'$comp'" . substr( $call, $comma );
301             }
302 32         102 $call = $self->_processed_perl_code($call);
303 32         100 my $code = "\$m->comp( $prespace $call $postspace \n); ";
304              
305 32         108 $self->_add_to_current_method($code);
306             }
307              
308 19     19   9345 method _handle_doc_block () {
  2     2   5  
  2         4  
309              
310             # Don't do anything - just discard the comment.
311             }
312              
313 19     19   5867 method _handle_filter_block ($contents, $name, $arglist) {
  3     3   6  
  3         6  
  3         6  
314 3         15 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   7207 method _handle_flags_block ($contents) {
  9     9   17  
  9         17  
  9         12  
326 9         29 my $ending = qr, (?: \n | # newline or
327             (?= </%flags> ) ) # end of block (don't consume it)
328             ,ix;
329              
330 9         1466 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         174 my ( $flag, $value ) = ( $1, $2 );
353 16 50 66     174 if ( defined $flag && defined $value && length $flag && length $value ) {
      66        
      33        
354 8 100       273 if ( $self->valid_flags_hash->{$flag} ) {
355 7         458 $self->{blocks}->{flags}->{$flag} = eval($value);
356 7 100       124 die $@ if $@;
357             }
358             else {
359 1         8 $self->_throw_syntax_error("Invalid flag '$flag'");
360             }
361             }
362             }
363             }
364              
365 19     19   22136 method _handle_init_block ($contents) {
  8     8   13  
  8         13  
  8         8  
366 8         26 $self->{current_method}->{init} =
367             $self->_output_line_number_comment . $self->_processed_perl_code($contents);
368             }
369              
370 19     19   8989 method _handle_method_block ($contents, $name, $arglist) {
  17     17   30  
  17         38  
  17         21  
371 17 100       341 $self->_throw_syntax_error("Invalid method name '$name'")
372             if $name !~ /^$identifier$/;
373              
374 16 100       529 $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       57 $self->_throw_syntax_error("Duplicate definition of method '$name'")
378             if exists $self->{methods}->{$name};
379              
380 14         72 $self->_assert_not_nested('method');
381              
382 14         40 my $method = $self->_new_method_hash( name => $name, arglist => $arglist );
383 14         35 $self->{methods}->{$name} = $method;
384              
385 14         71 $self->_recursive_parse( 'method', $contents, $method );
386             }
387              
388 19     19   23434 method _handle_perl_block ($contents) {
  40     40   78  
  40         64  
  40         58  
389 40         140 $self->_add_to_current_method( $self->_processed_perl_code($contents) );
390             }
391              
392 19     19   6428 method _handle_perl_line ($type, $contents) {
  45     45   70  
  45         80  
  45         55  
393 45         202 my $code = $self->_processed_perl_code( $contents . "\n" );
394              
395 45 100       127 if ( $type eq 'perl' ) {
396 41         128 $self->_add_to_current_method($code);
397             }
398             else {
399 4         12 $self->_add_to_class_block($code);
400             }
401             }
402              
403 19     19   7021 method _handle_plain_text ($text) {
  301     301   346  
  301         416  
  301         286  
404              
405             # Escape single quotes and backslashes
406             #
407 301         672 $text =~ s,([\'\\]),\\$1,g;
408              
409 301         649 my $code = "\$\$_m_buffer .= '$text';\n";
410 301         802 $self->_add_to_current_method($code);
411             }
412              
413 19     19   7389 method _handle_shared_block ($contents) {
  1     1   3  
  1         3  
  1         1  
414 1         6 $self->_handle_attributes_list( $contents, 'shared' );
415             }
416              
417 19     19   6623 method _handle_substitution ($text, $filter_list) {
  178     178   243  
  178         272  
  178         166  
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         582 my @lines = split( /\n/, $text );
428 178 100       262 unless ( grep { /^\s*[^\s\#]/ } @lines ) {
  180         975  
429 1         3 return;
430             }
431              
432 177         485 $text = $self->_processed_perl_code($text);
433              
434 177 100       412 if ($filter_list) {
435 12 50       28 if ( my @filters = grep { /\S/ } split( /\s*,\s*/, $filter_list ) ) {
  16         53  
436 12         14 my $filter_call_list = join( ", ", map { "\$self->$_()" } @filters );
  16         38  
437 12         40 $text =
438             sprintf( '$self->m->_apply_filters(%s, sub { local $_ = %s; defined($_) ? $_ : "" })',
439             $filter_call_list, $text );
440             }
441             }
442              
443 177         432 my $code = "for (scalar($text)) { \$\$_m_buffer .= \$_ if defined }\n";
444              
445 177         529 $self->_add_to_current_method($code);
446             }
447              
448 19     19   10211 method _handle_text_block ($contents) {
  2     2   4  
  2         4  
  2         2  
449 2         6 $contents =~ s/^\n//;
450 2         5 $contents =~ s,([\'\\]),\\$1,g;
451              
452 2         10 $self->_add_to_current_method("\$\$_m_buffer .= '$contents';\n");
453             }
454              
455 19     19   7266 method _match_apply_filter () {
  590     590   628  
  590         589  
456 590         985 my $pos = pos( $self->{source} );
457              
458             # Match % ... {{ at beginning of line
459 590 100       1551 if ( $self->{source} =~ / \G (?<=^) % ([^\n]*) \{\{ [^\S\n]* (?:\#.*)? \n /gcmx ) {
460 20         58 my ($filter_expr) = ($1);
461 20         101 $self->_handle_apply_filter($filter_expr);
462 19         98 return 1;
463             }
464              
465             # Old syntax, for backward compatibility
466             # Match <% ... { %>
467 570 100       2576 if ( $self->{source} =~ /\G(\n)? <% (.+?) (\s*\{\s*) %>(\n)?/xcgs ) {
468 5         17 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       14 if ( $filter_expr !~ /%>/ ) {
473 3         7 for ( $preceding_newline, $filter_expr, $following_newline ) {
474 9 100       18 $self->{line_number} += tr/\n// if defined($_);
475             }
476 3         9 $self->_handle_apply_filter($filter_expr);
477              
478 3         13 return 1;
479             }
480             else {
481 2         6 pos( $self->{source} ) = $pos;
482             }
483             }
484              
485 567         1446 return 0;
486             }
487              
488 19     19   10087 method _match_apply_filter_end () {
  762     762   1160  
  762         683  
489 762 100       1982 if ( $self->{source} =~ / \G (?<=^) % [ \t]+ \}\} [^\S\n]* (?:\#.*)? (?:\n\n?|\z) /gmcx ) {
490 20 100       77 if ( $self->{current_method}->{type} eq 'apply_filter' ) {
491 19         40 $self->{end_parse} = pos( $self->{source} );
492 19         136 return 1;
493             }
494             else {
495 1         8 $self->_throw_syntax_error("'}}' without matching '{{'");
496             }
497             }
498              
499             # Old syntax - <% } %> and </%> - for backward compatibility
500 742 100 100     2399 if ( $self->{current_method}->{type} eq 'apply_filter'
501             && $self->{source} =~ /\G (?: (?: <% [ \t]* \} [ \t]* %> ) | (?: <\/%> ) ) (\n?\n?)/gcx )
502             {
503 3         5 $self->{end_parse} = pos( $self->{source} );
504 3         19 return 1;
505             }
506              
507 739         1494 return 0;
508             }
509              
510 19     19   9214 method _match_block ($block_regex, $named) {
  1364     1364   1636  
  1364         1526  
  1364         1151  
511 1364         73364 my $regex = qr/
512             \G(\n?)
513             <% ($block_regex)
514             (?: \s+ ([^\s\(>]+) ([^>]*) )?
515             >
516             /x;
517 1364 100       10949 if ( $self->{source} =~ /$regex/gcs ) {
518 147         618 my ( $preceding_newline, $block_type, $name, $arglist ) = ( $1, $2, $3, $4 );
519              
520 147 100 100     549 $self->_throw_syntax_error("<%$block_type> block requires a name")
521             if ( $named && !defined($name) );
522              
523 145 100 100     799 $self->_throw_syntax_error("<%$block_type> block does not take a name")
524             if ( !$named && defined($name) );
525              
526 144         411 my $block_method = "_handle_${block_type}_block";
527              
528 144 100       345 $self->{line_number}++ if $preceding_newline;
529              
530 144         613 my ( $block_contents, $nl ) = $self->_match_block_end($block_type);
531              
532 143         765 $self->$block_method( $block_contents, $name, $arglist );
533              
534 134         509 $self->{line_number} += $block_contents =~ tr/\n//;
535 134 100       374 $self->{line_number} += length($nl) if $nl;
536              
537 134         997 return 1;
538             }
539 1217         5032 return 0;
540             }
541              
542 19     19   9778 method _match_block_end ($block_type) {
  144     144   217  
  144         230  
  144         167  
543 144         2086 my $re = qr,\G(.*?)</%\Q$block_type\E>(\n?\n?),is;
544 144 100       1152 if ( $self->{source} =~ /$re/gc ) {
545 143         718 return ( $1, $2 );
546             }
547             else {
548 1         7 $self->_throw_syntax_error("<%$block_type> without matching </%$block_type>");
549             }
550             }
551              
552 19     19   7536 method _match_component_call () {
  383     383   477  
  383         377  
553 383 100       1813 if ( $self->{source} =~ /\G<&(?!\|)/gcs ) {
554 33 100       192 if ( $self->{source} =~ /\G(.*?)&>/gcs ) {
555 32         75 my $body = $1;
556 32         134 $self->_handle_component_call($body);
557 32         86 $self->{line_number} += $body =~ tr/\n//;
558              
559 32         197 return 1;
560             }
561             else {
562 1         6 $self->_throw_syntax_error("'<&' without matching '&>'");
563             }
564             }
565             }
566              
567 19     19   19101 method _match_end () {
  998     998   1086  
  998         968  
568 998 100       3456 if ( $self->{source} =~ /(\G\z)/gcs ) {
569 236         588 $self->{line_number} += $1 =~ tr/\n//;
570 236 50 33     1892 return defined $1 && length $1 ? $1 : 1;
571             }
572 762         1685 return 0;
573             }
574              
575 19     19   7112 method _match_named_block () {
  625     625   836  
  625         553  
576 625         19062 $self->_match_block( $self->named_block_regex, 1 );
577             }
578              
579 19     19   6304 method _match_perl_line () {
  350     350   405  
  350         380  
580 350 100       1124 if ( $self->{source} =~ /\G(?<=^)(%%?)([^\n]*)(?:\n|\z)/gcm ) {
581 46         150 my ( $percents, $line ) = ( $1, $2 );
582 46 100 100     326 if ( length($line) && $line !~ /^\s/ ) {
583 1         6 $self->_throw_syntax_error("$percents must be followed by whitespace or EOL");
584             }
585 45 100       129 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       254 $self->_handle_perl_line( ( $percents eq '%' ? 'perl' : 'class' ), $line );
591 45         71 $self->{line_number}++;
592              
593 45         247 return 1;
594             }
595 304         810 return 0;
596             }
597              
598 19     19   9891 method _match_plain_text () {
  302     302   427  
  302         295  
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       2269 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         849 my ( $orig_text, $swallowed ) = ( $1, $2 );
627 302         408 my $text = $orig_text;
628              
629             # Chomp newline before block start
630             #
631 302 100       1282 if ( substr( $self->{source}, pos( $self->{source} ), 3 ) =~ /<%[a-z]/ ) {
632 15         40 chomp($text);
633             }
634 302 100       1298 $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         1868 $self->{line_number} += tr/\n// foreach grep defined, ( $orig_text, $swallowed );
639              
640 302         1664 return 1;
641             }
642              
643 0         0 return 0;
644             }
645              
646 19     19   9225 method _match_substitution () {
  567     567   637  
  567         534  
647              
648 567 100       2553 return 0 unless $self->{source} =~ /\G<%/gcs;
649              
650 184 100       3598 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         795 my ( $start_ws, $body, $after_body, $filters, $end_ws ) = ( $1, $2, $3, $4, $5 );
671 183 100       775 $self->_throw_syntax_error("found empty '<% %>' tag") unless $body =~ /\S/;
672 180 100       407 $self->_throw_syntax_error("whitespace required after '<%'") unless length($start_ws);
673             $self->{line_number} += tr/\n//
674 179         1137 foreach grep defined, ( $start_ws, $body, $after_body, $end_ws );
675 179 100       434 $self->_throw_syntax_error("whitespace required before '%>'") unless length($end_ws);
676              
677 178         688 $self->_handle_substitution( $body, $filters );
678              
679 178         1353 return 1;
680             }
681             else {
682 1         6 $self->_throw_syntax_error("'<%' without matching '%>'");
683             }
684             }
685              
686 19     19   11195 method _match_unknown_block () {
  592     592   700  
  592         591  
687 592 100       2944 if ( $self->{source} =~ /\G(?:\n?)<%([A-Za-z_]+)>/gc ) {
688 2         15 $self->_throw_syntax_error("unknown block '<%$1>'");
689             }
690             }
691              
692 19     19   7261 method _match_unnamed_block () {
  739     739   826  
  739         737  
693 739         22676 $self->_match_block( $self->unnamed_block_regex, 0 );
694             }
695              
696 19     19   7517 method _match_bad_close_tag () {
  304     304   382  
  304         309  
697 304 100       1977 if ( my ($end_tag) = ( $self->{source} =~ /\G\s*(%>|&>)/gc ) ) {
698 2         11 ( 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   7707 method _new_method_hash () {
  285     285   439  
  285         348  
704 285         2173 return { body => '', init => '', type => 'method', @_ };
705             }
706              
707 19     19   7604 method _output_attributes () {
  211     211   358  
  211         271  
708 211   100     1684 return $self->{blocks}->{attributes} || '';
709             }
710              
711 19     19   8912 method _output_class_block () {
  211     211   379  
  211         276  
712 211   100     1512 return $self->{blocks}->{class} || '';
713             }
714              
715 19     19   7233 method _output_class_initialization () {
  211     211   369  
  211         259  
716 211         1671 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   6875 method _output_cmeta () {
  211     211   390  
  211         647  
733 211     844   1056 my $q = sub { "'$_[0]'" };
  844         17569  
734 211         5855 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         5131 return join(
744             "\n",
745             "method _set_class_cmeta (\$interp) {",
746             "\$_class_cmeta = \$interp->component_class_meta_class->new(",
747             (
748 211         1555 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   10548 method _output_compiled_component () {
  211     211   373  
  211         313  
758 678         1468 return join(
759             "\n",
760 211 100       922 map { trim($_) } grep { defined($_) && length($_) } (
  1899         4677  
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   8340 method _output_flag_comment () {
  211     211   339  
  211         301  
771 211 100       1373 if ( my $flags = $self->{blocks}->{flags} ) {
772 6 50       25 if (%$flags) {
773 6         26 ( my $json = json_encode($flags) ) =~ s/\n//g;
774 6         132 return "# FLAGS: $json\n\n";
775             }
776             }
777             }
778              
779 19     19   9188 method _output_global_declaration ($spec) {
  4     4   7  
  4         5  
  4         3  
780 4         83 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   7195 method _output_global_declarations () {
  211     211   330  
  211         363  
786             return
787 211         328 join( "\n", map { $self->_output_global_declaration($_) } @{ $self->interp->allow_globals } );
  4         10  
  211         5082  
788             }
789              
790 19     19   8220 method _output_line_number_comment ($line_number) {
  657     657   782  
  657         758  
  657         625  
791 657 100       19106 if ( !$self->interp->no_source_line_numbers ) {
792 652   66     2680 $line_number ||= $self->{line_number};
793 652 50       1196 if ($line_number) {
794 652         16993 my $comment = sprintf( qq{#line %s "%s"\n}, $line_number, $self->source_file );
795 652         2114 return $comment;
796             }
797             }
798 5         15 return "";
799             }
800              
801 19     19   8827 method _output_method ($method) {
  240     240   330  
  240         358  
  240         275  
802 240         6756 my $path = $self->path;
803              
804 240         498 my $name = $method->{name};
805 240         385 my $type = $method->{type};
806 240   100     978 my $modifier = $method->{modifier} || '';
807 240   100     1010 my $arglist = $method->{arglist} || '';
808 240         582 my $contents = join( "\n", grep { /\S/ } ( $method->{init}, $method->{body} ) );
  480         1449  
809              
810 240 100       1483 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       541 my $end = $modifier ? "};" : "}";
816              
817 240         1978 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   10329 method _output_methods () {
  211     211   297  
  211         285  
834              
835             # Sort methods so that modifiers come after
836             #
837 32 50       124 my @sorted_methods_keys =
838 211         357 sort { ( index( $a, ' ' ) <=> index( $b, ' ' ) ) || $a cmp $b } keys( %{ $self->{methods} } );
  211         844  
839             return
840 211         554 join( "\n", map { $self->_output_method( $self->{methods}->{$_} ) } @sorted_methods_keys );
  218         843  
841             }
842              
843 19     19   7707 method _processed_perl_code ($code) {
  383     383   487  
  383         588  
  383         371  
844 383         494 my $coderef = \$code;
845 383         1543 $self->process_perl_code($coderef);
846 383         2260 return $$coderef;
847             }
848              
849 19     19   8860 method _recursive_parse ($block_type, $contents, $method) {
  48     48   59  
  48         84  
  48         62  
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         94 my $save_pos = pos( $self->{source} );
857 48     48   354 scope_guard { pos( $self->{source} ) = $save_pos };
  48         299  
858             {
859 48         55 local $self->{source} = $contents;
  48         115  
860 48         80 local $self->{current_method} = $method;
861 48         95 local $self->{line_number} = $self->{line_number};
862 48         142 $self->parse();
863             }
864             }
865              
866 19     19   9087 method _throw_syntax_error ($msg) {
  25     25   48  
  25         30  
  25         28  
867 25         753 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