File Coverage

blib/lib/PPI/Document.pm
Criterion Covered Total %
statement 252 275 91.6
branch 87 128 67.9
condition 18 29 62.0
subroutine 47 51 92.1
pod 20 24 83.3
total 424 507 83.6


line stmt bran cond sub pod time code
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 a Document, you are highly recommended
52             to use the 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 66     66   993803 use strict;
  66         111  
  66         1877  
67 66     66   250 use Carp ();
  66         121  
  66         1339  
68 66     66   220 use List::Util 1.33 ();
  66         1259  
  66         1676  
69 66     66   4442 use Params::Util 1.00 qw{_SCALAR0 _ARRAY0 _INSTANCE};
  66         51641  
  66         3774  
70 66     66   299 use Digest::MD5 ();
  66         104  
  66         962  
71 66     66   5364 use PPI::Util ();
  66         135  
  66         1043  
72 66     66   6371 use PPI ();
  66         121  
  66         3032  
73 66     66   786 use PPI::Node ();
  66         870  
  66         956  
74 66     66   30238 use YAML::PP ();
  66         3914692  
  66         2340  
75              
76 66     66   512 use overload 'bool' => \&PPI::Util::TRUE;
  66         136  
  66         311  
77 66     66   3214 use overload '""' => 'content';
  66         125  
  66         230  
78              
79             our $VERSION = '1.284';
80              
81             our ( $errstr, @ISA ) = ( "", "PPI::Node" );
82              
83 66     66   25318 use PPI::Document::Fragment ();
  66         143  
  66         1681  
84              
85             # Document cache
86             my $CACHE;
87              
88             # Convenience constants related to constants
89 66     66   288 use constant LOCATION_LINE => 0;
  66         95  
  66         4140  
90 66     66   267 use constant LOCATION_CHARACTER => 1;
  66         108  
  66         2415  
91 66     66   259 use constant LOCATION_COLUMN => 2;
  66         117  
  66         2255  
92 66     66   268 use constant LOCATION_LOGICAL_LINE => 3;
  66         106  
  66         2187  
93 66     66   233 use constant LOCATION_LOGICAL_FILE => 4;
  66         102  
  66         191943  
