File Coverage

blib/lib/PPIx/QuoteLike/Utils.pm

Criterion	Covered	Total	%
statement	134	165	81.2
branch	57	104	54.8
condition	6	40	15.0
subroutine	27	27	100.0
pod	7	7	100.0
total	231	343	67.3

package PPIx::QuoteLike::Utils;

use 5.006;

use strict;
use warnings;

use base qw{ Exporter };

use Carp;
use PPIx::QuoteLike::Constant qw{
    HAVE_PPIX_REGEXP
    LOCATION_LINE
    LOCATION_CHARACTER
    LOCATION_COLUMN
    LOCATION_LOGICAL_LINE
    LOCATION_LOGICAL_FILE
    VARIABLE_RE
    @CARP_NOT
};
use Readonly;
use Scalar::Util ();

use constant LEFT_CURLY		=> q<{>;
use constant RIGHT_CURLY	=> q<}>;

our @EXPORT_OK = qw{
    column_number
    is_ppi_quotelike_element
    line_number
    logical_filename
    logical_line_number
    statement
    visual_column_number
    __instance
    __match_enclosed
    __matching_delimiter
    __normalize_interpolation_for_ppi
    __variables
};

our $VERSION = '0.022_01';

# Readonly::Scalar my $BRACED_RE	=> __match_enclosed( LEFT_CURLY );
Readonly::Scalar my $BRACKETED_RE	=> __match_enclosed( '[' ); # ]
Readonly::Scalar my $PARENTHESIZED_RE	=> __match_enclosed( '(' ); # )

Readonly::Scalar my $SIGIL_AND_CAST_RE	=> qr/ \$ \# \$* | [\@\$] \$* /smx;
# The following is an interpretation of perldata Identifier Parsing for
# Perls before 5.10.
Readonly::Scalar my $NORMAL_SYMBOL_NAME_RE	=> qr/
    (?:
	(?: :: )* '?
	    \w+ (?: (?: (?: :: )+ '? | (?: :: )* ' ) \w+ )*
	    (?: :: )* |
	[[:punct:]]
    )
/smx;

Readonly::Scalar my $SYMBOL_NAME_RE	=> qr/
    \^ \w+ | $NORMAL_SYMBOL_NAME_RE
/smxo;

sub column_number {
    my ( $self ) = @_;
    return ( $self->location() || [] )->[LOCATION_CHARACTER];
}

