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 |