File Coverage

blib/lib/HTML/Mason/Lexer.pm
Criterion Covered Total %
statement 169 179 94.4
branch 73 88 82.9
condition 21 38 55.2
subroutine 33 33 100.0
pod 4 25 16.0
total 300 363 82.6


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 HTML::Mason::Lexer;
6             $HTML::Mason::Lexer::VERSION = '1.60';
7 30     30   204 use strict;
  30         72  
  30         849  
8 30     30   154 use warnings;
  30         67  
  30         946  
9              
10 30     30   186 use HTML::Mason::Exceptions( abbr => [qw(param_error syntax_error error)] );
  30         61  
  30         255  
11              
12 30     30   199 use HTML::Mason::Tools qw( taint_is_on );
  30         94  
  30         1613  
13              
14 30     30   253 use Params::Validate qw(:all);
  30         87  
  30         6249  
15             Params::Validate::validation_options( on_fail => sub { param_error join '', @_ } );
16              
17 30     30   257 use Class::Container;
  30         83  
  30         1054  
18 30     30   177 use base qw(Class::Container);
  30         65  
  30         93879  
19              
20             # This is a block name and what method should be called to lex its
21             # contents if it is encountered. 'def' & 'method' blocks are special
22             # cases we actually call ->start again to recursively parse the
23             # contents of a subcomponent/method. Theoretically, adding a block is
24             # as simple as adding an entry to this hash, and possibly a new
25             # contents lexing methods.
26             my %blocks = ( args => 'variable_list_block',
27             attr => 'key_val_block',
28             flags => 'key_val_block',
29             cleanup => 'raw_block',
30             doc => 'doc_block',
31             filter => 'raw_block',
32             init => 'raw_block',
33             once => 'raw_block',
34             perl => 'raw_block',
35             shared => 'raw_block',
36             text => 'text_block',
37             );
38              
39             sub block_names
40             {
41 30     30 0 208 return keys %blocks;
42             }
43              
44             sub block_body_method
45             {
46 265     265 0 732 return $blocks{ $_[1] };
47             }
48              
49             {
50             my $blocks_re;
51              
52             my $re = join '|', __PACKAGE__->block_names;
53             $blocks_re = qr/$re/i;
54              
55             sub blocks_regex
56             {
57 2656     2656 0 3980 return $blocks_re;
58             }
59             }
60              
61             sub lex
62             {
63 547     547 1 971 my $self = shift;
64 547         13259 my %p = validate(@_,
65             {comp_source => SCALAR|SCALARREF,
66             name => SCALAR,
67             compiler => {isa => 'HTML::Mason::Compiler'}}
68             );
69              
70             # Note - we could improve memory usage here if we didn't make a
71             # copy of the scalarref, but that will take some more work to get
72             # it working
73 547 50       3822 $p{comp_source} = ${$p{comp_source}} if ref $p{comp_source};
  547         1616  
74              
75             # Holds information about the current lex. Make it local() so
76             # we're fully re-entrant.
77 547         1447 local $self->{current} = \%p;
78 547         933 my $current = $self->{current}; # For convenience
79              
80             # Clean up Mac and DOS line endings
81 547         1684 $current->{comp_source} =~ s/\r\n?/\n/g;
82              
83             # Initialize lexer state
84 547         1102 $current->{lines} = 1;
85 547         1210 $current->{in_def} = $current->{in_method} = 0;
86              
87             # This will be overridden if entering a def or method section.
88 547         2482 $current->{ending} = qr/\G\z/;
89              
90             # We need to untaint the component or else the regexes will fail
91             # to a Perl bug. The delete is important because we need to
92             # create an entirely new scalar, not just modify the existing one.
93 547 100       1708 ($current->{comp_source}) = (delete $current->{comp_source}) =~ /(.*)/s
94             if taint_is_on;
95              
96             eval
97 547         958 {
98 547         1958 $current->{compiler}->start_component;
99 547         1422 $self->start;
100             };
101 547         1191 my $err = $@;
102             # Always call end_component, but throw the first error
103             eval
104 547         969 {
105 547         1927 $current->{compiler}->end_component;
106             };
107 547   66     2440 $err ||= $@;
108              
109 547         1637 rethrow_exception $err;
110             }
111              
112             sub start
113             {
114 661     661 0 1061 my $self = shift;
115              
116 661         950 my $end;
117 661         1017 while (1)
118             {
119 3299 100       6514 last if $end = $self->match_end;
120              
121 2656 100       5471 $self->match_block && next;
122              
123 2391 100       5746 $self->match_named_block && next;
124              
125 2271 100       4683 $self->match_substitute && next;
126              
127 1881 100       3677 $self->match_comp_call && next;
128              
129 1665 100       3563 $self->match_perl_line && next;
130              
131 1270 100       2690 $self->match_comp_content_call && next;
132              
133 1231 100       2494 $self->match_comp_content_call_end && next;
134              
135 1192 50       2440 $self->match_text && next;
136              
137 0 0 0     0 if ( ( $self->{current}{in_def} || $self->{current}{in_method} ) &&
      0        
138             $self->{current}{comp_source} =~ /\G\z/ )
139             {
140 0 0       0 my $type = $self->{current}{in_def} ? 'def' : 'method';
141 0         0 $self->throw_syntax_error("Missing closing tag");
142             }
143              
144 0 0       0 last if $self->{current}{comp_source} =~ /\G\z/;
145              
146             # We should never get here - if we do, we're in an infinite loop.
147 0         0 $self->throw_syntax_error("Infinite parsing loop encountered - Lexer bug?");
148             }
149              
150 643 100 100     3322 if ( $self->{current}{in_def} || $self->{current}{in_method} )
151             {
152 113 100       362 my $type = $self->{current}{in_def} ? 'def' : 'method';
153 113 50       1122 unless ( $end =~ m,\n?,i )
154             {
155 0         0 my $block_name = $self->{current}{"in_$type"};
156 0         0 $self->throw_syntax_error("No tag for <%$type $block_name> block");
157             }
158             }
159             }
160              
161             sub match_block
162             {
163 2656     2656 0 3681 my $self = shift;
164              
165 2656         4617 my $blocks_re = $self->blocks_regex;
166              
167 2656 100       16616 if ( $self->{current}{comp_source} =~ /\G<%($blocks_re)>/igcs )
168             {
169 265         951 my $type = lc $1;
170 265         1268 $self->{current}{compiler}->start_block( block_type => $type );
171              
172 265         747 my $method = $self->block_body_method($type);
173 265         1338 $self->$method( {block_type => $type} );
174              
175 263         1000 return 1;
176             }
177             }
178              
179             sub generic_block
180             {
181 167     167 0 455 my ($self, $method, $p) = @_;
182              
183 167         339 $p->{allow_text} = 1;
184 167         441 my ($block, $nl) = $self->match_block_end( $p );
185              
186             $self->{current}{compiler}->$method( block_type => $p->{block_type},
187 167         1027 block => $block );
188              
189 167         539 $self->{current}{lines} += $block =~ tr/\n//;
190 167 100       472 $self->{current}{lines}++ if $nl;
191              
192 167         657 $self->{current}{compiler}->end_block( block_type => $p->{block_type} );
193             }
194              
195             sub text_block
196             {
197 2     2 0 6 my $self = shift;
198 2         13 $self->generic_block('text_block', @_);
199             }
200              
201             sub raw_block
202             {
203 163     163 0 314 my $self = shift;
204 163         668 $self->generic_block('raw_block', @_);
205             }
206              
207             sub doc_block
208             {
209 2     2 0 7 my $self = shift;
210 2         8 $self->generic_block('doc_block', @_);
211             }
212              
213             sub variable_list_block
214             {
215 53     53 0 148 my ($self, $p) = @_;
216              
217 53         576 my $ending = qr/ \n | <\/%\Q$p->{block_type}\E> /ix;
218 53         2521 while ( $self->{current}{comp_source} =~ m,
219             \G # last pos matched
220             (?:
221             [ \t]*
222             ( [\$\@\%] ) # variable type
223             ( [^\W\d]\w* ) # only allows valid Perl variable names
224             [ \t]*
225             # if we have a default arg we'll suck up
226             # any comment it has as part of the default
227             # otherwise explcitly search for a comment
228             (?:
229             (?: # this entire entire piece is optional
230             =>
231             ( [^\n]+? ) # default value
232             )
233             |
234             (?: # an optional comment
235             [ \t]*
236             \#
237             [^\n]*
238             )
239             )?
240             (?= $ending )
241             |
242             [ \t]* # a comment line
243             \#
244             [^\n]*
245             (?= $ending )
246             |
247             [ \t]* # just space
248             )
249             (\n | # newline or
250             (?= <\/%\Q$p->{block_type}\E> ) ) # end of block (don't consume it)
251             ,ixgc
252             )
253             {
254 187 50 66     1273 if ( defined $1 && defined $2 && length $1 && length $2 )
      66        
      33        
255             {
256             $self->{current}{compiler}->variable_declaration( block_type => $p->{block_type},
257 85         485 type => $1,
258             name => $2,
259             default => $3,
260             );
261             }
262              
263 187 100       1963 $self->{current}{lines}++ if $4;
264             }
265              
266 53         176 $p->{allow_text} = 0;
267 53         227 my $nl = $self->match_block_end( $p );
268 51 100       174 $self->{current}{lines}++ if $nl;
269              
270 51         250 $self->{current}{compiler}->end_block( block_type => $p->{block_type} );
271             }
272              
273             sub key_val_block
274             {
275 45     45 0 111 my ($self, $p) = @_;
276              
277 45         855 my $ending = qr, (?: \n | # newline or
278             (?= {block_type}\E> ) ) # end of block (don't consume it)
279             ,ix;
280              
281 45         3938 while ( $self->{current}{comp_source} =~ /
282             \G
283             [ \t]*
284             ([\w_]+) # identifier
285             [ \t]*=>[ \t]* # separator
286             (\S[^\n]*?) # value ( must start with a non-space char)
287             $ending
288             |
289             \G\n # a plain empty line
290             |
291             \G
292             [ \t]* # an optional comment
293             \#
294             [^\n]*
295             $ending
296             |
297             \G[ \t]+?
298             $ending
299             /xgc )
300             {
301 107 50 66     778 if ( defined $1 && defined $2 && length $1 && length $2 )
      66        
      33        
302             {
303             $self->{current}{compiler}->key_value_pair( block_type => $p->{block_type},
304 62         318 key => $1,
305             value => $2
306             );
307             }
308              
309 107         1621 $self->{current}{lines}++;
310             }
311              
312 45         122 $p->{allow_text} = 0;
313 45         151 my $nl = $self->match_block_end( $p );
314 45 100       131 $self->{current}{lines}++ if $nl;
315              
316 45         185 $self->{current}{compiler}->end_block( block_type => $p->{block_type} );
317             }
318              
319             sub match_block_end
320             {
321 265     265 0 557 my ($self, $p) = @_;
322              
323 265 100       4379 my $re = $p->{allow_text} ? qr,\G(.*?){block_type}\E>(\n?),is
324             : qr,\G\s*{block_type}\E>(\n?),is;
325 265 100       2159 if ( $self->{current}{comp_source} =~ /$re/gc )
326             {
327 263 100       1720 return $p->{allow_text} ? ($1, $2) : $1;
328             }
329             else
330             {
331 2         19 $self->throw_syntax_error("Invalid <%$p->{block_type}> section line");
332             }
333             }
334              
335             sub match_named_block
336             {
337 2391     2391 0 4556 my ($self, $p) = @_;
338              
339 2391 100       9155 if ( $self->{current}{comp_source} =~ /\G<%(def|method)(?:\s+([^\n]+?))?\s*>/igcs )
340             {
341 120         573 my ($type, $name) = (lc $1, $2);
342              
343 120 100 66     618 $self->throw_syntax_error("$type block without a name")
344             unless defined $name && length $name;
345              
346 119         672 $self->{current}{compiler}->start_named_block( block_type => $type,
347             name => $name );
348              
349             # This will cause ->start to return once it hits the
350             # appropriate ending tag.
351 114         1256 local $self->{current}{ending} = qr,\G\n?,i;
352              
353 114         443 local $self->{current}{"in_$type"} = $name;
354              
355 114         472 $self->start();
356              
357 113         580 $self->{current}{compiler}->end_named_block( block_type => $type );
358              
359 113         527 return 1;
360             }
361             }
362              
363             # Like [a-zA-Z_] but respects locales
364             my $flag = qr/[[:alpha:]_]\w*/;
365 784     784 0 1557 sub escape_flag_regex { $flag }
366              
367             sub match_substitute
368             {
369             # This routine relies on there *not* to be an opening <%foo> tag
370             # present, so match_block() must happen first.
371            
372 2271     2271 0 3476 my $self = shift;
373              
374 2271 100       7069 return 0 unless $self->{current}{comp_source} =~ /\G<%/gcs;
375              
376 390 100       7566 if ( $self->{current}{comp_source} =~
377             m{
378             \G
379             (.+?) # Substitution body ($1)
380             (
381             \s*
382             (?
383             \| # A '|'
384             \s*
385             ( # (Start $3)
386             $flag # A flag
387             (?:\s*,\s*$flag)* # More flags, with comma separators
388             )
389             \s*
390             )?
391             %> # Closing tag
392             }xcigs )
393             {
394 387         2129 $self->{current}{lines} += tr/\n// foreach grep defined, ($1, $2);
395              
396 387         1659 $self->{current}{compiler}->substitution( substitution => $1,
397             escape => $3 );
398 387         1120 return 1;
399             }
400             else
401             {
402 3         19 $self->throw_syntax_error("'<%' without matching '%>'");
403             }
404             }
405              
406             sub match_comp_call
407             {
408 1881     1881 0 2632 my $self = shift;
409              
410 1881 100       6466 if ( $self->{current}{comp_source} =~ /\G<&(?!\|)/gcs )
411             {
412 216 50       1114 if ( $self->{current}{comp_source} =~ /\G(.*?)&>/gcs )
413             {
414 216         585 my $call = $1;
415 216         1170 $self->{current}{compiler}->component_call( call => $call );
416 216         546 $self->{current}{lines} += $call =~ tr/\n//;
417              
418 216         655 return 1;
419             }
420             else
421             {
422 0         0 $self->throw_syntax_error("'<&' without matching '&>'");
423             }
424             }
425             }
426              
427              
428             sub match_comp_content_call
429             {
430 1270     1270 0 1744 my $self = shift;
431              
432 1270 100       4075 if ( $self->{current}{comp_source} =~ /\G<&\|/gcs )
433             {
434 39 50       216 if ( $self->{current}{comp_source} =~ /\G(.*?)&>/gcs )
435             {
436 39         123 my $call = $1;
437 39         207 $self->{current}{compiler}->component_content_call( call => $call );
438 39         97 $self->{current}{lines} += $call =~ tr/\n//;
439              
440 39         108 return 1;
441             }
442             else
443             {
444 0         0 $self->throw_syntax_error("'<&|' without matching '&>'");
445             }
446             }
447             }
448              
449             sub match_comp_content_call_end
450             {
451 1231     1231 0 1703 my $self = shift;
452              
453 1231 100       3959 if ( $self->{current}{comp_source} =~ m,\G,gcs )
454             {
455 39   100     183 my $call = $1 || '';
456 39         175 $self->{current}{compiler}->component_content_call_end( call_end => $call );
457 33         77 $self->{current}{lines} += $call =~ tr/\n//;
458              
459 33         97 return 1;
460             }
461             }
462              
463             sub match_perl_line
464             {
465 1665     1665 0 2303 my $self = shift;
466              
467 1665 100       6205 if ( $self->{current}{comp_source} =~ /\G(?<=^)%([^\n]*)(?:\n|\z)/gcm )
468             {
469 395         1704 $self->{current}{compiler}->perl_line( line => $1 );
470 395         839 $self->{current}{lines}++;
471              
472 395         1072 return 1;
473             }
474             }
475              
476             sub match_text
477             {
478 1192     1192 0 1651 my $self = shift;
479 1192         1724 my $c = $self->{current};
480              
481             # Most of these terminator patterns actually belong to the next
482             # lexeme in the source, so we use a lookahead if we don't want to
483             # consume them. We use a lookbehind when we want to consume
484             # something in the matched text, like the newline before a '%'.
485 1192 50       9026 if ( $c->{comp_source} =~ m{
486             \G
487             (.*?) # anything, followed by:
488             (
489             (?<=\n)(?=%) # an eval line - consume the \n
490             |
491             (?=
492             # - don't consume
493             |
494             \\\n # an escaped newline - throw away
495             |
496             \z # end of string
497             )
498             }xcgs )
499             {
500             # Note: to save memory, it might be preferable to break very
501             # large $1 strings into several pieces and pass the pieces to
502             # compiler->text(). In my testing, this was quite a bit
503             # slower, though. -Ken 2002-09-19
504 1192 100       6270 $c->{compiler}->text( text => $1 ) if length $1;
505             # Not checking definedness seems to cause extra lines to be
506             # counted with Perl 5.00503. I'm not sure why - dave
507 1192         6325 $c->{lines} += tr/\n// foreach grep defined, ($1, $2);
508              
509 1192         3506 return 1;
510             }
511            
512 0         0 return 0;
513             }
514              
515             sub match_end
516             {
517 3299     3299 0 4561 my $self = shift;
518              
519             # $self->{current}{ending} is a qr// 'string'. No need to escape. It will
520             # also include the needed \G marker
521 3299 100       19185 if ( $self->{current}{comp_source} =~ /($self->{current}{ending})/gcs )
522             {
523 643         1672 $self->{current}{lines} += $1 =~ tr/\n//;
524 643 100 66     3754 return defined $1 && length $1 ? $1 : 1;
525             }
526 2656         7129 return 0;
527             }
528              
529             # goes from current pos, skips a newline if its the next character,
530             # and then goes to the next newline. Alternately, the caller can
531             # provide a starting position.
532             sub _next_line
533             {
534 19     19   35 my $self = shift;
535 19         32 my $pos = shift;
536              
537             $pos = ( defined $pos ?
538             $pos :
539             ( substr( $self->{current}{comp_source}, pos($self->{current}{comp_source}), 1 ) eq "\n" ?
540             pos($self->{current}{comp_source}) + 1 :
541 19 100       116 pos($self->{current}{comp_source}) ) );
    50          
542              
543             my $to_eol = ( index( $self->{current}{comp_source}, "\n", $pos ) != -1 ?
544             ( index( $self->{current}{comp_source}, "\n" , $pos ) ) - $pos :
545 19 100       85 length $self->{current}{comp_source} );
546 19         81 return substr( $self->{current}{comp_source}, $pos, $to_eol );
547             }
548              
549             sub line_number
550             {
551 4521     4521 1 6415 my $self = shift;
552              
553 4521         16478 return $self->{current}{lines};
554             }
555              
556             sub name
557             {
558 2159     2159 1 3084 my $self = shift;
559              
560 2159         5882 return $self->{current}{name};
561             }
562              
563             sub throw_syntax_error
564             {
565 19     19 1 75 my ($self, $error) = @_;
566              
567 19         66 HTML::Mason::Exception::Syntax->throw( error => $error,
568             comp_name => $self->name,
569             source_line => $self->_next_line,
570             line_number => $self->line_number );
571             }
572              
573             1;
574              
575             __END__