{

    my @relevant_ppi_classes = qw{
	PPI::Token::Quote
	PPI::Token::QuoteLike::Backtick
	PPI::Token::QuoteLike::Command
	PPI::Token::QuoteLike::Readline
	PPI::Token::HereDoc
    };

    sub is_ppi_quotelike_element {
	my ( $elem ) = @_;

	ref $elem
	    or return;

	Scalar::Util::blessed( $elem )
	    or return;

	foreach my $class ( @relevant_ppi_classes ) {
	    $elem->isa( $class )
		and return 1;
	}

	return;
    }

    my $cast_allowed_for_bare_bracketed_variable = {
	map { $_ => 1 } qw{ @ $ % } };

    sub __variables {
	my ( $ppi ) = @_;

	# In case we need to manufacture any.
	require PPIx::QuoteLike;

	Scalar::Util::blessed( $ppi )
	    or croak 'Argument must be an object';

	# TODO the following two lines are a crock, but there does not
	# seem to be a good alternative. Bad alternatives:
	# * Introduce PPIx::QuoteLike::Element. But it seems stupid to
	#   introduce a class simply to mark these as members of the
	#   PPIx::QuoteLike family.
	#   If I go this way at all, PPIx::QuoteLike::Element should be
	#   analogous to PPIx::Regexp::Element in that it carries at
	#   least the navigational and Perl version methods.
	# * Use DOES(). But that was not introduced until 5.10. So I
	#   could:
	#   - Depend on UNIVERSAL::DOES. This kindly steps aside if
	#     UNIVERSAL::DOES() exists, but it seems stupid to introduce
	#     a dependency that is only needed under really old Perls.
	#   - Same as above, only make the dependence conditional on the
	#     version of Perl. This may actually be the best
	#     alternative, but it's still pretty crufty.
	$ppi->isa( 'PPIx::QuoteLike' )
	    and return $ppi->variables();
	$ppi->isa( 'PPIx::QuoteLike::Token' )
	    and return $ppi->variables();

	my %var;

	$ppi->isa( 'PPIx::Regexp::Element' )
	    and do {
		foreach my $code ( @{ $ppi->find(
		    'PPIx::Regexp::Token::Code' ) || [] } ) {
		    foreach my $name ( __variables( $code->ppi() ) ) {
			$var{ $name } = 1;
		    }
		}
		return keys %var;
	    };

	$ppi->isa( 'PPI::Element' )
	    or croak 'Argument must be a PPI::Element, ',
		'PPIx::Regexp::Element, PPIx::QuoteLike, or ',
		'PPIx::QuoteLike::Token';

	foreach my $sym ( _find( $ppi, 'PPI::Token::Symbol' ) ) {
	    # Eliminate rogue subscripts
	    _is_bareword_subscript( $sym )
		and next;
	    if ( defined( my $name = _name_from_misparsed_magic( $sym ) )
	    ) {
		# We're $${name}, which is a dereference of $name
		$var{$name} = 1;
	    } else {
		# PPI got it right.
		$var{ $sym->symbol() } = 1;
	    }
	}

        # For some reason, PPI parses '$#foo' as a
        # PPI::Token::ArrayIndex.  $#$foo is parsed as a Cast followed
        # by a Symbol, so as long as nobody decides the '$#' cast causes
        # $elem->symbol() to return something other than '$foo', we're
        # cool.
        foreach my $elem ( _find( $ppi, 'PPI::Token::ArrayIndex' ) ) {
            my $name = $elem->content();
            $name =~ s/ \A \$ [#] /@/smx or next;
	    $var{$name} = 1;
        }

        # Occasionally you see something like ${foo} outside quotes.
        # This is legitimate, though PPI parses it as a cast followed by
        # a block. On the assumption that there are fewer blocks than
        # words in most Perl, we start at the top and work down. Perl
        # also handles punctuation variables specified this way, but
        # since PPI goes berserk when it sees this, we won't bother.
        foreach my $elem ( _find( $ppi, 'PPI::Structure::Block' ) ) {

            my $previous = $elem->sprevious_sibling()
                or next;
            $previous->isa( 'PPI::Token::Cast' )
                or next;
            my $sigil = $previous->content();
            $cast_allowed_for_bare_bracketed_variable->{ $sigil }
                or next;

	    if ( my @kids = $elem->schildren() ) {
		# The simple case: we parsed a block whose contents,
		# however they were parsed, are the contents of the
		# token.
		1 == @kids
		    or next;
		$kids[0]->isa( 'PPI::Statement' )
		    or next;

		( my $name = join '', map { $_->content() }
		    $kids[0]->children() ) =~ m/ \A @{[ VARIABLE_RE ]} \z /smxo
		    or next;

		$var{ "$sigil$name" } = 1;
	    } else {
		# The downright ugly case. We have something like ${]}
		# where PPI can't find the terminator. To solve this we
		# need to go blundering through the parse until we find
		# the closing terminator.
		my $stmt = $elem->statement()
		    or next;
		if ( my $finish = $elem->finish() ) {
		    # If we appear to have a terminated block, we may # {{
		    # have ${}}, which is the same as $}
		    my $next = $stmt->next_sibling()
			or next;
		    $next->isa( 'PPI::Statement::UnmatchedBrace' )
			and RIGHT_CURLY eq $next->content()
			or next;
		    $var{ $sigil . $finish->content() } = 1;
		} else {
		    # Otherwise we have something like # [
		    # ${]}
		    my $next = $stmt->next_sibling()
			or next;
		    my $finish = $next->next_sibling()
			or next;
		    $finish->isa( 'PPI::Statement::UnmatchedBrace' )
			and RIGHT_CURLY eq $finish->content()
			or next;
		    $var{ $sigil . $next->content() } = 1;
		}
	    }
        }

	# Yes, we might have nested string literals, like
	# "... @{[ qq<$foo> ]} ..."
	foreach my $class ( @relevant_ppi_classes ) {
	    foreach my $elem ( _find( $ppi, $class ) ) {

		my $ql = PPIx::QuoteLike->new( $elem )
		    or next;
		$ql->interpolates()
		    or next;
		foreach my $sym ( $ql->variables() ) {
		    $var{ $sym } = 1;
		}
	    }
	}

	# By the same token we might have a regexp
	# TODO for consistency's sake, give PPIx::Regexp a variables()
	# method.
	if ( HAVE_PPIX_REGEXP ) {
	    foreach my $class ( qw{
		    PPI::Token::QuoteLike::Regexp
		    PPI::Token::Regexp::Match
		    PPI::Token::Regexp::Substitute
		} ) {
		foreach my $elem ( _find( $ppi, $class ) ) {
		    my $re = PPIx::Regexp->new( $elem )
			or next;
		    foreach my $code ( @{ $re->find(
			'PPIx::Regexp::Token::Code' ) || [] } ) {
			foreach my $name ( __variables( $code->ppi() ) ) {
			    $var{ $name } = 1;
			}
		    }
		}
	    }
	}

	return ( keys %var );
    }
}

# We want __variables to work when passed a single token. So we go
# through this to do what we wish PPI did -- return an array for a
# PPI::Node, or return either the element itself or nothing otherwise.
sub _find {
    my ( $elem, $class ) = @_;
    $elem->isa( 'PPI::Node' )
	and return @{ $elem->find( $class ) || [] };
    $elem->isa( $class )
	and return $elem;
    return;
}

sub __instance {
    my ( $object, $class ) = @_;
    Scalar::Util::blessed( $object ) or return;
    return $object->isa( $class );
}

# The problem this solves is that PPI can parse '{_}' as containing a
# PPI::Token::Magic (which is a PPI::Token::Symbol), not a
# PPI::Token::Word. This code also returns true for '${_}', which is not
# a subscript but has the same basic problem. The latter gets caught
# later.
sub _is_bareword_subscript {
    my ( $elem ) = @_;
    $elem->content() =~ m/ \A \w+ \z /smx
	or return;
    my $parent;
    $parent = $elem->parent()
	and $parent->isa( 'PPI::Statement' )
	and 1 == $parent->children()
	or return;
    $parent = $parent->parent()
	and ( $parent->isa( 'PPI::Structure::Subscript' )
	    or $parent->isa( 'PPI::Structure::Block' ) )
	and 1 == $parent->children()
	or return;
    my $start;
    $start = $parent->start()
	and $start->isa( 'PPI::Token::Structure' )
	and q<{> eq $start->content()
	or return;
    return 1;
}

sub line_number {
    my ( $self ) = @_;
    return ( $self->location() || [] )->[LOCATION_LINE];
}

sub logical_filename {
    my ( $self ) = @_;
    return ( $self->location() || [] )->[LOCATION_LOGICAL_FILE];
}

sub logical_line_number {
    my ( $self ) = @_;
    return ( $self->location() || [] )->[LOCATION_LOGICAL_LINE];
}

{
    our %REGEXP_CACHE;

    my %matching_bracket;

    BEGIN {
	%matching_bracket = qw/ ( ) [ ] { } < > /;
    }

    sub __match_enclosed {
	my ( $left ) = @_;
	my $ql = quotemeta $left;

	$REGEXP_CACHE{$ql}
	    and return $REGEXP_CACHE{$ql};

	if ( my $right = $matching_bracket{$left} ) {

	    # Based on Regexp::Common $RE{balanced} 2.113 (because I
	    # can't use (?-1)

	    my $ql = quotemeta $left;
	    my $qr = quotemeta $right;
	    my $pkg = __PACKAGE__;
	    my $r  = "(??{ \$${pkg}::REGEXP_CACHE{'$ql'} })";

	    my @parts = (
		"(?>[^\\\\$ql$qr]+)",
		"(?>\\\$[$ql$qr])",
		'(?>\\\\.)',
		$r,
	    );

	    {
		use re qw{ eval };
		local $" = '|';
		$REGEXP_CACHE{$ql} = qr/($ql(?:@parts)*$qr)/sm;
	    }

	    return $REGEXP_CACHE{$ql};

	} else {

	    # Based on Regexp::Common $RE{delimited}{-delim=>'`'}
	    return ( $REGEXP_CACHE{$ql} ||=
		qr< (
		    (?: \Q$left\E )
		    (?: [^\\\Q$left\E]* (?: \\ . [^\\\Q$left\E]* )* )
		    (?: \Q$left\E )
		) >smx
	    );
	}
    }

    sub __matching_delimiter {
	my ( $left ) = @_;
	my $right = $matching_bracket{$left}
	    or return $left;
	return $right;
    }
}

sub __normalize_interpolation_for_ppi {
    ( local $_ ) = @_;

    # "@{[ foo() ]}" => 'foo()'
    if ( m/ \A \@ [{] \s* ( $BRACKETED_RE ) \s* [}] \z /smxo ) {
	$_ = $1;
	s/ \A [[] \s* //smx;
	s/ \s* []] \z //smx;
	return "$_";
    }

    # "${\( foo() )}" => 'foo()'
    if ( m/ \A \$ [{] \s* \\ \s* ( $PARENTHESIZED_RE ) \s* [}] \z /smox ) {
	$_ = $1;
	s/ \A [(] \s* //smx;
	s/ \s* [)] \z //smx;
	return "$_";
    }

    # "${foo}" => '$foo'
    m/ \A ( $SIGIL_AND_CAST_RE ) \s*
	[{] \s* ( $NORMAL_SYMBOL_NAME_RE ) \s* [}] \z /smxo
	and return "$1$2";

    # "${foo{bar}}" => '$foo{bar}'
    # NOTE that this is a warning, and so not done.
#    if ( m/ \A ( $SIGIL_AND_CAST_RE ) (?= [{] ) ( $BRACED_RE ) /smx ) {
#	( my $sigil, local $_ ) = ( $1, $2 );
#	s/ \A [{] \s* //smx;
#	s/ \s* [}] \z //smx;
#	return "$sigil$_";
#    }

    # "$ foo->{bar}" => '$foo->{bar}'
    if ( m/ \A ( $SIGIL_AND_CAST_RE ) \s+ ( $SYMBOL_NAME_RE ) ( .* ) /smxo ) {
	return "$1$2$3";
    }

    # Everything else
    return "$_";
}

sub statement {
    my ( $self ) = @_;
    my $top = $self->top()
	or return;
    $top->can( 'source' )
	or return;
    my $source = $top->source()
	or return;
    $source->can( 'statement' )
	or return;
    return $source->statement();
}

sub visual_column_number {
    my ( $self ) = @_;
    return ( $self->location() || [] )->[LOCATION_COLUMN];
}

# This handles two known cases where PPI misparses bracketed variable
# names.
# * $${foo} is parsed as '$$' when it is really a dereference of $foo.
#   The argument is the '$$'
# * ${$} is parsed as an unterminated block followed by '$}'. The
#   argument is the '$}'.

{
    my $special = {
	'$$'	=> sub {	# $${foo},$${$_[0]}
	    my ( $elem ) = @_;
	    my $next;
	    $next = $elem->snext_sibling()
		and $next->isa( 'PPI::Structure::Subscript' )
		or return;
	    my $start;
	    $start = $next->start()
		and LEFT_CURLY eq $start->content()
		or return;
	    my @kids = $next->schildren();
	    1 == @kids
		and $kids[0]->isa( 'PPI::Statement' )
		and @kids = $kids[0]->schildren();
	    if ( 1 == @kids ) {
		# The $${foo} case
		return join '', '$', map { $_->content() } @kids;
	    } else {
		# The $${$_[0]} case. In this case the curly brackets
		# are really a block, as
		# $ perl -MO=Deparse -e '$${$_[0]}' makes clear. So we
		# just return the '$$', since the '$_' will turn up in
		# the course of things.
		return $elem->content();
	    }
	},
	# {
	'$}'	=> sub {	# ${$}
	    my ( $elem ) = @_;
	    my $stmt;
	    $stmt = $elem->parent()
		and $stmt->isa( 'PPI::Statement' )
		or return;
	    my $block;
	    $block = $stmt->parent()
		and $block->isa( 'PPI::Structure::Block' )
		and not $block->finish()
		or return;
	    my $sigil;
	    $sigil = $block->sprevious_sibling()
		and $sigil->isa( 'PPI::Token::Cast' )
		or return;
	    my $name = join '', map { $_->content() } $sigil,
		$stmt->children();
	    chop $name;
	    return $name;
	},
    };

    sub _name_from_misparsed_magic {
	my ( $elem ) = @_;
	$elem->isa( 'PPI::Token::Magic' )
	    or return;
	my $code = $special->{ $elem->content() }
	    or return;
	return $code->( $elem );
    }
}

1;

__END__