File Coverage

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

Criterion	Covered	Total	%
statement	65	66	98.4
branch	19	22	86.3
condition	3	6	50.0
subroutine	14	15	93.3
pod	6	6	100.0
total	107	115	93.0

=head1 NAME

PPIx::Regexp::Token::Reference - Represent a reference to a capture

=head1 SYNOPSIS

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

=head1 INHERITANCE

C is a
L.

C is the parent of
L,
L and
L.

=head1 DESCRIPTION

This abstract class represents a reference to a capture buffer, either
numbered or named. It should never be instantiated, but it provides a
number of methods to its subclasses.

=head1 METHODS

This class provides the following public methods. Methods not documented
here are private, and unsupported in the sense that the author reserves
the right to change or remove them without notice.

=cut

package PPIx::Regexp::Token::Reference;

use strict;
use warnings;

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

use Carp qw{ confess };
use List::Util qw{ first };
use PPIx::Regexp::Constant qw{ @CARP_NOT };

our $VERSION = '0.092';

sub __new {
    my ( $class, $content, %arg ) = @_;

    if ( defined $arg{capture} ) {
    } elsif ( defined $arg{tokenizer} ) {
	$arg{capture} = first { defined $_ } $arg{tokenizer}->capture();
    }

    unless ( defined $arg{capture} ) {
	foreach ( $class->__PPIX_TOKEN__recognize() ) {
	    my ( $re, $a ) = @{ $_ };
	    $content =~ $re or next;
	    @arg{ keys %{ $a } } = @{ $a }{ keys %{ $a } };
	    foreach my $inx ( 1 .. $#- ) {
		defined $-[$inx] or next;
		$arg{capture} = substr $content, $-[$inx], $+[$inx] - $-[$inx];
		last;
	    }
	    last;
	}
    }

    defined $arg{capture}
	or confess q{Programming error - reference '},
	    $content, q{' of unknown form};

    my $self = $class->SUPER::__new( $content, %arg )
	or return;

    $self->{is_named} = $arg{is_named};

    my $capture = delete $arg{capture};

    if ( $self->{is_named} ) {
	$self->{absolute} = undef;
	$self->{is_relative} = undef;
	$self->{name} = $capture;
    } elsif ( $capture !~ m/ \A [-+] /smx ) {
	$self->{absolute} = $self->{number} = $capture;
	$self->{is_relative} = undef;
    } else {
	$self->{number} = $capture;
	$self->{is_relative} = 1;
    }

    return $self;
}

=head2 absolute

 print "The absolute reference is ", $ref->absolute(), "\n";

This method returns the absolute number of the capture buffer referred
to. This is the same as number() for unsigned numeric references. If the
reference is to a named buffer, C is returned.

=cut

sub absolute {
    my ( $self ) = @_;
    return $self->{absolute};
}

=head2 is_named

 $ref->is_named and print "named reference\n";

This method returns true if the reference is named rather than numbered.

=cut

sub is_named {
    my ( $self ) = @_;
    return $self->{is_named};
}

=head2 is_relative

 $ref->is_relative()
     and print "relative numbered reference\n";

This method returns true if the reference is numbered and it is a
relative number (i.e. if it is signed).

=cut

sub is_relative {
    my ( $self ) = @_;
    return $self->{is_relative};
}

=head2 is_matcher

This method returns a true value because, although we do not actually
perform an analysis on the referred-to entity, we presume it matches
something.

=cut

sub is_matcher { return 1; }

=head2 name

 print "The name is ", $ref->name(), "\n";

This method returns the name of the capture buffer referred to. In the
case of a reference to a numbered capture (i.e. C returns
false), this method returns C.

=cut

sub name {
    my ( $self ) = @_;
    return $self->{name};
}

=head2 number

 print "The number is ", $ref->number(), "\n";

This method returns the number of the capture buffer referred to. In the
case of a reference to a named capture (i.e. C returns true),
this method returns C.

=cut

sub number {
    my ( $self ) = @_;
    return $self->{number};
}

# Called by the lexer to record the capture number.
sub __PPIX_LEXER__record_capture_number {
    my ( $self, $number ) = @_;
    if ( ! exists $self->{absolute} && exists $self->{number}
	&& $self->{number} =~ m/ \A [-+] /smx ) {

	my $delta = $self->{number};
	$delta > 0 and --$delta;	# no -0 or +0.
	$self->{absolute} = $number + $delta;

    }
    return $number;
}

1;

__END__