Initial Commit
This commit is contained in:
Riley Schneider
926
database/perl/vendor/lib/PPI/Document.pm
vendored
Normal file
926
database/perl/vendor/lib/PPI/Document.pm
vendored
Normal file
@@ -0,0 +1,926 @@
|
||||
package PPI::Document;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
PPI::Document - Object representation of a Perl document
|
||||
|
||||
=head1 INHERITANCE
|
||||
|
||||
PPI::Document
|
||||
isa PPI::Node
|
||||
isa PPI::Element
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use PPI;
|
||||
|
||||
# Load a document from a file
|
||||
my $Document = PPI::Document->new('My/Module.pm');
|
||||
|
||||
# Strip out comments
|
||||
$Document->prune('PPI::Token::Comment');
|
||||
|
||||
# Find all the named subroutines
|
||||
my $sub_nodes = $Document->find(
|
||||
sub { $_[1]->isa('PPI::Statement::Sub') and $_[1]->name }
|
||||
);
|
||||
my @sub_names = map { $_->name } @$sub_nodes;
|
||||
|
||||
# Save the file
|
||||
$Document->save('My/Module.pm.stripped');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<PPI::Document> class represents a single Perl "document". A
|
||||
C<PPI::Document> object acts as a root L<PPI::Node>, with some
|
||||
additional methods for loading and saving, and working with
|
||||
the line/column locations of Elements within a file.
|
||||
|
||||
The exemption to its L<PPI::Node>-like behavior this is that a
|
||||
C<PPI::Document> object can NEVER have a parent node, and is always
|
||||
the root node in a tree.
|
||||
|
||||
=head2 Storable Support
|
||||
|
||||
C<PPI::Document> implements the necessary C<STORABLE_freeze> and
|
||||
C<STORABLE_thaw> hooks to provide native support for L<Storable>,
|
||||
if you have it installed.
|
||||
|
||||
However if you want to clone a Document, you are highly recommended
|
||||
to use the C<$Document-E<gt>clone> method rather than Storable's
|
||||
C<dclone> function (although C<dclone> should still work).
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Most of the things you are likely to want to do with a Document are
|
||||
probably going to involve the methods from L<PPI::Node> class, of which
|
||||
this is a subclass.
|
||||
|
||||
The methods listed here are the remaining few methods that are truly
|
||||
Document-specific.
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp ();
|
||||
use List::Util 1.33 ();
|
||||
use Params::Util 1.00 qw{_SCALAR0 _ARRAY0 _INSTANCE};
|
||||
use Digest::MD5 ();
|
||||
use PPI::Util ();
|
||||
use PPI ();
|
||||
use PPI::Node ();
|
||||
|
||||
use overload 'bool' => \&PPI::Util::TRUE;
|
||||
use overload '""' => 'content';
|
||||
|
||||
our $VERSION = '1.270'; # VERSION
|
||||
|
||||
our ( $errstr, @ISA ) = ( "", "PPI::Node" );
|
||||
|
||||
use PPI::Document::Fragment ();
|
||||
|
||||
# Document cache
|
||||
my $CACHE;
|
||||
|
||||
# Convenience constants related to constants
|
||||
use constant LOCATION_LINE => 0;
|
||||
use constant LOCATION_CHARACTER => 1;
|
||||
use constant LOCATION_COLUMN => 2;
|
||||
use constant LOCATION_LOGICAL_LINE => 3;
|
||||
use constant LOCATION_LOGICAL_FILE => 4;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Constructor and Static Methods
|
||||
|
||||
=pod
|
||||
|
||||
=head2 new
|
||||
|
||||
# Simple construction
|
||||
$doc = PPI::Document->new( $filename );
|
||||
$doc = PPI::Document->new( \$source );
|
||||
|
||||
# With the readonly attribute set
|
||||
$doc = PPI::Document->new( $filename,
|
||||
readonly => 1,
|
||||
);
|
||||
|
||||
The C<new> constructor takes as argument a variety of different sources of
|
||||
Perl code, and creates a single cohesive Perl C<PPI::Document>
|
||||
for it.
|
||||
|
||||
If passed a file name as a normal string, it will attempt to load the
|
||||
document from the file.
|
||||
|
||||
If passed a reference to a C<SCALAR>, this is taken to be source code and
|
||||
parsed directly to create the document.
|
||||
|
||||
If passed zero arguments, a "blank" document will be created that contains
|
||||
no content at all.
|
||||
|
||||
In all cases, the document is considered to be "anonymous" and not tied back
|
||||
to where it was created from. Specifically, if you create a PPI::Document from
|
||||
a filename, the document will B<not> remember where it was created from.
|
||||
|
||||
The constructor also takes attribute flags.
|
||||
|
||||
At this time, the only available attribute is the C<readonly> flag.
|
||||
|
||||
Setting C<readonly> to true will allow various systems to provide
|
||||
additional optimisations and caching. Note that because C<readonly> is an
|
||||
optimisation flag, it is off by default and you will need to explicitly
|
||||
enable it.
|
||||
|
||||
Returns a C<PPI::Document> object, or C<undef> if parsing fails.
|
||||
L<PPI::Exception> objects can also be thrown if there are parsing problems.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
local $_; # An extra one, just in case
|
||||
my $class = ref $_[0] ? ref shift : shift;
|
||||
|
||||
unless ( @_ ) {
|
||||
my $self = $class->SUPER::new;
|
||||
$self->{readonly} = ! 1;
|
||||
$self->{tab_width} = 1;
|
||||
return $self;
|
||||
}
|
||||
|
||||
# Check constructor attributes
|
||||
my $source = shift;
|
||||
my %attr = @_;
|
||||
|
||||
# Check the data source
|
||||
if ( ! defined $source ) {
|
||||
$class->_error("An undefined value was passed to PPI::Document::new");
|
||||
|
||||
} elsif ( ! ref $source ) {
|
||||
# Catch people using the old API
|
||||
if ( $source =~ /(?:\012|\015)/ ) {
|
||||
Carp::croak("API CHANGE: Source code should only be passed to PPI::Document->new as a SCALAR reference");
|
||||
}
|
||||
|
||||
# Save the filename
|
||||
$attr{filename} ||= $source;
|
||||
|
||||
# When loading from a filename, use the caching layer if it exists.
|
||||
if ( $CACHE ) {
|
||||
my $file_contents = PPI::Util::_slurp( $source );
|
||||
|
||||
# Errors returned as plain string
|
||||
return $class->_error($file_contents) if !ref $file_contents;
|
||||
|
||||
# Retrieve the document from the cache
|
||||
my $document = $CACHE->get_document($file_contents);
|
||||
return $class->_setattr( $document, %attr ) if $document;
|
||||
|
||||
$document = PPI::Lexer->lex_source( $$file_contents );
|
||||
if ( $document ) {
|
||||
# Save in the cache
|
||||
$CACHE->store_document( $document );
|
||||
return $class->_setattr( $document, %attr );
|
||||
}
|
||||
} else {
|
||||
my $document = PPI::Lexer->lex_file( $source );
|
||||
return $class->_setattr( $document, %attr ) if $document;
|
||||
}
|
||||
|
||||
} elsif ( _SCALAR0($source) ) {
|
||||
my $document = PPI::Lexer->lex_source( $$source );
|
||||
return $class->_setattr( $document, %attr ) if $document;
|
||||
|
||||
} elsif ( _ARRAY0($source) ) {
|
||||
$source = join '', map { "$_\n" } @$source;
|
||||
my $document = PPI::Lexer->lex_source( $source );
|
||||
return $class->_setattr( $document, %attr ) if $document;
|
||||
|
||||
} else {
|
||||
$class->_error("Unknown object or reference was passed to PPI::Document::new");
|
||||
}
|
||||
|
||||
# Pull and store the error from the lexer
|
||||
my $errstr;
|
||||
if ( _INSTANCE($@, 'PPI::Exception') ) {
|
||||
$errstr = $@->message;
|
||||
} elsif ( $@ ) {
|
||||
$errstr = $@;
|
||||
$errstr =~ s/\sat line\s.+$//;
|
||||
} elsif ( PPI::Lexer->errstr ) {
|
||||
$errstr = PPI::Lexer->errstr;
|
||||
} else {
|
||||
$errstr = "Unknown error parsing Perl document";
|
||||
}
|
||||
PPI::Lexer->_clear;
|
||||
$class->_error( $errstr );
|
||||
}
|
||||
|
||||
sub load {
|
||||
Carp::croak("API CHANGE: File names should now be passed to PPI::Document->new to load a file");
|
||||
}
|
||||
|
||||
sub _setattr {
|
||||
my ($class, $document, %attr) = @_;
|
||||
$document->{readonly} = !! $attr{readonly};
|
||||
$document->{filename} = $attr{filename};
|
||||
return $document;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 set_cache $cache
|
||||
|
||||
As of L<PPI> 1.100, C<PPI::Document> supports parser caching.
|
||||
|
||||
The default cache class L<PPI::Cache> provides a L<Storable>-based
|
||||
caching or the parsed document based on the MD5 hash of the document as
|
||||
a string.
|
||||
|
||||
The static C<set_cache> method is used to set the cache object for
|
||||
C<PPI::Document> to use when loading documents. It takes as argument
|
||||
a L<PPI::Cache> object (or something that C<isa> the same).
|
||||
|
||||
If passed C<undef>, this method will stop using the current cache, if any.
|
||||
|
||||
For more information on caching, see L<PPI::Cache>.
|
||||
|
||||
Returns true on success, or C<undef> if not passed a valid param.
|
||||
|
||||
=cut
|
||||
|
||||
sub set_cache {
|
||||
my $class = ref $_[0] ? ref shift : shift;
|
||||
|
||||
if ( defined $_[0] ) {
|
||||
# Enable the cache
|
||||
my $object = _INSTANCE(shift, 'PPI::Cache') or return undef;
|
||||
$CACHE = $object;
|
||||
} else {
|
||||
# Disable the cache
|
||||
$CACHE = undef;
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 get_cache
|
||||
|
||||
If a document cache is currently set, the C<get_cache> method will
|
||||
return it.
|
||||
|
||||
Returns a L<PPI::Cache> object, or C<undef> if there is no cache
|
||||
currently set for C<PPI::Document>.
|
||||
|
||||
=cut
|
||||
|
||||
sub get_cache {
|
||||
$CACHE;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# PPI::Document Instance Methods
|
||||
|
||||
=pod
|
||||
|
||||
=head2 filename
|
||||
|
||||
The C<filename> accessor returns the name of the file in which the document
|
||||
is stored.
|
||||
|
||||
=cut
|
||||
|
||||
sub filename {
|
||||
$_[0]->{filename};
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 readonly
|
||||
|
||||
The C<readonly> attribute indicates if the document is intended to be
|
||||
read-only, and will never be modified. This is an advisory flag, that
|
||||
writers of L<PPI>-related systems may or may not use to enable
|
||||
optimisations and caches for your document.
|
||||
|
||||
Returns true if the document is read-only or false if not.
|
||||
|
||||
=cut
|
||||
|
||||
sub readonly {
|
||||
$_[0]->{readonly};
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 tab_width [ $width ]
|
||||
|
||||
In order to handle support for C<location> correctly, C<Documents>
|
||||
need to understand the concept of tabs and tab width. The C<tab_width>
|
||||
method is used to get and set the size of the tab width.
|
||||
|
||||
At the present time, PPI only supports "naive" (width 1) tabs, but we do
|
||||
plan on supporting arbitrary, default and auto-sensing tab widths later.
|
||||
|
||||
Returns the tab width as an integer, or C<die>s if you attempt to set the
|
||||
tab width.
|
||||
|
||||
=cut
|
||||
|
||||
sub tab_width {
|
||||
my $self = shift;
|
||||
return $self->{tab_width} unless @_;
|
||||
$self->{tab_width} = shift;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 save
|
||||
|
||||
$document->save( $file )
|
||||
|
||||
The C<save> method serializes the C<PPI::Document> object and saves the
|
||||
resulting Perl document to a file. Returns C<undef> on failure to open
|
||||
or write to the file.
|
||||
|
||||
=cut
|
||||
|
||||
sub save {
|
||||
my $self = shift;
|
||||
local *FILE;
|
||||
open( FILE, '>', $_[0] ) or return undef;
|
||||
binmode FILE;
|
||||
print FILE $self->serialize or return undef;
|
||||
close FILE or return undef;
|
||||
return 1;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 serialize
|
||||
|
||||
Unlike the C<content> method, which shows only the immediate content
|
||||
within an element, Document objects also have to be able to be written
|
||||
out to a file again.
|
||||
|
||||
When doing this we need to take into account some additional factors.
|
||||
|
||||
Primarily, we need to handle here-docs correctly, so that are written
|
||||
to the file in the expected place.
|
||||
|
||||
The C<serialize> method generates the actual file content for a given
|
||||
Document object. The resulting string can be written straight to a file.
|
||||
|
||||
Returns the serialized document as a string.
|
||||
|
||||
=cut
|
||||
|
||||
sub serialize {
|
||||
my $self = shift;
|
||||
my @tokens = $self->tokens;
|
||||
|
||||
# The here-doc content buffer
|
||||
my $heredoc = '';
|
||||
|
||||
# Start the main loop
|
||||
my $output = '';
|
||||
foreach my $i ( 0 .. $#tokens ) {
|
||||
my $Token = $tokens[$i];
|
||||
|
||||
# Handle normal tokens
|
||||
unless ( $Token->isa('PPI::Token::HereDoc') ) {
|
||||
my $content = $Token->content;
|
||||
|
||||
# Handle the trivial cases
|
||||
unless ( $heredoc ne '' and $content =~ /\n/ ) {
|
||||
$output .= $content;
|
||||
next;
|
||||
}
|
||||
|
||||
# We have pending here-doc content that needs to be
|
||||
# inserted just after the first newline in the content.
|
||||
if ( $content eq "\n" ) {
|
||||
# Shortcut the most common case for speed
|
||||
$output .= $content . $heredoc;
|
||||
} else {
|
||||
# Slower and more general version
|
||||
$content =~ s/\n/\n$heredoc/;
|
||||
$output .= $content;
|
||||
}
|
||||
|
||||
$heredoc = '';
|
||||
next;
|
||||
}
|
||||
|
||||
# This token is a HereDoc.
|
||||
# First, add the token content as normal, which in this
|
||||
# case will definitely not contain a newline.
|
||||
$output .= $Token->content;
|
||||
|
||||
# Now add all of the here-doc content to the heredoc buffer.
|
||||
foreach my $line ( $Token->heredoc ) {
|
||||
$heredoc .= $line;
|
||||
}
|
||||
|
||||
if ( $Token->{_damaged} ) {
|
||||
# Special Case:
|
||||
# There are a couple of warning/bug situations
|
||||
# that can occur when a HereDoc content was read in
|
||||
# from the end of a file that we silently allow.
|
||||
#
|
||||
# When writing back out to the file we have to
|
||||
# auto-repair these problems if we aren't going back
|
||||
# on to the end of the file.
|
||||
|
||||
# When calculating $last_line, ignore the final token if
|
||||
# and only if it has a single newline at the end.
|
||||
my $last_index = $#tokens;
|
||||
if ( $tokens[$last_index]->{content} =~ /^[^\n]*\n$/ ) {
|
||||
$last_index--;
|
||||
}
|
||||
|
||||
# This is a two part test.
|
||||
# First, are we on the last line of the
|
||||
# content part of the file
|
||||
my $last_line = List::Util::none {
|
||||
$tokens[$_] and $tokens[$_]->{content} =~ /\n/
|
||||
} (($i + 1) .. $last_index);
|
||||
if ( ! defined $last_line ) {
|
||||
# Handles the null list case
|
||||
$last_line = 1;
|
||||
}
|
||||
|
||||
# Secondly, are their any more here-docs after us,
|
||||
# (with content or a terminator)
|
||||
my $any_after = List::Util::any {
|
||||
$tokens[$_]->isa('PPI::Token::HereDoc')
|
||||
and (
|
||||
scalar(@{$tokens[$_]->{_heredoc}})
|
||||
or
|
||||
defined $tokens[$_]->{_terminator_line}
|
||||
)
|
||||
} (($i + 1) .. $#tokens);
|
||||
if ( ! defined $any_after ) {
|
||||
# Handles the null list case
|
||||
$any_after = '';
|
||||
}
|
||||
|
||||
# We don't need to repair the last here-doc on the
|
||||
# last line. But we do need to repair anything else.
|
||||
unless ( $last_line and ! $any_after ) {
|
||||
# Add a terminating string if it didn't have one
|
||||
unless ( defined $Token->{_terminator_line} ) {
|
||||
$Token->{_terminator_line} = $Token->{_terminator};
|
||||
}
|
||||
|
||||
# Add a trailing newline to the terminating
|
||||
# string if it didn't have one.
|
||||
unless ( $Token->{_terminator_line} =~ /\n$/ ) {
|
||||
$Token->{_terminator_line} .= "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Now add the termination line to the heredoc buffer
|
||||
if ( defined $Token->{_terminator_line} ) {
|
||||
$heredoc .= $Token->{_terminator_line};
|
||||
}
|
||||
}
|
||||
|
||||
# End of tokens
|
||||
|
||||
if ( $heredoc ne '' ) {
|
||||
# If the file doesn't end in a newline, we need to add one
|
||||
# so that the here-doc content starts on the next line.
|
||||
unless ( $output =~ /\n$/ ) {
|
||||
$output .= "\n";
|
||||
}
|
||||
|
||||
# Now we add the remaining here-doc content
|
||||
# to the end of the file.
|
||||
$output .= $heredoc;
|
||||
}
|
||||
|
||||
$output;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 hex_id
|
||||
|
||||
The C<hex_id> method generates an unique identifier for the Perl document.
|
||||
|
||||
This identifier is basically just the serialized document, with
|
||||
Unix-specific newlines, passed through MD5 to produce a hexadecimal string.
|
||||
|
||||
This identifier is used by a variety of systems (such as L<PPI::Cache>
|
||||
and L<Perl::Metrics>) as a unique key against which to store or cache
|
||||
information about a document (or indeed, to cache the document itself).
|
||||
|
||||
Returns a 32 character hexadecimal string.
|
||||
|
||||
=cut
|
||||
|
||||
sub hex_id {
|
||||
PPI::Util::md5hex($_[0]->serialize);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 index_locations
|
||||
|
||||
Within a document, all L<PPI::Element> objects can be considered to have a
|
||||
"location", a line/column position within the document when considered as a
|
||||
file. This position is primarily useful for debugging type activities.
|
||||
|
||||
The method for finding the position of a single Element is a bit laborious,
|
||||
and very slow if you need to do it a lot. So the C<index_locations> method
|
||||
will index and save the locations of every Element within the Document in
|
||||
advance, making future calls to <PPI::Element::location> virtually free.
|
||||
|
||||
Please note that this index should always be cleared using C<flush_locations>
|
||||
once you are finished with the locations. If content is added to or removed
|
||||
from the file, these indexed locations will be B<wrong>.
|
||||
|
||||
=cut
|
||||
|
||||
sub index_locations {
|
||||
my $self = shift;
|
||||
my @tokens = $self->tokens;
|
||||
|
||||
# Whenever we hit a heredoc we will need to increment by
|
||||
# the number of lines in its content section when we
|
||||
# encounter the next token with a newline in it.
|
||||
my $heredoc = 0;
|
||||
|
||||
# Find the first Token without a location
|
||||
my ($first, $location) = ();
|
||||
foreach ( 0 .. $#tokens ) {
|
||||
my $Token = $tokens[$_];
|
||||
next if $Token->{_location};
|
||||
|
||||
# Found the first Token without a location
|
||||
# Calculate the new location if needed.
|
||||
if ($_) {
|
||||
$location =
|
||||
$self->_add_location( $location, $tokens[$_ - 1], \$heredoc );
|
||||
} else {
|
||||
my $logical_file =
|
||||
$self->can('filename') ? $self->filename : undef;
|
||||
$location = [ 1, 1, 1, 1, $logical_file ];
|
||||
}
|
||||
$first = $_;
|
||||
last;
|
||||
}
|
||||
|
||||
# Calculate locations for the rest
|
||||
if ( defined $first ) {
|
||||
foreach ( $first .. $#tokens ) {
|
||||
my $Token = $tokens[$_];
|
||||
$Token->{_location} = $location;
|
||||
$location = $self->_add_location( $location, $Token, \$heredoc );
|
||||
|
||||
# Add any here-doc lines to the counter
|
||||
if ( $Token->isa('PPI::Token::HereDoc') ) {
|
||||
$heredoc += $Token->heredoc + 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub _add_location {
|
||||
my ($self, $start, $Token, $heredoc) = @_;
|
||||
my $content = $Token->{content};
|
||||
|
||||
# Does the content contain any newlines
|
||||
my $newlines =()= $content =~ /\n/g;
|
||||
my ($logical_line, $logical_file) =
|
||||
$self->_logical_line_and_file($start, $Token, $newlines);
|
||||
|
||||
unless ( $newlines ) {
|
||||
# Handle the simple case
|
||||
return [
|
||||
$start->[LOCATION_LINE],
|
||||
$start->[LOCATION_CHARACTER] + length($content),
|
||||
$start->[LOCATION_COLUMN]
|
||||
+ $self->_visual_length(
|
||||
$content,
|
||||
$start->[LOCATION_COLUMN]
|
||||
),
|
||||
$logical_line,
|
||||
$logical_file,
|
||||
];
|
||||
}
|
||||
|
||||
# This is the more complex case where we hit or
|
||||
# span a newline boundary.
|
||||
my $physical_line = $start->[LOCATION_LINE] + $newlines;
|
||||
my $location = [ $physical_line, 1, 1, $logical_line, $logical_file ];
|
||||
if ( $heredoc and $$heredoc ) {
|
||||
$location->[LOCATION_LINE] += $$heredoc;
|
||||
$location->[LOCATION_LOGICAL_LINE] += $$heredoc;
|
||||
$$heredoc = 0;
|
||||
}
|
||||
|
||||
# Does the token have additional characters
|
||||
# after their last newline.
|
||||
if ( $content =~ /\n([^\n]+?)\z/ ) {
|
||||
$location->[LOCATION_CHARACTER] += length($1);
|
||||
$location->[LOCATION_COLUMN] +=
|
||||
$self->_visual_length(
|
||||
$1, $location->[LOCATION_COLUMN],
|
||||
);
|
||||
}
|
||||
|
||||
$location;
|
||||
}
|
||||
|
||||
sub _logical_line_and_file {
|
||||
my ($self, $start, $Token, $newlines) = @_;
|
||||
|
||||
# Regex taken from perlsyn, with the correction that there's no space
|
||||
# required between the line number and the file name.
|
||||
if ($start->[LOCATION_CHARACTER] == 1) {
|
||||
if ( $Token->isa('PPI::Token::Comment') ) {
|
||||
if (
|
||||
$Token->content =~ m<
|
||||
\A
|
||||
\# \s*
|
||||
line \s+
|
||||
(\d+) \s*
|
||||
(?: (\"?) ([^\"]* [^\s\"]) \2 )?
|
||||
\s*
|
||||
\z
|
||||
>xms
|
||||
) {
|
||||
return $1, ($3 || $start->[LOCATION_LOGICAL_FILE]);
|
||||
}
|
||||
}
|
||||
elsif ( $Token->isa('PPI::Token::Pod') ) {
|
||||
my $content = $Token->content;
|
||||
my $line;
|
||||
my $file = $start->[LOCATION_LOGICAL_FILE];
|
||||
my $end_of_directive;
|
||||
while (
|
||||
$content =~ m<
|
||||
^
|
||||
\# \s*?
|
||||
line \s+?
|
||||
(\d+) (?: (?! \n) \s)*
|
||||
(?: (\"?) ([^\"]*? [^\s\"]) \2 )??
|
||||
\s*?
|
||||
$
|
||||
>xmsg
|
||||
) {
|
||||
($line, $file) = ($1, ( $3 || $file ) );
|
||||
$end_of_directive = pos $content;
|
||||
}
|
||||
|
||||
if (defined $line) {
|
||||
pos $content = $end_of_directive;
|
||||
my $post_directive_newlines =()= $content =~ m< \G [^\n]* \n >xmsg;
|
||||
return $line + $post_directive_newlines - 1, $file;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return
|
||||
$start->[LOCATION_LOGICAL_LINE] + $newlines,
|
||||
$start->[LOCATION_LOGICAL_FILE];
|
||||
}
|
||||
|
||||
sub _visual_length {
|
||||
my ($self, $content, $pos) = @_;
|
||||
|
||||
my $tab_width = $self->tab_width;
|
||||
my ($length, $vis_inc);
|
||||
|
||||
return length $content if $content !~ /\t/;
|
||||
|
||||
# Split the content in tab and non-tab parts and calculate the
|
||||
# "visual increase" of each part.
|
||||
for my $part ( split(/(\t)/, $content) ) {
|
||||
if ($part eq "\t") {
|
||||
$vis_inc = $tab_width - ($pos-1) % $tab_width;
|
||||
}
|
||||
else {
|
||||
$vis_inc = length $part;
|
||||
}
|
||||
$length += $vis_inc;
|
||||
$pos += $vis_inc;
|
||||
}
|
||||
|
||||
$length;
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 flush_locations
|
||||
|
||||
When no longer needed, the C<flush_locations> method clears all location data
|
||||
from the tokens.
|
||||
|
||||
=cut
|
||||
|
||||
sub flush_locations {
|
||||
shift->_flush_locations(@_);
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 normalized
|
||||
|
||||
The C<normalized> method is used to generate a "Layer 1"
|
||||
L<PPI::Document::Normalized> object for the current Document.
|
||||
|
||||
A "normalized" Perl Document is an arbitrary structure that removes any
|
||||
irrelevant parts of the document and refactors out variations in style,
|
||||
to attempt to approach something that is closer to the "true meaning"
|
||||
of the Document.
|
||||
|
||||
See L<PPI::Normal> for more information on document normalization and
|
||||
the tasks for which it is useful.
|
||||
|
||||
Returns a L<PPI::Document::Normalized> object, or C<undef> on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub normalized {
|
||||
# The normalization process will utterly destroy and mangle
|
||||
# anything passed to it, so we are going to only give it a
|
||||
# clone of ourselves.
|
||||
PPI::Normal->process( $_[0]->clone );
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head1 complete
|
||||
|
||||
The C<complete> method is used to determine if a document is cleanly
|
||||
structured, all braces are closed, the final statement is
|
||||
fully terminated and all heredocs are fully entered.
|
||||
|
||||
Returns true if the document is complete or false if not.
|
||||
|
||||
=cut
|
||||
|
||||
sub complete {
|
||||
my $self = shift;
|
||||
|
||||
# Every structure has to be complete
|
||||
$self->find_any( sub {
|
||||
$_[1]->isa('PPI::Structure')
|
||||
and
|
||||
! $_[1]->complete
|
||||
} )
|
||||
and return '';
|
||||
|
||||
# Strip anything that isn't a statement off the end
|
||||
my @child = $self->children;
|
||||
while ( @child and not $child[-1]->isa('PPI::Statement') ) {
|
||||
pop @child;
|
||||
}
|
||||
|
||||
# We must have at least one statement
|
||||
return '' unless @child;
|
||||
|
||||
# Check the completeness of the last statement
|
||||
return $child[-1]->_complete;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# PPI::Node Methods
|
||||
|
||||
# We are a scope boundary
|
||||
### XS -> PPI/XS.xs:_PPI_Document__scope 0.903+
|
||||
sub scope() { 1 }
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# PPI::Element Methods
|
||||
|
||||
sub insert_before {
|
||||
return undef;
|
||||
# die "Cannot insert_before a PPI::Document";
|
||||
}
|
||||
|
||||
sub insert_after {
|
||||
return undef;
|
||||
# die "Cannot insert_after a PPI::Document";
|
||||
}
|
||||
|
||||
sub replace {
|
||||
return undef;
|
||||
# die "Cannot replace a PPI::Document";
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Error Handling
|
||||
|
||||
# Set the error message
|
||||
sub _error {
|
||||
$errstr = $_[1];
|
||||
undef;
|
||||
}
|
||||
|
||||
# Clear the error message.
|
||||
# Returns the object as a convenience.
|
||||
sub _clear {
|
||||
$errstr = '';
|
||||
$_[0];
|
||||
}
|
||||
|
||||
=pod
|
||||
|
||||
=head2 errstr
|
||||
|
||||
For error that occur when loading and saving documents, you can use
|
||||
C<errstr>, as either a static or object method, to access the error message.
|
||||
|
||||
If a Document loads or saves without error, C<errstr> will return false.
|
||||
|
||||
=cut
|
||||
|
||||
sub errstr {
|
||||
$errstr;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#####################################################################
|
||||
# Native Storable Support
|
||||
|
||||
sub STORABLE_freeze {
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my %hash = %$self;
|
||||
return ($class, \%hash);
|
||||
}
|
||||
|
||||
sub STORABLE_thaw {
|
||||
my ($self, undef, $class, $hash) = @_;
|
||||
bless $self, $class;
|
||||
foreach ( keys %$hash ) {
|
||||
$self->{$_} = delete $hash->{$_};
|
||||
}
|
||||
$self->__link_children;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 TO DO
|
||||
|
||||
- May need to overload some methods to forcefully prevent Document
|
||||
objects becoming children of another Node.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
See the L<support section|PPI/SUPPORT> in the main module.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<PPI>, L<http://ali.as/>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001 - 2011 Adam Kennedy.
|
||||
|
||||
This program is free software; you can redistribute
|
||||
it and/or modify it under the same terms as Perl itself.
|
||||
|
||||
The full text of the license can be found in the
|
||||
LICENSE file included with this module.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user