Commit | Line | Data |
3fea05b9 |
1 | package PPI::Token::_QuoteEngine; |
2 | |
3 | =pod |
4 | |
5 | =head1 NAME |
6 | |
7 | PPI::Token::_QuoteEngine - The PPI Quote Engine |
8 | |
9 | =head1 DESCRIPTION |
10 | |
11 | The C<PPI::Token::_QuoteEngine> package is designed hold functionality |
12 | for processing quotes and quote like operators, including regexes. |
13 | These have special requirements in parsing. |
14 | |
15 | The C<PPI::Token::_QuoteEngine> package itself provides various parsing |
16 | methods, which the L<PPI::Token::Quote>, L<PPI::Token::QuoteLike> and |
17 | L<PPI::Token::Regexp> can inherit from. In this sense, it serves |
18 | as a base class. |
19 | |
20 | =head2 Using this class |
21 | |
22 | I<(Refers only to internal uses. This class does not provide a |
23 | public interface)> |
24 | |
25 | To use these, you should initialize them as normal C<'$Class-E<gt>new'>, |
26 | and then call the 'fill' method, which will cause the specialised |
27 | parser to scan forwards and parse the quote to its end point. |
28 | |
29 | If -E<gt>fill returns true, finalise the token. |
30 | |
31 | =cut |
32 | |
33 | use strict; |
34 | use Carp (); |
35 | |
36 | use vars qw{$VERSION}; |
37 | BEGIN { |
38 | $VERSION = '1.206'; |
39 | } |
40 | |
41 | |
42 | |
43 | |
44 | |
45 | # Hook for the __TOKENIZER__on_char token call |
46 | sub __TOKENIZER__on_char { |
47 | my $class = shift; |
48 | my $t = $_[0]->{token} ? shift : return undef; |
49 | |
50 | # Call the fill method to process the quote |
51 | my $rv = $t->{token}->_fill( $t ); |
52 | return undef unless defined $rv; |
53 | |
54 | ## Doesn't support "end of file" indicator |
55 | |
56 | # Finalize the token and return 0 to tell the tokenizer |
57 | # to go to the next character. |
58 | $t->_finalize_token; |
59 | |
60 | 0; |
61 | } |
62 | |
63 | |
64 | |
65 | |
66 | |
67 | ##################################################################### |
68 | # Optimised character processors, used for quotes |
69 | # and quote like stuff, and accessible to the child classes |
70 | |
71 | # An outright scan, raw and fast. |
72 | # Searches for a particular character, loading in new |
73 | # lines as needed. |
74 | # When called, we start at the current position. |
75 | # When leaving, the position should be set to the position |
76 | # of the character, NOT the one after it. |
77 | sub _scan_for_character { |
78 | my $class = shift; |
79 | my $t = shift; |
80 | my $char = (length $_[0] == 1) ? quotemeta shift : return undef; |
81 | |
82 | # Create the search regex |
83 | my $search = qr/^(.*?$char)/; |
84 | |
85 | my $string = ''; |
86 | while ( exists $t->{line} ) { |
87 | # Get the search area for the current line |
88 | my $search_area |
89 | = $t->{line_cursor} |
90 | ? substr( $t->{line}, $t->{line_cursor} ) |
91 | : $t->{line}; |
92 | |
93 | # Can we find a match on this line |
94 | if ( $search_area =~ /$search/ ) { |
95 | # Found the character on this line |
96 | $t->{line_cursor} += length($1) - 1; |
97 | return $string . $1; |
98 | } |
99 | |
100 | # Load in the next line |
101 | $string .= $search_area; |
102 | return undef unless defined $t->_fill_line; |
103 | $t->{line_cursor} = 0; |
104 | } |
105 | |
106 | # Returning the string as a reference indicates EOF |
107 | \$string; |
108 | } |
109 | |
110 | # Scan for a character, but not if it is escaped |
111 | sub _scan_for_unescaped_character { |
112 | my $class = shift; |
113 | my $t = shift; |
114 | my $char = (length $_[0] == 1) ? quotemeta shift : return undef; |
115 | |
116 | # Create the search regex. |
117 | # Same as above but with a negative look-behind assertion. |
118 | my $search = qr/^(.*?(?<!\\)(?:\\\\)*$char)/; |
119 | |
120 | my $string = ''; |
121 | while ( exists $t->{line} ) { |
122 | # Get the search area for the current line |
123 | my $search_area |
124 | = $t->{line_cursor} |
125 | ? substr( $t->{line}, $t->{line_cursor} ) |
126 | : $t->{line}; |
127 | |
128 | # Can we find a match on this line |
129 | if ( $search_area =~ /$search/ ) { |
130 | # Found the character on this line |
131 | $t->{line_cursor} += length($1) - 1; |
132 | return $string . $1; |
133 | } |
134 | |
135 | # Load in the next line |
136 | $string .= $search_area; |
137 | my $rv = $t->_fill_line('inscan'); |
138 | if ( $rv ) { |
139 | # Push to first character |
140 | $t->{line_cursor} = 0; |
141 | } elsif ( defined $rv ) { |
142 | # We hit the End of File |
143 | return \$string; |
144 | } else { |
145 | # Unexpected error |
146 | return undef; |
147 | } |
148 | } |
149 | |
150 | # We shouldn't be able to get here |
151 | return undef; |
152 | } |
153 | |
154 | # Scan for a close braced, and take into account both escaping, |
155 | # and open close bracket pairs in the string. When complete, the |
156 | # method leaves the line cursor on the LAST character found. |
157 | sub _scan_for_brace_character { |
158 | my $class = shift; |
159 | my $t = shift; |
160 | my $close_brace = $_[0] =~ /^(?:\>|\)|\}|\])$/ ? shift : Carp::confess(''); # return undef; |
161 | my $open_brace = $close_brace; |
162 | $open_brace =~ tr/\>\)\}\]/\<\(\{\[/; |
163 | |
164 | # Create the search string |
165 | $close_brace = quotemeta $close_brace; |
166 | $open_brace = quotemeta $open_brace; |
167 | my $search = qr/^(.*?(?<!\\)(?:\\\\)*(?:$open_brace|$close_brace))/; |
168 | |
169 | # Loop as long as we can get new lines |
170 | my $string = ''; |
171 | my $depth = 1; |
172 | while ( exists $t->{line} ) { |
173 | # Get the search area |
174 | my $search_area |
175 | = $t->{line_cursor} |
176 | ? substr( $t->{line}, $t->{line_cursor} ) |
177 | : $t->{line}; |
178 | |
179 | # Look for a match |
180 | unless ( $search_area =~ /$search/ ) { |
181 | # Load in the next line |
182 | $string .= $search_area; |
183 | my $rv = $t->_fill_line('inscan'); |
184 | if ( $rv ) { |
185 | # Push to first character |
186 | $t->{line_cursor} = 0; |
187 | next; |
188 | } |
189 | if ( defined $rv ) { |
190 | # We hit the End of File |
191 | return \$string; |
192 | } |
193 | |
194 | # Unexpected error |
195 | return undef; |
196 | } |
197 | |
198 | # Add to the string |
199 | $string .= $1; |
200 | $t->{line_cursor} += length $1; |
201 | |
202 | # Alter the depth and continue if we arn't at the end |
203 | $depth += ($1 =~ /$open_brace$/) ? 1 : -1 and next; |
204 | |
205 | # Rewind the cursor by one character ( cludgy hack ) |
206 | $t->{line_cursor} -= 1; |
207 | return $string; |
208 | } |
209 | |
210 | # Returning the string as a reference indicates EOF |
211 | \$string; |
212 | } |
213 | |
214 | # Find all spaces and comments, up to, but not including |
215 | # the first non-whitespace character. |
216 | # |
217 | # Although it doesn't return it, it leaves the cursor |
218 | # on the character following the gap |
219 | sub _scan_quote_like_operator_gap { |
220 | my $t = $_[1]; |
221 | |
222 | my $string = ''; |
223 | while ( exists $t->{line} ) { |
224 | # Get the search area for the current line |
225 | my $search_area |
226 | = $t->{line_cursor} |
227 | ? substr( $t->{line}, $t->{line_cursor} ) |
228 | : $t->{line}; |
229 | |
230 | # Since this regex can match zero characters, it should always match |
231 | $search_area =~ /^(\s*(?:\#.*)?)/s or return undef; |
232 | |
233 | # Add the chars found to the string |
234 | $string .= $1; |
235 | |
236 | # Did we match the entire line? |
237 | unless ( length $1 == length $search_area ) { |
238 | # Partial line match, which means we are at |
239 | # the end of the gap. Fix the cursor and return |
240 | # the string. |
241 | $t->{line_cursor} += length $1; |
242 | return $string; |
243 | } |
244 | |
245 | # Load in the next line. |
246 | # If we reach the EOF, $t->{line} gets deleted, |
247 | # which is caught by the while. |
248 | my $rv = $t->_fill_line('inscan'); |
249 | if ( $rv ) { |
250 | # Set the cursor to the first character |
251 | $t->{line_cursor} = 0; |
252 | } elsif ( defined $rv ) { |
253 | # Returning the string as a reference indicates EOF |
254 | return \$string; |
255 | } else { |
256 | return undef; |
257 | } |
258 | } |
259 | |
260 | # Shouldn't be able to get here |
261 | return undef; |
262 | } |
263 | |
264 | 1; |
265 | |
266 | =pod |
267 | |
268 | =head1 SUPPORT |
269 | |
270 | See the L<support section|PPI/SUPPORT> in the main module. |
271 | |
272 | =head1 AUTHOR |
273 | |
274 | Adam Kennedy E<lt>adamk@cpan.orgE<gt> |
275 | |
276 | =head1 COPYRIGHT |
277 | |
278 | Copyright 2001 - 2009 Adam Kennedy. |
279 | |
280 | This program is free software; you can redistribute |
281 | it and/or modify it under the same terms as Perl itself. |
282 | |
283 | The full text of the license can be found in the |
284 | LICENSE file included with this module. |
285 | |
286 | =cut |