Commit | Line | Data |
3fea05b9 |
1 | package PPI::Document; |
2 | |
3 | =pod |
4 | |
5 | =head1 NAME |
6 | |
7 | PPI::Document - Object representation of a Perl document |
8 | |
9 | =head1 INHERITANCE |
10 | |
11 | PPI::Document |
12 | isa PPI::Node |
13 | isa PPI::Element |
14 | |
15 | =head1 SYNOPSIS |
16 | |
17 | use PPI; |
18 | |
19 | # Load a document from a file |
20 | my $Document = PPI::Document->new('My/Module.pm'); |
21 | |
22 | # Strip out comments |
23 | $Document->prune('PPI::Token::Comment'); |
24 | |
25 | # Find all the named subroutines |
26 | my $sub_nodes = $Document->find( |
27 | sub { $_[1]->isa('PPI::Statement::Sub') and $_[1]->name } |
28 | ); |
29 | my @sub_names = map { $_->name } @$sub_nodes; |
30 | |
31 | # Save the file |
32 | $Document->save('My/Module.pm.stripped'); |
33 | |
34 | =head1 DESCRIPTION |
35 | |
36 | The C<PPI::Document> class represents a single Perl "document". A |
37 | C<PPI::Document> object acts as a root L<PPI::Node>, with some |
38 | additional methods for loading and saving, and working with |
39 | the line/column locations of Elements within a file. |
40 | |
41 | The exemption to its L<PPI::Node>-like behavior this is that a |
42 | C<PPI::Document> object can NEVER have a parent node, and is always |
43 | the root node in a tree. |
44 | |
45 | =head2 Storable Support |
46 | |
47 | C<PPI::Document> implements the necessary C<STORABLE_freeze> and |
48 | C<STORABLE_thaw> hooks to provide native support for L<Storable>, |
49 | if you have it installed. |
50 | |
51 | However if you want to clone clone a Document, you are highly recommended |
52 | to use the internal C<$Document-E<gt>clone> method rather than Storable's |
53 | C<dclone> function (although C<dclone> should still work). |
54 | |
55 | =head1 METHODS |
56 | |
57 | Most of the things you are likely to want to do with a Document are |
58 | probably going to involve the methods from L<PPI::Node> class, of which |
59 | this is a subclass. |
60 | |
61 | The methods listed here are the remaining few methods that are truly |
62 | Document-specific. |
63 | |
64 | =cut |
65 | |
66 | use strict; |
67 | use Carp (); |
68 | use List::MoreUtils (); |
69 | use Params::Util qw{_SCALAR0 _ARRAY0 _INSTANCE}; |
70 | use Digest::MD5 (); |
71 | use PPI::Util (); |
72 | use PPI (); |
73 | use PPI::Node (); |
74 | use PPI::Exception::ParserTimeout (); |
75 | |
76 | use overload 'bool' => \&PPI::Util::TRUE; |
77 | use overload '""' => 'content'; |
78 | |
79 | use vars qw{$VERSION @ISA $errstr}; |
80 | BEGIN { |
81 | $VERSION = '1.206'; |
82 | @ISA = 'PPI::Node'; |
83 | $errstr = ''; |
84 | } |
85 | |
86 | use PPI::Document::Fragment (); |
87 | |
88 | # Document cache |
89 | my $CACHE = undef; |
90 | |
91 | # Convenience constants related to constants |
92 | use constant LOCATION_LINE => 0; |
93 | use constant LOCATION_CHARACTER => 1; |
94 | use constant LOCATION_COLUMN => 2; |
95 | use constant LOCATION_LOGICAL_LINE => 3; |
96 | use constant LOCATION_LOGICAL_FILE => 4; |
97 | |
98 | |
99 | |
100 | |
101 | |
102 | ##################################################################### |
103 | # Constructor and Static Methods |
104 | |
105 | =pod |
106 | |
107 | =head2 new |
108 | |
109 | # Simple construction |
110 | $doc = PPI::Document->new( $filename ); |
111 | $doc = PPI::Document->new( \$source ); |
112 | |
113 | # With the readonly attribute set |
114 | $doc = PPI::Document->new( $filename, |
115 | readonly => 1, |
116 | ); |
117 | |
118 | The C<new> constructor takes as argument a variety of different sources of |
119 | Perl code, and creates a single cohesive Perl C<PPI::Document> |
120 | for it. |
121 | |
122 | If passed a file name as a normal string, it will attempt to load the |
123 | document from the file. |
124 | |
125 | If passed a reference to a C<SCALAR>, this is taken to be source code and |
126 | parsed directly to create the document. |
127 | |
128 | If passed zero arguments, a "blank" document will be created that contains |
129 | no content at all. |
130 | |
131 | In all cases, the document is considered to be "anonymous" and not tied back |
132 | to where it was created from. Specifically, if you create a PPI::Document from |
133 | a filename, the document will B<not> remember where it was created from. |
134 | |
135 | The constructor also takes attribute flags. |
136 | |
137 | At this time, the only available attribute is the C<readonly> flag. |
138 | |
139 | Setting C<readonly> to true will allow various systems to provide |
140 | additional optimisations and caching. Note that because C<readonly> is an |
141 | optimisation flag, it is off by default and you will need to explicitly |
142 | enable it. |
143 | |
144 | Returns a C<PPI::Document> object, or C<undef> if parsing fails. |
145 | |
146 | =cut |
147 | |
148 | sub new { |
149 | local $_; # An extra one, just in case |
150 | my $class = ref $_[0] ? ref shift : shift; |
151 | |
152 | unless ( @_ ) { |
153 | my $self = $class->SUPER::new; |
154 | $self->{readonly} = ! 1; |
155 | $self->{tab_width} = 1; |
156 | return $self; |
157 | } |
158 | |
159 | # Check constructor attributes |
160 | my $source = shift; |
161 | my %attr = @_; |
162 | my $timeout = delete $attr{timeout}; |
163 | if ( $timeout and ! PPI::Util::HAVE_ALARM() ) { |
164 | Carp::croak("This platform does not support PPI parser timeouts"); |
165 | } |
166 | |
167 | # Check the data source |
168 | if ( ! defined $source ) { |
169 | $class->_error("An undefined value was passed to PPI::Document::new"); |
170 | |
171 | } elsif ( ! ref $source ) { |
172 | # Catch people using the old API |
173 | if ( $source =~ /(?:\012|\015)/ ) { |
174 | Carp::croak("API CHANGE: Source code should only be passed to PPI::Document->new as a SCALAR reference"); |
175 | } |
176 | |
177 | # When loading from a filename, use the caching layer if it exists. |
178 | if ( $CACHE ) { |
179 | my $file = $source; |
180 | my $source = PPI::Util::_slurp( $file ); |
181 | unless ( ref $source ) { |
182 | # Errors returned as plain string |
183 | return $class->_error($source); |
184 | } |
185 | |
186 | # Retrieve the document from the cache |
187 | my $document = $CACHE->get_document($source); |
188 | return $class->_setattr( $document, %attr ) if $document; |
189 | |
190 | if ( $timeout ) { |
191 | eval { |
192 | local $SIG{ALRM} = sub { die "alarm\n" }; |
193 | alarm( $timeout ); |
194 | $document = PPI::Lexer->lex_source( $$source ); |
195 | alarm( 0 ); |
196 | }; |
197 | } else { |
198 | $document = PPI::Lexer->lex_source( $$source ); |
199 | } |
200 | if ( $document ) { |
201 | # Save in the cache |
202 | $CACHE->store_document( $document ); |
203 | return $class->_setattr( $document, %attr ); |
204 | } |
205 | } else { |
206 | if ( $timeout ) { |
207 | eval { |
208 | local $SIG{ALRM} = sub { die "alarm\n" }; |
209 | alarm( $timeout ); |
210 | my $document = PPI::Lexer->lex_file( $source ); |
211 | return $class->_setattr( $document, %attr ) if $document; |
212 | alarm( 0 ); |
213 | }; |
214 | } else { |
215 | my $document = PPI::Lexer->lex_file( $source ); |
216 | return $class->_setattr( $document, %attr ) if $document; |
217 | } |
218 | } |
219 | |
220 | } elsif ( _SCALAR0($source) ) { |
221 | if ( $timeout ) { |
222 | eval { |
223 | local $SIG{ALRM} = sub { die "alarm\n" }; |
224 | alarm( $timeout ); |
225 | my $document = PPI::Lexer->lex_source( $$source ); |
226 | return $class->_setattr( $document, %attr ) if $document; |
227 | alarm( 0 ); |
228 | }; |
229 | } else { |
230 | my $document = PPI::Lexer->lex_source( $$source ); |
231 | return $class->_setattr( $document, %attr ) if $document; |
232 | } |
233 | |
234 | } elsif ( _ARRAY0($source) ) { |
235 | $source = join '', map { "$_\n" } @$source; |
236 | if ( $timeout ) { |
237 | eval { |
238 | local $SIG{ALRM} = sub { die "alarm\n" }; |
239 | alarm( $timeout ); |
240 | my $document = PPI::Lexer->lex_source( $source ); |
241 | return $class->_setattr( $document, %attr ) if $document; |
242 | alarm( 0 ); |
243 | }; |
244 | } else { |
245 | my $document = PPI::Lexer->lex_source( $source ); |
246 | return $class->_setattr( $document, %attr ) if $document; |
247 | } |
248 | |
249 | } else { |
250 | $class->_error("Unknown object or reference was passed to PPI::Document::new"); |
251 | } |
252 | |
253 | # Pull and store the error from the lexer |
254 | my $errstr; |
255 | if ( _INSTANCE($@, 'PPI::Exception::Timeout') ) { |
256 | $errstr = 'Timed out while parsing document'; |
257 | } elsif ( _INSTANCE($@, 'PPI::Exception') ) { |
258 | $errstr = $@->message; |
259 | } elsif ( $@ ) { |
260 | $errstr = $@; |
261 | $errstr =~ s/\sat line\s.+$//; |
262 | } elsif ( PPI::Lexer->errstr ) { |
263 | $errstr = PPI::Lexer->errstr; |
264 | } else { |
265 | $errstr = "Unknown error parsing Perl document"; |
266 | } |
267 | PPI::Lexer->_clear; |
268 | $class->_error( $errstr ); |
269 | } |
270 | |
271 | sub load { |
272 | Carp::croak("API CHANGE: File names should now be passed to PPI::Document->new to load a file"); |
273 | } |
274 | |
275 | sub _setattr { |
276 | my ($class, $document, %attr) = @_; |
277 | $document->{readonly} = !! $attr{readonly}; |
278 | return $document; |
279 | } |
280 | |
281 | =pod |
282 | |
283 | =head2 set_cache $cache |
284 | |
285 | As of L<PPI> 1.100, C<PPI::Document> supports parser caching. |
286 | |
287 | The default cache class L<PPI::Cache> provides a L<Storable>-based |
288 | caching or the parsed document based on the MD5 hash of the document as |
289 | a string. |
290 | |
291 | The static C<set_cache> method is used to set the cache object for |
292 | C<PPI::Document> to use when loading documents. It takes as argument |
293 | a L<PPI::Cache> object (or something that C<isa> the same). |
294 | |
295 | If passed C<undef>, this method will stop using the current cache, if any. |
296 | |
297 | For more information on caching, see L<PPI::Cache>. |
298 | |
299 | Returns true on success, or C<undef> if not passed a valid param. |
300 | |
301 | =cut |
302 | |
303 | sub set_cache { |
304 | my $class = ref $_[0] ? ref shift : shift; |
305 | |
306 | if ( defined $_[0] ) { |
307 | # Enable the cache |
308 | my $object = _INSTANCE(shift, 'PPI::Cache') or return undef; |
309 | $CACHE = $object; |
310 | } else { |
311 | # Disable the cache |
312 | $CACHE = undef; |
313 | } |
314 | |
315 | 1; |
316 | } |
317 | |
318 | =pod |
319 | |
320 | =head2 get_cache |
321 | |
322 | If a document cache is currently set, the C<get_cache> method will |
323 | return it. |
324 | |
325 | Returns a L<PPI::Cache> object, or C<undef> if there is no cache |
326 | currently set for C<PPI::Document>. |
327 | |
328 | =cut |
329 | |
330 | sub get_cache { |
331 | $CACHE; |
332 | } |
333 | |
334 | |
335 | |
336 | |
337 | |
338 | ##################################################################### |
339 | # PPI::Document Instance Methods |
340 | |
341 | =pod |
342 | |
343 | =head2 readonly |
344 | |
345 | The C<readonly> attribute indicates if the document is intended to be |
346 | read-only, and will never be modified. This is an advisory flag, that |
347 | writers of L<PPI>-related systems may or may not use to enable |
348 | optimisations and caches for your document. |
349 | |
350 | Returns true if the document is read-only or false if not. |
351 | |
352 | =cut |
353 | |
354 | sub readonly { |
355 | $_[0]->{readonly}; |
356 | } |
357 | |
358 | =pod |
359 | |
360 | =head2 tab_width [ $width ] |
361 | |
362 | In order to handle support for C<location> correctly, C<Documents> |
363 | need to understand the concept of tabs and tab width. The C<tab_width> |
364 | method is used to get and set the size of the tab width. |
365 | |
366 | At the present time, PPI only supports "naive" (width 1) tabs, but we do |
367 | plan on supporting arbitrary, default and auto-sensing tab widths later. |
368 | |
369 | Returns the tab width as an integer, or C<die>s if you attempt to set the |
370 | tab width. |
371 | |
372 | =cut |
373 | |
374 | sub tab_width { |
375 | my $self = shift; |
376 | return $self->{tab_width} unless @_; |
377 | $self->{tab_width} = shift; |
378 | } |
379 | |
380 | =pod |
381 | |
382 | =head2 save |
383 | |
384 | $document->save( $file ) |
385 | |
386 | The C<save> method serializes the C<PPI::Document> object and saves the |
387 | resulting Perl document to a file. Returns C<undef> on failure to open |
388 | or write to the file. |
389 | |
390 | =cut |
391 | |
392 | sub save { |
393 | my $self = shift; |
394 | local *FILE; |
395 | open( FILE, '>', $_[0] ) or return undef; |
396 | print FILE $self->serialize or return undef; |
397 | close FILE or return undef; |
398 | return 1; |
399 | } |
400 | |
401 | =pod |
402 | |
403 | =head2 serialize |
404 | |
405 | Unlike the C<content> method, which shows only the immediate content |
406 | within an element, Document objects also have to be able to be written |
407 | out to a file again. |
408 | |
409 | When doing this we need to take into account some additional factors. |
410 | |
411 | Primarily, we need to handle here-docs correctly, so that are written |
412 | to the file in the expected place. |
413 | |
414 | The C<serialize> method generates the actual file content for a given |
415 | Document object. The resulting string can be written straight to a file. |
416 | |
417 | Returns the serialized document as a string. |
418 | |
419 | =cut |
420 | |
421 | sub serialize { |
422 | my $self = shift; |
423 | my @tokens = $self->tokens; |
424 | |
425 | # The here-doc content buffer |
426 | my $heredoc = ''; |
427 | |
428 | # Start the main loop |
429 | my $output = ''; |
430 | foreach my $i ( 0 .. $#tokens ) { |
431 | my $Token = $tokens[$i]; |
432 | |
433 | # Handle normal tokens |
434 | unless ( $Token->isa('PPI::Token::HereDoc') ) { |
435 | my $content = $Token->content; |
436 | |
437 | # Handle the trivial cases |
438 | unless ( $heredoc ne '' and $content =~ /\n/ ) { |
439 | $output .= $content; |
440 | next; |
441 | } |
442 | |
443 | # We have pending here-doc content that needs to be |
444 | # inserted just after the first newline in the content. |
445 | if ( $content eq "\n" ) { |
446 | # Shortcut the most common case for speed |
447 | $output .= $content . $heredoc; |
448 | } else { |
449 | # Slower and more general version |
450 | $content =~ s/\n/\n$heredoc/; |
451 | $output .= $content; |
452 | } |
453 | |
454 | $heredoc = ''; |
455 | next; |
456 | } |
457 | |
458 | # This token is a HereDoc. |
459 | # First, add the token content as normal, which in this |
460 | # case will definately not contain a newline. |
461 | $output .= $Token->content; |
462 | |
463 | # Now add all of the here-doc content to the heredoc buffer. |
464 | foreach my $line ( $Token->heredoc ) { |
465 | $heredoc .= $line; |
466 | } |
467 | |
468 | if ( $Token->{_damaged} ) { |
469 | # Special Case: |
470 | # There are a couple of warning/bug situations |
471 | # that can occur when a HereDoc content was read in |
472 | # from the end of a file that we silently allow. |
473 | # |
474 | # When writing back out to the file we have to |
475 | # auto-repair these problems if we arn't going back |
476 | # on to the end of the file. |
477 | |
478 | # When calculating $last_line, ignore the final token if |
479 | # and only if it has a single newline at the end. |
480 | my $last_index = $#tokens; |
481 | if ( $tokens[$last_index]->{content} =~ /^[^\n]*\n$/ ) { |
482 | $last_index--; |
483 | } |
484 | |
485 | # This is a two part test. |
486 | # First, are we on the last line of the |
487 | # content part of the file |
488 | my $last_line = List::MoreUtils::none { |
489 | $tokens[$_] and $tokens[$_]->{content} =~ /\n/ |
490 | } (($i + 1) .. $last_index); |
491 | if ( ! defined $last_line ) { |
492 | # Handles the null list case |
493 | $last_line = 1; |
494 | } |
495 | |
496 | # Secondly, are their any more here-docs after us, |
497 | # (with content or a terminator) |
498 | my $any_after = List::MoreUtils::any { |
499 | $tokens[$_]->isa('PPI::Token::HereDoc') |
500 | and ( |
501 | scalar(@{$tokens[$_]->{_heredoc}}) |
502 | or |
503 | defined $tokens[$_]->{_terminator_line} |
504 | ) |
505 | } (($i + 1) .. $#tokens); |
506 | if ( ! defined $any_after ) { |
507 | # Handles the null list case |
508 | $any_after = ''; |
509 | } |
510 | |
511 | # We don't need to repair the last here-doc on the |
512 | # last line. But we do need to repair anything else. |
513 | unless ( $last_line and ! $any_after ) { |
514 | # Add a terminating string if it didn't have one |
515 | unless ( defined $Token->{_terminator_line} ) { |
516 | $Token->{_terminator_line} = $Token->{_terminator}; |
517 | } |
518 | |
519 | # Add a trailing newline to the terminating |
520 | # string if it didn't have one. |
521 | unless ( $Token->{_terminator_line} =~ /\n$/ ) { |
522 | $Token->{_terminator_line} .= "\n"; |
523 | } |
524 | } |
525 | } |
526 | |
527 | # Now add the termination line to the heredoc buffer |
528 | if ( defined $Token->{_terminator_line} ) { |
529 | $heredoc .= $Token->{_terminator_line}; |
530 | } |
531 | } |
532 | |
533 | # End of tokens |
534 | |
535 | if ( $heredoc ne '' ) { |
536 | # If the file doesn't end in a newline, we need to add one |
537 | # so that the here-doc content starts on the next line. |
538 | unless ( $output =~ /\n$/ ) { |
539 | $output .= "\n"; |
540 | } |
541 | |
542 | # Now we add the remaining here-doc content |
543 | # to the end of the file. |
544 | $output .= $heredoc; |
545 | } |
546 | |
547 | $output; |
548 | } |
549 | |
550 | =pod |
551 | |
552 | =head2 hex_id |
553 | |
554 | The C<hex_id> method generates an unique identifier for the Perl document. |
555 | |
556 | This identifier is basically just the serialized document, with |
557 | Unix-specific newlines, passed through MD5 to produce a hexadecimal string. |
558 | |
559 | This identifier is used by a variety of systems (such as L<PPI::Cache> |
560 | and L<Perl::Metrics>) as a unique key against which to store or cache |
561 | information about a document (or indeed, to cache the document itself). |
562 | |
563 | Returns a 32 character hexadecimal string. |
564 | |
565 | =cut |
566 | |
567 | sub hex_id { |
568 | PPI::Util::md5hex($_[0]->serialize); |
569 | } |
570 | |
571 | =pod |
572 | |
573 | =head2 index_locations |
574 | |
575 | Within a document, all L<PPI::Element> objects can be considered to have a |
576 | "location", a line/column position within the document when considered as a |
577 | file. This position is primarily useful for debugging type activities. |
578 | |
579 | The method for finding the position of a single Element is a bit laborious, |
580 | and very slow if you need to do it a lot. So the C<index_locations> method |
581 | will index and save the locations of every Element within the Document in |
582 | advance, making future calls to <PPI::Element::location> virtually free. |
583 | |
584 | Please note that this index should always be cleared using C<flush_locations> |
585 | once you are finished with the locations. If content is added to or removed |
586 | from the file, these indexed locations will be B<wrong>. |
587 | |
588 | =cut |
589 | |
590 | sub index_locations { |
591 | my $self = shift; |
592 | my @tokens = $self->tokens; |
593 | |
594 | # Whenever we hit a heredoc we will need to increment by |
595 | # the number of lines in it's content section when when we |
596 | # encounter the next token with a newline in it. |
597 | my $heredoc = 0; |
598 | |
599 | # Find the first Token without a location |
600 | my ($first, $location) = (); |
601 | foreach ( 0 .. $#tokens ) { |
602 | my $Token = $tokens[$_]; |
603 | next if $Token->{_location}; |
604 | |
605 | # Found the first Token without a location |
606 | # Calculate the new location if needed. |
607 | if ($_) { |
608 | $location = |
609 | $self->_add_location( $location, $tokens[$_ - 1], \$heredoc ); |
610 | } else { |
611 | my $logical_file = |
612 | $self->can('filename') ? $self->filename : undef; |
613 | $location = [ 1, 1, 1, 1, $logical_file ]; |
614 | } |
615 | $first = $_; |
616 | last; |
617 | } |
618 | |
619 | # Calculate locations for the rest |
620 | foreach ( $first .. $#tokens ) { |
621 | my $Token = $tokens[$_]; |
622 | $Token->{_location} = $location; |
623 | $location = $self->_add_location( $location, $Token, \$heredoc ); |
624 | |
625 | # Add any here-doc lines to the counter |
626 | if ( $Token->isa('PPI::Token::HereDoc') ) { |
627 | $heredoc += $Token->heredoc + 1; |
628 | } |
629 | } |
630 | |
631 | 1; |
632 | } |
633 | |
634 | sub _add_location { |
635 | my ($self, $start, $Token, $heredoc) = @_; |
636 | my $content = $Token->{content}; |
637 | |
638 | # Does the content contain any newlines |
639 | my $newlines =()= $content =~ /\n/g; |
640 | my ($logical_line, $logical_file) = |
641 | $self->_logical_line_and_file($start, $Token, $newlines); |
642 | |
643 | unless ( $newlines ) { |
644 | # Handle the simple case |
645 | return [ |
646 | $start->[LOCATION_LINE], |
647 | $start->[LOCATION_CHARACTER] + length($content), |
648 | $start->[LOCATION_COLUMN] |
649 | + $self->_visual_length( |
650 | $content, |
651 | $start->[LOCATION_COLUMN] |
652 | ), |
653 | $logical_line, |
654 | $logical_file, |
655 | ]; |
656 | } |
657 | |
658 | # This is the more complex case where we hit or |
659 | # span a newline boundary. |
660 | my $physical_line = $start->[LOCATION_LINE] + $newlines; |
661 | my $location = [ $physical_line, 1, 1, $logical_line, $logical_file ]; |
662 | if ( $heredoc and $$heredoc ) { |
663 | $location->[LOCATION_LINE] += $$heredoc; |
664 | $location->[LOCATION_LOGICAL_LINE] += $$heredoc; |
665 | $$heredoc = 0; |
666 | } |
667 | |
668 | # Does the token have additional characters |
669 | # after their last newline. |
670 | if ( $content =~ /\n([^\n]+?)\z/ ) { |
671 | $location->[LOCATION_CHARACTER] += length($1); |
672 | $location->[LOCATION_COLUMN] += |
673 | $self->_visual_length( |
674 | $1, $location->[LOCATION_COLUMN], |
675 | ); |
676 | } |
677 | |
678 | $location; |
679 | } |
680 | |
681 | sub _logical_line_and_file { |
682 | my ($self, $start, $Token, $newlines) = @_; |
683 | |
684 | # Regex taken from perlsyn, with the correction that there's no space |
685 | # required between the line number and the file name. |
686 | if ($start->[LOCATION_CHARACTER] == 1) { |
687 | if ( $Token->isa('PPI::Token::Comment') ) { |
688 | if ( |
689 | $Token->content =~ m< |
690 | \A |
691 | \# \s* |
692 | line \s+ |
693 | (\d+) \s* |
694 | (?: (\"?) ([^\"]* [^\s\"]) \2 )? |
695 | \s* |
696 | \z |
697 | >xms |
698 | ) { |
699 | return $1, ($3 || $start->[LOCATION_LOGICAL_FILE]); |
700 | } |
701 | } |
702 | elsif ( $Token->isa('PPI::Token::Pod') ) { |
703 | my $content = $Token->content; |
704 | my $line; |
705 | my $file = $start->[LOCATION_LOGICAL_FILE]; |
706 | my $end_of_directive; |
707 | while ( |
708 | $content =~ m< |
709 | ^ |
710 | \# \s*? |
711 | line \s+? |
712 | (\d+) (?: (?! \n) \s)* |
713 | (?: (\"?) ([^\"]*? [^\s\"]) \2 )?? |
714 | \s*? |
715 | $ |
716 | >xmsg |
717 | ) { |
718 | ($line, $file) = ($1, ( $3 || $file ) ); |
719 | $end_of_directive = pos $content; |
720 | } |
721 | |
722 | if (defined $line) { |
723 | pos $content = $end_of_directive; |
724 | my $post_directive_newlines =()= $content =~ m< \G [^\n]* \n >xmsg; |
725 | return $line + $post_directive_newlines - 1, $file; |
726 | } |
727 | } |
728 | } |
729 | |
730 | return |
731 | $start->[LOCATION_LOGICAL_LINE] + $newlines, |
732 | $start->[LOCATION_LOGICAL_FILE]; |
733 | } |
734 | |
735 | sub _visual_length { |
736 | my ($self, $content, $pos) = @_; |
737 | |
738 | my $tab_width = $self->tab_width; |
739 | my ($length, $vis_inc); |
740 | |
741 | return length $content if $content !~ /\t/; |
742 | |
743 | # Split the content in tab and non-tab parts and calculate the |
744 | # "visual increase" of each part. |
745 | for my $part ( split(/(\t)/, $content) ) { |
746 | if ($part eq "\t") { |
747 | $vis_inc = $tab_width - ($pos-1) % $tab_width; |
748 | } |
749 | else { |
750 | $vis_inc = length $part; |
751 | } |
752 | $length += $vis_inc; |
753 | $pos += $vis_inc; |
754 | } |
755 | |
756 | $length; |
757 | } |
758 | |
759 | =pod |
760 | |
761 | =head2 flush_locations |
762 | |
763 | When no longer needed, the C<flush_locations> method clears all location data |
764 | from the tokens. |
765 | |
766 | =cut |
767 | |
768 | sub flush_locations { |
769 | shift->_flush_locations(@_); |
770 | } |
771 | |
772 | =pod |
773 | |
774 | =head2 normalized |
775 | |
776 | The C<normalized> method is used to generate a "Layer 1" |
777 | L<PPI::Document::Normalized> object for the current Document. |
778 | |
779 | A "normalized" Perl Document is an arbitrary structure that removes any |
780 | irrelevant parts of the document and refactors out variations in style, |
781 | to attempt to approach something that is closer to the "true meaning" |
782 | of the Document. |
783 | |
784 | See L<PPI::Normal> for more information on document normalization and |
785 | the tasks for which it is useful. |
786 | |
787 | Returns a L<PPI::Document::Normalized> object, or C<undef> on error. |
788 | |
789 | =cut |
790 | |
791 | sub normalized { |
792 | # The normalization process will utterly destroy and mangle |
793 | # anything passed to it, so we are going to only give it a |
794 | # clone of ourself. |
795 | PPI::Normal->process( $_[0]->clone ); |
796 | } |
797 | |
798 | =pod |
799 | |
800 | =head1 complete |
801 | |
802 | The C<complete> method is used to determine if a document is cleanly |
803 | structured, all braces are closed, the final statement is |
804 | fully terminated and all heredocs are fully entered. |
805 | |
806 | Returns true if the document is complete or false if not. |
807 | |
808 | =cut |
809 | |
810 | sub complete { |
811 | my $self = shift; |
812 | |
813 | # Every structure has to be complete |
814 | $self->find_any( sub { |
815 | $_[1]->isa('PPI::Structure') |
816 | and |
817 | ! $_[1]->complete |
818 | } ) |
819 | and return ''; |
820 | |
821 | # Strip anything that isn't a statement off the end |
822 | my @child = $self->children; |
823 | while ( @child and not $child[-1]->isa('PPI::Statement') ) { |
824 | pop @child; |
825 | } |
826 | |
827 | # We must have at least one statement |
828 | return '' unless @child; |
829 | |
830 | # Check the completeness of the last statement |
831 | return $child[-1]->_complete; |
832 | } |
833 | |
834 | |
835 | |
836 | |
837 | |
838 | ##################################################################### |
839 | # PPI::Node Methods |
840 | |
841 | # We are a scope boundary |
842 | ### XS -> PPI/XS.xs:_PPI_Document__scope 0.903+ |
843 | sub scope { 1 } |
844 | |
845 | |
846 | |
847 | |
848 | |
849 | ##################################################################### |
850 | # PPI::Element Methods |
851 | |
852 | sub insert_before { |
853 | return undef; |
854 | # die "Cannot insert_before a PPI::Document"; |
855 | } |
856 | |
857 | sub insert_after { |
858 | return undef; |
859 | # die "Cannot insert_after a PPI::Document"; |
860 | } |
861 | |
862 | sub replace { |
863 | return undef; |
864 | # die "Cannot replace a PPI::Document"; |
865 | } |
866 | |
867 | |
868 | |
869 | |
870 | |
871 | ##################################################################### |
872 | # Error Handling |
873 | |
874 | # Set the error message |
875 | sub _error { |
876 | $errstr = $_[1]; |
877 | undef; |
878 | } |
879 | |
880 | # Clear the error message. |
881 | # Returns the object as a convenience. |
882 | sub _clear { |
883 | $errstr = ''; |
884 | $_[0]; |
885 | } |
886 | |
887 | =pod |
888 | |
889 | =head2 errstr |
890 | |
891 | For error that occur when loading and saving documents, you can use |
892 | C<errstr>, as either a static or object method, to access the error message. |
893 | |
894 | If a Document loads or saves without error, C<errstr> will return false. |
895 | |
896 | =cut |
897 | |
898 | sub errstr { |
899 | $errstr; |
900 | } |
901 | |
902 | |
903 | |
904 | |
905 | |
906 | ##################################################################### |
907 | # Native Storable Support |
908 | |
909 | sub STORABLE_freeze { |
910 | my $self = shift; |
911 | my $class = ref $self; |
912 | my %hash = %$self; |
913 | return ($class, \%hash); |
914 | } |
915 | |
916 | sub STORABLE_thaw { |
917 | my ($self, undef, $class, $hash) = @_; |
918 | bless $self, $class; |
919 | foreach ( keys %$hash ) { |
920 | $self->{$_} = delete $hash->{$_}; |
921 | } |
922 | $self->__link_children; |
923 | } |
924 | |
925 | 1; |
926 | |
927 | =pod |
928 | |
929 | =head1 TO DO |
930 | |
931 | - May need to overload some methods to forcefully prevent Document |
932 | objects becoming children of another Node. |
933 | |
934 | =head1 SUPPORT |
935 | |
936 | See the L<support section|PPI/SUPPORT> in the main module. |
937 | |
938 | =head1 AUTHOR |
939 | |
940 | Adam Kennedy E<lt>adamk@cpan.orgE<gt> |
941 | |
942 | =head1 SEE ALSO |
943 | |
944 | L<PPI>, L<http://ali.as/> |
945 | |
946 | =head1 COPYRIGHT |
947 | |
948 | Copyright 2001 - 2009 Adam Kennedy. |
949 | |
950 | This program is free software; you can redistribute |
951 | it and/or modify it under the same terms as Perl itself. |
952 | |
953 | The full text of the license can be found in the |
954 | LICENSE file included with this module. |
955 | |
956 | =cut |