94              
95              
96              
97              
98              
99             #####################################################################
100             # Constructor and Static Methods
101              
102             =pod
103              
104             =head2 new
105              
106             # Simple construction
107             $doc = PPI::Document->new( $filename );
108             $doc = PPI::Document->new( \$source );
109            
110             # With the readonly attribute set
111             $doc = PPI::Document->new( $filename,
112             readonly => 1,
113             );
114              
115             The C<new> constructor takes as argument a variety of different sources of
116             Perl code, and creates a single cohesive Perl C<PPI::Document>
117             for it.
118              
119             If passed a file name as a normal string, it will attempt to load the
120             document from the file.
121              
122             If passed a reference to a C<SCALAR>, this is taken to be source code and
123             parsed directly to create the document.
124              
125             If passed zero arguments, a "blank" document will be created that contains
126             no content at all.
127              
128             In all cases, the document is considered to be "anonymous" and not tied back
129             to where it was created from. Specifically, if you create a PPI::Document from
130             a filename, the document will B<not> remember where it was created from.
131              
132             Returns a C<PPI::Document> object, or C<undef> if parsing fails.
133             L<PPI::Exception> objects can also be thrown if there are parsing problems.
134              
135             The constructor also takes attribute flags.
136              
137             =head3 readonly
138              
139             Setting C<readonly> to true will allow various systems to provide additional
140             optimisations and caching. Note that because C<readonly> is an optimisation
141             flag, it is off by default and you will need to explicitly enable it.
142              
143             =head3 feature_mods
144              
145             Setting feature_mods with a hashref allows defining perl parsing features to be
146             enabled for the whole document. (e.g. when the code is assumed to be run as a
147             oneliner)
148              
149             =head3 custom_feature_includes
150              
151             custom_feature_includes =>
152             { strEct => { signatures => "Syntax::Keyword::Try" } }
153              
154             Setting custom_feature_includes with a hashref allows defining include names
155             which act like pragmas that enable parsing features within their scope.
156              
157             This is mostly useful when your work project has its own boilerplate module.
158              
159             It can also be provided as JSON or YAML in the environment variable
160             PPI_CUSTOM_FEATURE_INCLUDES, like so:
161              
162             PPI_CUSTOM_FEATURE_INCLUDES='strEct: {signatures: perl}' \
163             perlcritic lib/OurModule.pm
164              
165             PPI_CUSTOM_FEATURE_INCLUDES='{"strEct":{"signatures":"perl"}}' \
166             perlcritic lib/OurModule.pm
167              
168             =head3 custom_feature_include_cb
169              
170             custom_feature_include_cb => sub {
171             my ($statement) = @_;
172             return $statement->module eq "strEct" ? { signatures => "perl" } : ();
173             },
174              
175             Setting custom_feature_include_cb with a code reference causes all inspections
176             on includes to call that sub before doing any other inspections. The sub can
177             decide to either return a hashref of features to be enabled or disabled, which
178             will be used for the scope the include was called in, or undef to continue with
179             the default inspections. The argument to the sub will be the
180             L<PPI::Statement::Include> object.
181              
182             This can be useful when your work project has a complex boilerplate module.
183              
184             =cut
185              
186             sub new {
187 33599     33599 1 31761258 local $_; # An extra one, just in case
188 33599 50       67447 my $class = ref $_[0] ? ref shift : shift;
189              
190 33599 100       66467 unless ( @_ ) {
191 16801         55026 my $self = $class->SUPER::new;
192 16801         40023 $self->{readonly} = ! 1;
193 16801         28627 $self->{tab_width} = 1;
194 16801         36251 return $self;
195             }
196              
197             # Check constructor attributes
198 16798         31968 my $source = shift;
199 16798         28932 my %attr = @_;
200              
201             # Check the data source
202 16798 50       77238 if ( ! defined $source ) {
    100          
    100          
    50          
203 0         0 $class->_error("An undefined value was passed to PPI::Document::new");
204              
205             } elsif ( ! ref $source ) {
206             # Catch people using the old API
207 509 50       3430 if ( $source =~ /(?:\012|\015)/ ) {
208 0         0 Carp::croak("API CHANGE: Source code should only be passed to PPI::Document->new as a SCALAR reference");
209             }
210              
211             # Save the filename
212 509   66     3837 $attr{filename} ||= $source;
213              
214             # When loading from a filename, use the caching layer if it exists.
215 509 100       1373 if ( $CACHE ) {
216 3         10 my $file_contents = PPI::Util::_slurp( $source );
217              
218             # Errors returned as plain string
219 3 50       7 return $class->_error($file_contents) if !ref $file_contents;
220              
221             # Retrieve the document from the cache
222 3         9 my $document = $CACHE->get_document($file_contents);
223 3 100       15 return $class->_setattr( $document, %attr ) if $document;
224              
225 1         10 $document = PPI::Lexer->lex_source( $$file_contents, %attr );
226 1 50       25 if ( $document ) {
227             # Save in the cache
228 1         6 $CACHE->store_document( $document );
229 1         62 return $document;
230             }
231             } else {
232 506         5204 my $document = PPI::Lexer->lex_file( $source, %attr );
233 506 50       4413 return $document if $document;
234             }
235              
236             } elsif ( _SCALAR0($source) ) {
237 16286         68353 my $document = PPI::Lexer->lex_source( $$source, %attr );
238 16286 100       75372 return $document if $document;
239              
240             } elsif ( _ARRAY0($source) ) {
241 3         8 $source = join '', map { "$_\n" } @$source;
  5         10  
242 3         11 my $document = PPI::Lexer->lex_source( $source, %attr );
243 3 50       17 return $document if $document;
244              
245             } else {
246 0         0 $class->_error("Unknown object or reference was passed to PPI::Document::new");
247             }
248              
249             # Pull and store the error from the lexer
250 1         2 my $errstr;
251 1 50       3 if ( _INSTANCE($@, 'PPI::Exception') ) {
    0          
    0          
252 1         3 $errstr = $@->message;
253             } elsif ( $@ ) {
254 0         0 $errstr = $@;
255 0         0 $errstr =~ s/\sat line\s.+$//;
256             } elsif ( PPI::Lexer->errstr ) {
257 0         0 $errstr = PPI::Lexer->errstr;
258             } else {
259 0         0 $errstr = "Unknown error parsing Perl document";
260             }
261 1         3 PPI::Lexer->_clear;
262 1         3 $class->_error( $errstr );
263             }
264              
265             sub load {
266 0     0 0 0 Carp::croak("API CHANGE: File names should now be passed to PPI::Document->new to load a file");
267             }
268              
269             sub _setattr {
270 16801     16801   32016 my ( $class, $document, %attr ) = @_;
271 16801         33133 $document->{readonly} = !!$attr{readonly};
272 16801         30225 $document->{filename} = $attr{filename};
273 16801         26271 $document->{feature_mods} = $attr{feature_mods};
274 16801         32973 $document->{custom_feature_includes} = $attr{custom_feature_includes};
275 16801         37840 $document->{custom_feature_include_cb} = $attr{custom_feature_include_cb};
276 16801 100       43303 if ( $ENV{PPI_CUSTOM_FEATURE_INCLUDES} ) {
277 1         4 my $includes = YAML::PP::Load $ENV{PPI_CUSTOM_FEATURE_INCLUDES};
278 1 50       5634 die "\$ENV{PPI_CUSTOM_FEATURE_INCLUDES} "
279             . "does not contain valid perl:\n"
280             . "val: '$ENV{PPI_CUSTOM_FEATURE_INCLUDES}'\nerr: $@"
281             if $@;
282             $document->{custom_feature_includes} =
283 1 50       2 { %{ $document->{custom_feature_includes} || {} }, %{$includes} };
  1         6  
  1         4  
284             }
285 16801         29578 return $document;
286             }
287              
288             =pod
289              
290             =head2 set_cache $cache
291              
292             As of L<PPI> 1.100, C<PPI::Document> supports parser caching.
293              
294             The default cache class L<PPI::Cache> provides a L<Storable>-based
295             caching or the parsed document based on the MD5 hash of the document as
296             a string.
297              
298             The static C<set_cache> method is used to set the cache object for
299             C<PPI::Document> to use when loading documents. It takes as argument
300             a L<PPI::Cache> object (or something that C<isa> the same).
301              
302             If passed C<undef>, this method will stop using the current cache, if any.
303              
304             For more information on caching, see L<PPI::Cache>.
305              
306             Returns true on success, or C<undef> if not passed a valid param.
307              
308             =cut
309              
310             sub set_cache {
311 3 50   3 1 13 my $class = ref $_[0] ? ref shift : shift;
312              
313 3 100       8 if ( defined $_[0] ) {
314             # Enable the cache
315 2 50       17 my $object = _INSTANCE(shift, 'PPI::Cache') or return undef;
316 2         2 $CACHE = $object;
317             } else {
318             # Disable the cache
319 1         2 $CACHE = undef;
320             }
321              
322 3         10 1;
323             }
324              
325             =pod
326              
327             =head2 get_cache
328              
329             If a document cache is currently set, the C<get_cache> method will
330             return it.
331              
332             Returns a L<PPI::Cache> object, or C<undef> if there is no cache
333             currently set for C<PPI::Document>.
334              
335             =cut
336              
337             sub get_cache {
338 7     7 1 1169 $CACHE;
339             }
340              
341              
342              
343              
344              
345             #####################################################################
346             # PPI::Document Instance Methods
347              
348             =pod
349              
350             =head2 filename
351              
352             The C<filename> accessor returns the name of the file in which the document
353             is stored.
354              
355             =cut
356              
357             sub filename {
358 263     263 1 1521 $_[0]->{filename};
359             }
360              
361             =pod
362              
363             =head2 readonly
364              
365             The C<readonly> attribute indicates if the document is intended to be
366             read-only, and will never be modified. This is an advisory flag, that
367             writers of L<PPI>-related systems may or may not use to enable
368             optimisations and caches for your document.
369              
370             Returns true if the document is read-only or false if not.
371              
372             =cut
373              
374             sub readonly {
375 4     4 1 4358 $_[0]->{readonly};
376             }
377              
378             =pod
379              
380             =head2 tab_width [ $width ]
381              
382             In order to handle support for C<location> correctly, C<Documents>
383             need to understand the concept of tabs and tab width. The C<tab_width>
384             method is used to get and set the size of the tab width.
385              
386             At the present time, PPI only supports "naive" (width 1) tabs, but we do
387             plan on supporting arbitrary, default and auto-sensing tab widths later.
388              
389             Returns the tab width as an integer, or C<die>s if you attempt to set the
390             tab width.
391              
392             =cut
393              
394             sub tab_width {
395 57948     57948 1 56988 my $self = shift;
396 57948 100       94514 return $self->{tab_width} unless @_;
397 2         6 $self->{tab_width} = shift;
398             }
399              
400             =head2 feature_mods { feature_name => $provider }
401              
402             =cut
403              
404             sub feature_mods {
405 67238     67238 1 82936 my $self = shift;
406 67238 50       282820 return $self->{feature_mods} unless @_;
407 0         0 $self->{feature_mods} = shift;
408             }
409              
410             =head2 custom_feature_includes { module_name => { feature_name => $provider } }
411              
412             =cut
413              
414             sub custom_feature_includes {
415 212234     212234 1 216686 my $self = shift;
416 212234 50       787238 return $self->{custom_feature_includes} unless @_;
417 0         0 $self->{custom_feature_includes} = shift;
418             }
419              
420             =head2 custom_feature_include_cb sub { ... }
421              
422             =cut
423              
424             sub custom_feature_include_cb {
425 213317     213317 1 210166 my $self = shift;
426 213317 50       1073797 return $self->{custom_feature_include_cb} unless @_;
427 0         0 $self->{custom_feature_include_cb} = shift;
428             }
429              
430             =pod
431              
432             =head2 save
433              
434             $document->save( $file )
435            
436             The C<save> method serializes the C<PPI::Document> object and saves the
437             resulting Perl document to a file. Returns C<undef> on failure to open
438             or write to the file.
439              
440             =cut
441              
442             sub save {
443 2     2 1 4 my $self = shift;
444 2         4 local *FILE;
445 2 50       280 open( FILE, '>', $_[0] ) or return undef;
446 2         7 binmode FILE;
447 2 50       9 print FILE $self->serialize or return undef;
448 2 50       195 close FILE or return undef;
449 2         29 return 1;
450             }
451              
452             =pod
453              
454             =head2 serialize
455              
456             Unlike the C<content> method, which shows only the immediate content
457             within an element, Document objects also have to be able to be written
458             out to a file again.
459              
460             When doing this we need to take into account some additional factors.
461              
462             Primarily, we need to handle here-docs correctly, so that are written
463             to the file in the expected place.
464              
465             The C<serialize> method generates the actual file content for a given
466             Document object. The resulting string can be written straight to a file.
467              
468             Returns the serialized document as a string.
469              
470             =cut
471              
472             sub serialize {
473 7207     7207 1 9495778 my $self = shift;
474 7207         27856 my @tokens = $self->tokens;
475              
476             # The here-doc content buffer
477 7207         12605 my $heredoc = '';
478              
479             # Start the main loop
480 7207         10641 my $output = '';
481 7207         20302 foreach my $i ( 0 .. $#tokens ) {
482 277509         276187 my $Token = $tokens[$i];
483              
484             # Handle normal tokens
485 277509 100       542520 unless ( $Token->isa('PPI::Token::HereDoc') ) {
486 276878         356121 my $content = $Token->content;
487              
488             # Handle the trivial cases
489 276878 100 100     399720 unless ( $heredoc ne '' and $content =~ /\n/ ) {
490 276435         256825 $output .= $content;
491 276435         289117 next;
492             }
493              
494             # We have pending here-doc content that needs to be
495             # inserted just after the first newline in the content.
496 443 100       816 if ( $content eq "\n" ) {
497             # Shortcut the most common case for speed
498 321         510 $output .= $content . $heredoc;
499             } else {
500             # Slower and more general version
501 122         751 $content =~ s/\n/\n$heredoc/;
502 122         226 $output .= $content;
503             }
504              
505 443         593 $heredoc = '';
506 443         814 next;
507             }
508              
509             # This token is a HereDoc.
510             # First, add the token content as normal, which in this
511             # case will definitely not contain a newline.
512 631         1431 $output .= $Token->content;
513              
514             # Pick up the indentation, which may be undef.
515 631   100     1665 my $indentation = $Token->indentation || '';
516              
517             # Now add all of the here-doc content to the heredoc buffer.
518 631         1322 foreach my $line ( $Token->heredoc ) {
519 989 100       2164 $heredoc .= "\n" eq $line ? $line : $indentation . $line;
520             }
521              
522 631 100       1347 if ( $Token->{_damaged} ) {
523             # Special Case:
524             # There are a couple of warning/bug situations
525             # that can occur when a HereDoc content was read in
526             # from the end of a file that we silently allow.
527             #
528             # When writing back out to the file we have to
529             # auto-repair these problems if we aren't going back
530             # on to the end of the file.
531              
532             # When calculating $last_line, ignore the final token if
533             # and only if it has a single newline at the end.
534 459         648 my $last_index = $#tokens;
535 459 100       2503 if ( $tokens[$last_index]->{content} =~ /^[^\n]*\n$/ ) {
536 283         417 $last_index--;
537             }
538              
539             # This is a two part test.
540             # First, are we on the last line of the
541             # content part of the file
542             my $last_line = List::Util::none {
543 1225 50   1225   4743 $tokens[$_] and $tokens[$_]->{content} =~ /\n/
544 459         3385 } (($i + 1) .. $last_index);
545 459 50       1995 if ( ! defined $last_line ) {
546             # Handles the null list case
547 0         0 $last_line = 1;
548             }
549              
550             # Secondly, are their any more here-docs after us,
551             # (with content or a terminator)
552             my $any_after = List::Util::any {
553             $tokens[$_]->isa('PPI::Token::HereDoc')
554             and (
555 2         8 scalar(@{$tokens[$_]->{_heredoc}})
556             or
557             defined $tokens[$_]->{_terminator_line}
558             )
559 459 100 33 1508   1764 } (($i + 1) .. $#tokens);
  1508         4192  
560 459 50       1599 if ( ! defined $any_after ) {
561             # Handles the null list case
562 0         0 $any_after = '';
563             }
564              
565             # We don't need to repair the last here-doc on the
566             # last line. But we do need to repair anything else.
567 459 50 33     1639 unless ( $last_line and ! $any_after ) {
568             # Add a terminating string if it didn't have one
569 0 0       0 unless ( defined $Token->{_terminator_line} ) {
570 0         0 $Token->{_terminator_line} = $Token->{_terminator};
571             }
572              
573             # Add a trailing newline to the terminating
574             # string if it didn't have one.
575 0 0       0 unless ( $Token->{_terminator_line} =~ /\n$/ ) {
576 0         0 $Token->{_terminator_line} .= "\n";
577             }
578             }
579             }
580              
581             # Now add the termination line to the heredoc buffer
582 631 100       1472 if ( defined $Token->{_terminator_line} ) {
583 179         342 $heredoc .= $indentation . $Token->{_terminator_line};
584             }
585             }
586              
587             # End of tokens
588              
589 7207 50       13439 if ( $heredoc ne '' ) {
590             # If the file doesn't end in a newline, we need to add one
591             # so that the here-doc content starts on the next line.
592 0 0       0 unless ( $output =~ /\n$/ ) {
593 0         0 $output .= "\n";
594             }
595              
596             # Now we add the remaining here-doc content
597             # to the end of the file.
598 0         0 $output .= $heredoc;
599             }
600              
601 7207         41773 $output;
602             }
603              
604             =pod
605              
606             =head2 hex_id
607              
608             The C<hex_id> method generates an unique identifier for the Perl document.
609              
610             This identifier is basically just the serialized document, with
611             Unix-specific newlines, passed through MD5 to produce a hexadecimal string.
612              
613             This identifier is used by a variety of systems (such as L<PPI::Cache>
614             and L<Perl::Metrics>) as a unique key against which to store or cache
615             information about a document (or indeed, to cache the document itself).
616              
617             Returns a 32 character hexadecimal string.
618              
619             =cut
620              
621             sub hex_id {
622 166     166 1 295197 PPI::Util::md5hex($_[0]->serialize);
623             }
624              
625             =pod
626              
627             =head2 index_locations
628              
629             Within a document, all L<PPI::Element> objects can be considered to have a
630             "location", a line/column position within the document when considered as a
631             file. This position is primarily useful for debugging type activities.
632              
633             The method for finding the position of a single Element is a bit laborious,
634             and very slow if you need to do it a lot. So the C<index_locations> method
635             will index and save the locations of every Element within the Document in
636             advance, making future calls to <PPI::Element::location> virtually free.
637              
638             Please note that this index should always be cleared using C<flush_locations>
639             once you are finished with the locations. If content is added to or removed
640             from the file, these indexed locations will be B<wrong>.
641              
642             =cut
643              
644             sub index_locations {
645 259     259 1 132291 my $self = shift;
646 259         1147 my @tokens = $self->tokens;
647              
648             # Whenever we hit a heredoc we will need to increment by
649             # the number of lines in its content section when we
650             # encounter the next token with a newline in it.
651 259         686 my $heredoc = 0;
652              
653             # Find the first Token without a location
654 259         626 my ($first, $location) = ();
655 259         1009 foreach ( 0 .. $#tokens ) {
656 259         538 my $Token = $tokens[$_];
657 259 50       748 next if $Token->{_location};
658              
659             # Found the first Token without a location
660             # Calculate the new location if needed.
661 259 50       1300 $location =
662             $_
663             ? $self->_add_location( $location, $tokens[ $_ - 1 ], \$heredoc )
664             : $self->_default_location;
665 259         429 $first = $_;
666 259         565 last;
667             }
668              
669             # Calculate locations for the rest
670 259 50       773 if ( defined $first ) {
671 259         665 foreach ( $first .. $#tokens ) {
672 68803         74952 my $Token = $tokens[$_];
673 68803         82654 $Token->{_location} = $location;
674 68803         81758 $location = $self->_add_location( $location, $Token, \$heredoc );
675              
676             # Add any here-doc lines to the counter
677 68803 100       161490 if ( $Token->isa('PPI::Token::HereDoc') ) {
678 34         143 $heredoc += $Token->heredoc + 1;
679             }
680             }
681             }
682              
683 259         6602 1;
684             }
685              
686             sub _default_location {
687 262     262   545 my ($self) = @_;
688 262 50       1564 my $logical_file = $self->can('filename') ? $self->filename : undef;
689 262         1109 return [ 1, 1, 1, 1, $logical_file ];
690             }
691              
692             sub location {
693 3     3 1 554 my ($self) = @_;
694 3   33     11 return $self->SUPER::location || $self->_default_location;
695             }
696              
697             sub _add_location {
698 68803     68803   78910 my ($self, $start, $Token, $heredoc) = @_;
699 68803         90734 my $content = $Token->{content};
700              
701             # Does the content contain any newlines
702 68803         83183 my $newlines =()= $content =~ /\n/g;
703 68803         85249 my ($logical_line, $logical_file) =
704             $self->_logical_line_and_file($start, $Token, $newlines);
705              
706 68803 100       94472 unless ( $newlines ) {
707             # Handle the simple case
708             return [
709 57641         80498 $start->[LOCATION_LINE],
710             $start->[LOCATION_CHARACTER] + length($content),
711             $start->[LOCATION_COLUMN]
712             + $self->_visual_length(
713             $content,
714             $start->[LOCATION_COLUMN]
715             ),
716             $logical_line,
717             $logical_file,
718             ];
719             }
720              
721             # This is the more complex case where we hit or
722             # span a newline boundary.
723 11162         11190 my $physical_line = $start->[LOCATION_LINE] + $newlines;
724 11162         19439 my $location = [ $physical_line, 1, 1, $logical_line, $logical_file ];
725 11162 100 66     25948 if ( $heredoc and $$heredoc ) {
726 31         43 $location->[LOCATION_LINE] += $$heredoc;
727 31         53 $location->[LOCATION_LOGICAL_LINE] += $$heredoc;
728 31         52 $$heredoc = 0;
729             }
730              
731             # Does the token have additional characters
732             # after their last newline.
733 11162 100       24700 if ( $content =~ /\n([^\n]+?)\z/ ) {
734 304         917 $location->[LOCATION_CHARACTER] += length($1);
735 304         526 $location->[LOCATION_COLUMN] +=
736             $self->_visual_length(
737             $1, $location->[LOCATION_COLUMN],
738             );
739             }
740              
741 11162         14907 $location;
742             }
743              
744             sub _logical_line_and_file {
745 68803     68803   73738 my ($self, $start, $Token, $newlines) = @_;
746              
747             # Regex taken from perlsyn, with the correction that there's no space
748             # required between the line number and the file name.
749 68803 100       91955 if ($start->[LOCATION_CHARACTER] == 1) {
750 10884 100       32043 if ( $Token->isa('PPI::Token::Comment') ) {
    100          
751 1771 100       3377 if (
752             $Token->content =~ m<
753             \A
754             \# \s*
755             line \s+
756             (\d+) \s*
757             (?: (\"?) ([^\"]* [^\s\"]) \2 )?
758             \s*
759             \z
760             >xms
761             ) {
762 13   66     77 return $1, ($3 || $start->[LOCATION_LOGICAL_FILE]);
763             }
764             }
765             elsif ( $Token->isa('PPI::Token::Pod') ) {
766 351         1201 my $content = $Token->content;
767 351         740 my $line;
768 351         524 my $file = $start->[LOCATION_LOGICAL_FILE];
769 351         467 my $end_of_directive;
770 351         1335 while (
771             $content =~ m<
772             ^
773             \# \s*?
774             line \s+?
775             (\d+) (?: (?! \n) \s)*
776             (?: (\"?) ([^\"]*? [^\s\"]) \2 )??
777             \s*?
778             $
779             >xmsg
780             ) {
781 6   66     32 ($line, $file) = ($1, ( $3 || $file ) );
782 6         11 $end_of_directive = pos $content;
783             }
784              
785 351 100       584 if (defined $line) {
786 6         8 pos $content = $end_of_directive;
787 6         20 my $post_directive_newlines =()= $content =~ m< \G [^\n]* \n >xmsg;
788 6         23 return $line + $post_directive_newlines - 1, $file;
789             }
790             }
791             }
792              
793             return
794 68784         109767 $start->[LOCATION_LOGICAL_LINE] + $newlines,
795             $start->[LOCATION_LOGICAL_FILE];
796             }
797              
798             sub _visual_length {
799 57945     57945   66635 my ($self, $content, $pos) = @_;
800              
801 57945         61476 my $tab_width = $self->tab_width;
802 57945         57562 my ($length, $vis_inc);
803              
804 57945 100       153393 return length $content if $content !~ /\t/;
805              
806             # Split the content in tab and non-tab parts and calculate the
807             # "visual increase" of each part.
808 4410         13663 for my $part ( split(/(\t)/, $content) ) {
809 16147 100       18232 if ($part eq "\t") {
810 8040         8071 $vis_inc = $tab_width - ($pos-1) % $tab_width;
811             }
812             else {
813 8107         7106 $vis_inc = length $part;
814             }
815 16147         14118 $length += $vis_inc;
816 16147         14981 $pos += $vis_inc;
817             }
818              
819 4410         11240 $length;
820             }
821              
822             =pod
823              
824             =head2 flush_locations
825              
826             When no longer needed, the C<flush_locations> method clears all location data
827             from the tokens.
828              
829             =cut
830              
831             sub flush_locations {
832 1     1 1 682 shift->_flush_locations(@_);
833             }
834              
835             =pod
836              
837             =head2 normalized
838              
839             The C<normalized> method is used to generate a "Layer 1"
840             L<PPI::Document::Normalized> object for the current Document.
841              
842             A "normalized" Perl Document is an arbitrary structure that removes any
843             irrelevant parts of the document and refactors out variations in style,
844             to attempt to approach something that is closer to the "true meaning"
845             of the Document.
846              
847             See L<PPI::Normal> for more information on document normalization and
848             the tasks for which it is useful.
849              
850             Returns a L<PPI::Document::Normalized> object, or C<undef> on error.
851              
852             =cut
853              
854             sub normalized {
855             # The normalization process will utterly destroy and mangle
856             # anything passed to it, so we are going to only give it a
857             # clone of ourselves.
858 4     4 1 2273 PPI::Normal->process( $_[0]->clone );
859             }
860              
861             =pod
862              
863             =head1 complete
864              
865             The C<complete> method is used to determine if a document is cleanly
866             structured, all braces are closed, the final statement is
867             fully terminated and all heredocs are fully entered.
868              
869             Returns true if the document is complete or false if not.
870              
871             =cut
872              
873             sub complete {
874 2     2 0 2114 my $self = shift;
875              
876             # Every structure has to be complete
877             $self->find_any( sub {
878 15 50   15   47 $_[1]->isa('PPI::Structure')
879             and
880             ! $_[1]->complete
881             } )
882 2 50       15 and return '';
883              
884             # Strip anything that isn't a statement off the end
885 2         11 my @child = $self->children;
886 2   66     21 while ( @child and not $child[-1]->isa('PPI::Statement') ) {
887 2         7 pop @child;
888             }
889              
890             # We must have at least one statement
891 2 50       5 return '' unless @child;
892              
893             # Check the completeness of the last statement
894 2         8 return $child[-1]->_complete;
895             }
896              
897              
898              
899              
900              
901             #####################################################################
902             # PPI::Node Methods
903              
904             # We are a scope boundary
905             ### XS -> PPI/XS.xs:_PPI_Document__scope 0.903+
906             sub scope() { 1 }
907              
908              
909              
910              
911              
912             #####################################################################
913             # PPI::Element Methods
914              
915             sub insert_before {
916 0     0 1 0 return undef;
917             # die "Cannot insert_before a PPI::Document";
918             }
919              
920             sub insert_after {
921 0     0 1 0 return undef;
922             # die "Cannot insert_after a PPI::Document";
923             }
924              
925             sub replace {
926 0     0 1 0 return undef;
927             # die "Cannot replace a PPI::Document";
928             }
929              
930              
931              
932              
933              
934             #####################################################################
935             # Error Handling
936              
937             # Set the error message
938             sub _error {
939 1     1   2 $errstr = $_[1];
940 1         3 undef;
941             }
942              
943             # Clear the error message.
944             # Returns the object as a convenience.
945             sub _clear {
946 16744     16744   50252 $errstr = '';
947 16744         22254 $_[0];
948             }
949              
950             =pod
951              
952             =head2 errstr
953              
954             For error that occur when loading and saving documents, you can use
955             C<errstr>, as either a static or object method, to access the error message.
956              
957             If a Document loads or saves without error, C<errstr> will return false.
958              
959             =cut
960              
961             sub errstr {
962 16744     16744 1 81244 $errstr;
963             }
964              
965              
966              
967              
968              
969             #####################################################################
970             # Native Storable Support
971              
972             sub STORABLE_freeze {
973 4     4 0 860 my $self = shift;
974 4         9 my $class = ref $self;
975 4         29 my %hash = %$self;
976 4         607 return ($class, \%hash);
977             }
978              
979             sub STORABLE_thaw {
980 6     6 0 591 my ($self, undef, $class, $hash) = @_;
981 6         13 bless $self, $class;
982 6         24 foreach ( keys %$hash ) {
983 42         67 $self->{$_} = delete $hash->{$_};
984             }
985 6         30 $self->__link_children;
986             }
987              
988             1;
989              
990             =pod
991              
992             =head1 TO DO
993              
994             - May need to overload some methods to forcefully prevent Document
995             objects becoming children of another Node.
996              
997             =head1 SUPPORT
998              
999             See the L<support section|PPI/SUPPORT> in the main module.
1000              
1001             =head1 AUTHOR
1002              
1003             Adam Kennedy E<lt>adamk@cpan.orgE<gt>
1004              
1005             =head1 SEE ALSO
1006              
1007             L<PPI>, L<https://web.archive.org/web/20230911221703/http://ali.as/>
1008              
1009             =head1 COPYRIGHT
1010              
1011             Copyright 2001 - 2011 Adam Kennedy.
1012              
1013             This program is free software; you can redistribute
1014             it and/or modify it under the same terms as Perl itself.
1015              
1016             The full text of the license can be found in the
1017             LICENSE file included with this module.
1018              
1019             =cut