File Coverage

blib/lib/PPI/Document.pm

Criterion	Covered	Total	%
statement	252	275	91.6
branch	90	128	70.3
condition	18	29	62.0
subroutine	47	51	92.1
pod	20	24	83.3
total	427	507	84.2

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 class represents a single Perl "document". A
C object acts as a root L, 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-like behavior this is that a
C object can NEVER have a parent node, and is always
the root node in a tree.

=head2 Storable Support

C implements the necessary C and
C hooks to provide native support for L,
if you have it installed.

However if you want to clone a Document, you are highly recommended
to use the C<$Document-Eclone> method rather than Storable's
C function (although C 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 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 YAML::PP                      ();

use overload 'bool' => \&PPI::Util::TRUE;
use overload '""'   => 'content';

our $VERSION = '1.291';

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 constructor takes as argument a variety of different sources of
Perl code, and creates a single cohesive Perl C
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, 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 remember where it was created from.

Returns a C object, or C if parsing fails.
L objects can also be thrown if there are parsing problems.

The constructor also takes attribute flags.

=head3 readonly

Setting C to true will allow various systems to provide additional
optimisations and caching. Note that because C is an optimisation
flag, it is off by default and you will need to explicitly enable it.

=head3 feature_mods

Setting feature_mods with a hashref allows defining perl parsing features to be
enabled for the whole document. (e.g. when the code is assumed to be run as a
oneliner)

=head3 custom_feature_includes

  custom_feature_includes =>
    { $my_custom_pragma_name => { $feature_name => $feature_provider } }

  # e.g.
  custom_feature_includes =>
    { MyStrict => { try => "Syntax::Keyword::Try" } }

Setting custom_feature_includes with a hashref allows defining include names
which act like pragmas that enable parsing features within their scope. This
is mostly useful when your work project has its own boilerplate module. The
provider is either perl, or the name of a cpan module that implements the
feature.

It can also be provided as JSON or YAML in the environment variable
PPI_CUSTOM_FEATURE_INCLUDES, like so:

  PPI_CUSTOM_FEATURE_INCLUDES='MyStrict: {signatures: perl}' \
    perlcritic lib/OurModule.pm

  PPI_CUSTOM_FEATURE_INCLUDES='{"MyStrict":{"signatures":"perl"}}' \
    perlcritic lib/OurModule.pm

=head3 custom_feature_include_cb

  custom_feature_include_cb => sub {
    my ($statement) = @_;
    return $statement->module eq "MyStrict" ? { signatures => "perl" } : ();
  },

Setting custom_feature_include_cb with a code reference causes all inspections
on includes to call that sub before doing any other inspections. The sub can
decide to either return a hashref of features to be enabled or disabled, which
will be used for the scope the include was called in, or undef to continue with
the default inspections. The argument to the sub will be the
L object.

This can be useful when your work project has a complex boilerplate module.

=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, %attr );
			if ( $document ) {
				# Save in the cache
				$CACHE->store_document( $document );
				return $document;
			}
		} else {
			my $document = PPI::Lexer->lex_file( $source, %attr );
			return $document if $document;
		}

	} elsif ( _SCALAR0($source) ) {
		my $document = PPI::Lexer->lex_source( $$source, %attr );
		return $document if $document;

	} elsif ( _ARRAY0($source) ) {
		my $document = PPI::Lexer->lex_file( $source, %attr );
		return $document 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 ( PPI::Lexer->errstr ) {
		$errstr = PPI::Lexer->errstr;
	} elsif ( _INSTANCE($@, 'PPI::Exception') ) {
		$errstr = $@->message;
	} elsif ( $@ ) {
		$errstr = $@;
		$errstr =~ s/\sat line\s.+$//;
	} 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};
	$document->{feature_mods}              = $attr{feature_mods};
	$document->{custom_feature_includes}   = $attr{custom_feature_includes};
	$document->{custom_feature_include_cb} = $attr{custom_feature_include_cb};
	if ( $ENV{PPI_CUSTOM_FEATURE_INCLUDES} ) {
		my $includes = YAML::PP::Load $ENV{PPI_CUSTOM_FEATURE_INCLUDES};
		die "\$ENV{PPI_CUSTOM_FEATURE_INCLUDES} "
		  . "does not contain valid perl:\n"
		  . "val: '$ENV{PPI_CUSTOM_FEATURE_INCLUDES}'\nerr: $@"
		  if $@;
		$document->{custom_feature_includes} =
		  { %{ $document->{custom_feature_includes} || {} }, %{$includes} };
	}
	return $document;
}

