padre 1.00+dfsg-3 / usr / share / perl5 / Padre / PPI.pm

package Padre::PPI;

use 5.008;
use strict;
use warnings;
use PPI ();

our $VERSION = '1.00';

#####################################################################
# Assorted Search Functions

sub find_unmatched_brace {
	$_[1]->isa('PPI::Statement::UnmatchedBrace') and return 1;
	$_[1]->isa('PPI::Structure') or return '';
	$_[1]->start and $_[1]->finish and return '';
	return 1;
}

# scans a document for variable declarations and
# sorts them into three categories:
# lexical (my)
# our (our, doh)
# dynamic (local)
# package (use vars)
# Returns a hash reference containing the three category names
# each pointing at a hash which contains '$variablename' => locations.
# locations is an array reference containing one or more PPI-style
# locations. Example:
# {
#   lexical => {
#     '$foo' => [ [ 2, 3, 3], [ 6, 7, 7 ] ],
#   },
#   ...
# }
# Thus, there are two places where a "my $foo" was declared. On line 2 col 3
# and line 6 col 7.
sub get_all_variable_declarations {
	my $document = shift;
	my %vars;

	my $declarations = $document->find(
		sub {
			return 0
				unless $_[1]->isa('PPI::Statement::Variable')
					or $_[1]->isa('PPI::Statement::Include');
			return 1;
		},
	);

	my %our;
	my %lexical;
	my %dynamic;
	my %package;
	foreach my $decl (@$declarations) {
		if ( $decl->isa('PPI::Statement::Variable') ) {
			my $type     = $decl->type;
			my @vars     = $decl->variables;
			my $location = $decl->location;

			my $target_type;

			if ( $type eq 'my' ) {
				$target_type = \%lexical;
			} elsif ( $type eq 'our' ) {
				$target_type = \%our;
			} elsif ( $type eq 'local' ) {
				$target_type = \%dynamic;
			}

			foreach my $var (@vars) {
				$target_type->{$var} ||= [];
				push @{ $target_type->{$var} }, $location;
			}
		}

		# find use vars...
		elsif ( $decl->isa('PPI::Statement::Include')
			and $decl->module eq 'vars'
			and $decl->type   eq 'use' )
		{

			# do it the low-tech way
			my $string   = $decl->content;
			my $location = $decl->location;

			my @vars = $string =~ /([\%\@\$][\w_:]+)/g;
			foreach my $var (@vars) {
				$package{$var} ||= [];
				push @{ $package{$var} }, $location;
			}

		}
	} # end foreach declaration

	return ( { our => \%our, lexical => \%lexical, dynamic => \%dynamic, package => \%package } );
}

#####################################################################
# Stuff that should be in PPI itself

sub element_depth {
	my $cursor = shift;
	my $depth  = 0;
	while ( $cursor = $cursor->parent ) {
		$depth += 1;
	}
	return $depth;
}

# TO DO: PPIx::IndexOffsets or something similar might help.
# TO DO: See the 71... tests. If we don#t flush locations there, this breaks.
sub find_token_at_location {
	my $document = shift;
	my $location = shift;

	if (   not defined $document
		or not $document->isa('PPI::Document')
		or not defined $location
		or not ref($location) eq 'ARRAY' )
	{
		require Carp;
		Carp::croak("find_token_at_location() requires a PPI::Document and a PPI-style location as arguments");
	}

	$document->index_locations;

	foreach my $token ( $document->tokens ) {
		my $tloc = $token->location;
		return $token->previous_token
			if $tloc->[0] > $location->[0]
				or (    $tloc->[0] == $location->[0]
					and $tloc->[1] > $location->[1] );
	}

	return ();

	# old way that would only handle beginning of tokens; Should probably simply go away.; Should probably simply go away.
	#my $variable_token = $document->find_first(
	#	sub {
	#		my $elem = $_[1];
	#		return 0 if not $elem->isa('PPI::Token');
	#		my $loc = $elem->location;
	#		return 0 if $loc->[0] != $location->[0] or $loc->[1] != $location->[1];
	#		return 1;
	#	},
	#);
	#
	#return $variable_token;
}

# given either a PPI::Token::Symbol (i.e. a variable)
# or a PPI::Token which contains something that looks like
# a variable (quoted vars, interpolated vars in regexes...)
# find where that variable has been declared lexically.
# Doesn't find stuff like "use vars...".
sub find_variable_declaration {
	my $cursor = shift;
	return ()
		if not $cursor
			or not $cursor->isa("PPI::Token");

	my ( $varname, $token_str );
	if ( $cursor->isa("PPI::Token::Symbol") ) {
		$varname   = $cursor->symbol;
		$token_str = $cursor->content;
	} else {
		my $content = $cursor->content;
		if ( $content =~ /((?:\$#?|[@%*])[\w:']+)/ ) {
			$varname   = $1;
			$token_str = $1;
		}
	}
	return ()
		if not defined $varname;

	$varname =~ s/^\$\#/@/;

	my $document = $cursor->top;
	my $declaration;
	my $prev_cursor;
	while (1) {
		$prev_cursor = $cursor;
		$cursor      = $cursor->parent;
		if ( $cursor->isa("PPI::Structure::Block") or $cursor == $document ) {
			my @elems = $cursor->elements;
			foreach my $elem (@elems) {

				# Stop scanning this scope if we're at the branch we're coming
				# from. This is to ignore declarations later in the block.
				last if $elem == $prev_cursor;

				if ( $elem->isa("PPI::Statement::Variable")
					and grep { $_ eq $varname } $elem->variables )
				{
					$declaration = $elem;
					last;
				}

				# find use vars ...
				elsif ( $elem->isa("PPI::Statement::Include")
					and $elem->module eq 'vars'
					and $elem->type   eq 'use' )
				{

					# do it the low-tech way
					my $string = $elem->content;
					my @vars = $string =~ /([\%\@\$][\w_:]+)/g;
					if ( grep { $varname eq $_ } @vars ) {
						$declaration = $elem;
						last;
					}
				}

			}
			last if $declaration or $cursor == $document;
		}

		# this is for "foreach my $i ..."
		elsif ( $cursor->isa("PPI::Statement::Compound") and $cursor->type =~ /^for/ ) {
			my @elems = $cursor->elements;
			foreach my $elem (@elems) {

				# Stop scanning this scope if we're at the branch we're coming
				# from. This is to ignore declarations later in the block.
				last if $elem == $prev_cursor;

				if ( $elem->isa("PPI::Token::Word") and $elem->content =~ /^(?:my|our)$/ ) {
					my $nelem = $elem->snext_sibling;
					if (    defined $nelem
						and $nelem->isa("PPI::Token::Symbol")
						and $nelem->symbol eq $varname || $nelem->content eq $token_str )
					{
						$declaration = $nelem;
						last;
					}
				}
			}
			last if $declaration or $cursor == $document;
		}
	} # end while not top level

	return $declaration;
}

1;

# Copyright 2008-2013 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.