File Coverage

blib/lib/PPIx/Regexp/Token/Backreference.pm

Criterion	Covered	Total	%
statement	74	80	92.5
branch	37	54	68.5
condition	2	2	100.0
subroutine	13	14	92.8
pod	3	3	100.0
total	129	153	84.3

=head1 NAME

PPIx::Regexp::Token::Backreference - Represent a back reference

=head1 SYNOPSIS

 use PPIx::Regexp::Dumper;
 PPIx::Regexp::Dumper->new( 'qr{(foo|bar)baz\1}smx' )
     ->print();

=head1 INHERITANCE

C is a
L.

C has no descendants.

=head1 DESCRIPTION

This class represents back references of all sorts, both the traditional
numbered variety and the Perl 5.010 named kind.

=head1 METHODS

This class provides no public methods beyond those provided by its
superclass.

=cut

package PPIx::Regexp::Token::Backreference;

use strict;
use warnings;

use base qw{ PPIx::Regexp::Token::Reference };

use Carp qw{ confess };
use PPIx::Regexp::Constant qw{
    MINIMUM_PERL
    RE_CAPTURE_NAME
    TOKEN_LITERAL
    TOKEN_UNKNOWN
    @CARP_NOT
};
use PPIx::Regexp::Util qw{ __to_ordinal_en width };

our $VERSION = '0.088';

# Return true if the token can be quantified, and false otherwise
# sub can_be_quantified { return };

sub explain {
    my ( $self ) = @_;
    $self->is_named()
	and return sprintf q,
	    $self->name();
    $self->is_relative()
	and return sprintf
	    q,
	    __to_ordinal_en( - $self->number() ),
	    $self->absolute();
    return sprintf q,
	$self->absolute();
}

{

    my %perl_version_introduced = (
	g => '5.009005',	# \g1 \g-1 \g{1} \g{-1}
	k => '5.009005',	# \k \k'name'
	'?' => '5.009005',	# (?P=name)	(PCRE/Python)
    );

    sub perl_version_introduced {
	my ( $self ) = @_;
	return $perl_version_introduced{substr( $self->content(), 1, 1 )} ||
	    MINIMUM_PERL;
    }

}

sub raw_width {
    my ( $self ) = @_;
    my $re = $self->top()
	or return ( undef, undef );	# Shouldn't happen.
    my @capture;
    if ( $self->is_named() ) {
	my $name = $self->name();
	foreach my $elem ( @{ $re->find(
	    'PPIx::Regexp::Structure::NamedCapture' ) || [] } ) {
	    $elem->name() eq $name
		or next;
	    $re->__token_post_order( $elem, $self ) < 0
		or last;
	    push @capture, $elem;
	}
    } else {
	my $number = $self->absolute();
	foreach my $elem ( @{ $re->find(
	    'PPIx::Regexp::Structure::Capture' ) || [] } ) {
	    $elem->number() == $number
		or next;
	    $re->__token_post_order( $elem, $self ) < 0
		or last;
	    push @capture, $elem;
	}
    }
    @capture == 1
	and return $capture[0]->raw_width();
    my ( $base_min, $base_max ) = $capture[0]->raw_width();
    foreach my $elem ( @capture[ 1 .. $#capture ] ) {
	my ( $ele_min, $ele_max ) = $elem->raw_width();
	defined $ele_min
	    or $base_min = undef;
	defined $base_min
	    and $base_min = $base_min == $ele_min ? $base_min : undef;
	defined $ele_max
	    or $base_max = undef;
	defined $base_max
	    and $base_max = $base_max == $ele_max ? $base_max : undef;
    }
    return ( $base_min, $base_max );
}

my @external = (	# Recognition used externally
    [ qr{ \A \( \? P = ( @{[ RE_CAPTURE_NAME ]} ) \) }smxo,
	{ is_named => 1 },
	],
);

my @recognize_regexp = (	# recognition used internally
    [
	qr{ \A \\ (?:		# numbered (including relative)
	    ( [0-9]+ )	|
	    g (?: ( -? [0-9]+ ) | \{ ( -? [0-9]+ ) \} )
	)
	}smx, { is_named => 0 }, ],
    [
	qr{ \A \\ (?:		# named
	    g [{] ( @{[ RE_CAPTURE_NAME ]} ) [}] |
	    k (?: \< ( @{[ RE_CAPTURE_NAME ]} ) \> |	# named with angles
		' ( @{[ RE_CAPTURE_NAME ]} ) ' )	#   or quotes
	)
	}smxo, { is_named => 1 }, ],
);

my %recognize = (
    regexp	=> \@recognize_regexp,
    repl	=> [
	[ qr{ \A \\ ( [0-9]+ ) }smx, { is_named => 0 } ],
    ],
);

# This must be implemented by tokens which do not recognize themselves.
# The return is a list of list references. Each list reference must
# contain a regular expression that recognizes the token, and optionally
# a reference to a hash to pass to make_token as the class-specific
# arguments. The regular expression MUST be anchored to the beginning of
# the string.
sub __PPIX_TOKEN__recognize {
    return __PACKAGE__->isa( scalar caller ) ?
	( @external, @recognize_regexp ) :
	( @external );
}

sub __PPIX_TOKENIZER__regexp {
    my ( undef, $tokenizer, $character ) = @_;

    # PCRE/Python back references are handled in
    # PPIx::Regexp::Token::Structure, because they are parenthesized.

    # All the other styles are escaped.
    $character eq '\\'
	or return;

    foreach ( @{ $recognize{$tokenizer->get_mode()} } ) {
	my ( $re, $arg ) = @{ $_ };
	my $accept = $tokenizer->find_regexp( $re ) or next;
	my %arg = ( %{ $arg }, tokenizer => $tokenizer );
	return $tokenizer->make_token( $accept, __PACKAGE__, \%arg );
    }

    return;
}

sub __PPIX_TOKENIZER__repl {
    my ( undef, $tokenizer ) = @_;	# Invocant, $character unused

    $tokenizer->interpolates()
	or return;

    goto &__PPIX_TOKENIZER__regexp;
}

# Called by the lexer to disambiguate between captures, literals, and
# whatever. We have to return the number of tokens reblessed to
# TOKEN_UNKNOWN (i.e. either 0 or 1) because we get called after the
# parse is finalized.
sub __PPIX_LEXER__rebless {
    my ( $self, %arg ) = @_;

    # Handle named back references
    if ( $self->is_named() ) {
	$arg{capture_name}{$self->name()}
	    and return 0;
	return $self->__error();
    }

    # Get the absolute capture group number.
    my $absolute = $self->absolute();

    # If it is zero or negative, we have a relateive reference to a
    # non-existent capture group.
    $absolute <= 0
	and return $self->__error();

    # If the absolute number is less than or equal to the maximum
    # capture group number, we are good.
    $absolute <= $arg{max_capture}
	and return 0;

    # It's not a valid capture. If it's an octal literal, rebless it so.
    # Note that we can't rebless single-digit numbers, since they can't
    # be octal literals.
    my $content = $self->content();
    if ( $content =~ m/ \A \\ [0-7]{2,} \z /smx ) {
	TOKEN_LITERAL->__PPIX_ELEM__rebless( $self );
	return 0;
    }

    # Anything else is an error.
    return $self->__error();
}

sub __error {
    my ( $self, $msg ) = @_;
    defined $msg
	or $msg = 'No corresponding capture group';
    TOKEN_UNKNOWN->__PPIX_ELEM__rebless( $self, error => $msg );
    return 1;
}

1;

__END__