=pod

=head2 set_cache $cache

As of L 1.100, C supports parser caching.

The default cache class L provides a L-based
caching or the parsed document based on the MD5 hash of the document as
a string.

The static C method is used to set the cache object for
C to use when loading documents. It takes as argument
a L object (or something that C the same).

If passed C, this method will stop using the current cache, if any.

For more information on caching, see L.

Returns true on success, or C 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 method will
return it.

Returns a L object, or C if there is no cache
currently set for C.

=cut

sub get_cache {
	$CACHE;
}





#####################################################################
# PPI::Document Instance Methods

=pod

=head2 filename

The C accessor returns the name of the file in which the document
is stored.

=cut

sub filename {
	$_[0]->{filename};
}

=pod

=head2 readonly

The C 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-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 correctly, C
need to understand the concept of tabs and tab width. The C
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 Cs if you attempt to set the
tab width.

=cut

sub tab_width {
	my $self = shift;
	return $self->{tab_width} unless @_;
	$self->{tab_width} = shift;
}

=head2 feature_mods { feature_name => $provider }

=cut

sub feature_mods {
	my $self = shift;
	return $self->{feature_mods} unless @_;
	$self->{feature_mods} = shift;
}

=head2 custom_feature_includes { module_name => { feature_name => $provider } }

=cut

sub custom_feature_includes {
	my $self = shift;
	return $self->{custom_feature_includes} unless @_;
	$self->{custom_feature_includes} = shift;
}

=head2 custom_feature_include_cb sub { ... }

=cut

sub custom_feature_include_cb {
	my $self = shift;
	return $self->{custom_feature_include_cb} unless @_;
	$self->{custom_feature_include_cb} = shift;
}

=pod

=head2 save

  $document->save( $file )

The C method serializes the C object and saves the
resulting Perl document to a file. Returns C 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 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 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;

		# Pick up the indentation, which may be undef.
		my $indentation = $Token->indentation || '';

		# Now add all of the here-doc content to the heredoc buffer.
		foreach my $line ( $Token->heredoc ) {
			$heredoc .= "\n" eq $line ? $line : $indentation . $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 .= $indentation . $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 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
and L) 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 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 method
will index and save the locations of every Element within the Document in
advance, making future calls to  virtually free.

Please note that this index should always be cleared using C
once you are finished with the locations. If content is added to or removed
from the file, these indexed locations will be B.

=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[$_];
		if ($Token->{_location}) {
			$location = $Token->{_location};
			next;
		}

		# Found the first Token without a location
		# Calculate the new location if needed.
		$location =
			$_
		  ? $self->_add_location( $location, $tokens[ $_ - 1 ], \$heredoc )
		  : $self->_default_location;
		$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 _default_location {
	my ($self) = @_;
	my $logical_file = $self->can('filename') ? $self->filename : undef;
	return [ 1, 1, 1, 1, $logical_file ];
}

sub location {
	my ($self) = @_;
	return $self->SUPER::location || $self->_default_location;
}

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 method clears all location data
from the tokens.

=cut

sub flush_locations {
	shift->_flush_locations(@_);
}

=pod

=head2 normalized

The C method is used to generate a "Layer 1"
L 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 for more information on document normalization and
the tasks for which it is useful.

Returns a L object, or C 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 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, as either a static or object method, to access the error message.

If a Document loads or saves without error, C 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 in the main module.

=head1 AUTHOR

Adam Kennedy [e-mail]

=head1 SEE ALSO

L, L

=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