File Coverage

blib/lib/PPIx/Regexp/Util.pm

Criterion	Covered	Total	%
statement	66	78	84.6
branch	19	38	50.0
condition	12	18	66.6
subroutine	17	18	94.4
pod	3	3	100.0
total	117	155	75.4

package PPIx::Regexp::Util;

use 5.006;

use strict;
use warnings;

use Carp;
use PPIx::Regexp::Constant qw{
    INFINITY
    MINIMUM_PERL
    @CARP_NOT
};
use Scalar::Util qw{ blessed };

use base qw{ Exporter };

our @EXPORT_OK = qw{
    is_ppi_regexp_element
    __choose_tokenizer_class
    __instance
    __is_ppi_regexp_element
    __merge_perl_requirements
    __ns_can
    __post_rebless_error
    raw_width
    __to_ordinal_en
    width
};

our %EXPORT_TAGS = (
    all		=> \@EXPORT_OK,
    width_one	=> [ qw{ raw_width width } ],
);

our $VERSION = '0.087';

sub is_ppi_regexp_element {
    my ( $elem ) = @_;
    __instance( $elem, 'PPI::Element' )
	or return;
    return $elem->isa( 'PPI::Token::Regexp' ) ||
	$elem->isa( 'PPI::Token::QuoteLike::Regexp' );
}

sub __is_ppi_regexp_element {
    Carp::cluck(
	'__is_ppi_regexp_element is deprecated. Use is_ppi_regexp_element'
    );
    goto &is_ppi_regexp_element;
}

# TODO ditch this once the deprecation period ends
sub __choose_tokenizer_class {
    # my ( $content, $arg ) = @_;
    my ( undef, $arg ) = @_;
    if ( defined $arg->{parse} ) {
	my $warning = q;
	{ guess => 1, string => 1 }->{$arg->{parse}}
	    and $warning = join ' ', $warning,
		q;
	croak $warning;
    }
    return 'PPIx::Regexp::Tokenizer';
}

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

sub __merge_perl_requirements {	## no critic (RequireArgUnpacking)
    my @work =
    sort { $a->[0] <=> $b->[0] || $b->[1] <=> $a->[1] }
    map { ( [ $_->[0], 1 ], [ $_->[1], 0 ] ) }
    map { [ $_->{introduced}, defined $_->{removed} ? $_->{removed} : INFINITY ] } @_;
    my @rslt;
    while ( @work ) {
	my ( $intro, $rem );
	$intro = ( shift @work )->[0] while @work && $work[0][1];
	if ( @work ) {
	    $rem = $work[0][0];
	    shift @work while @work && ! $work[0][1];
	}
	defined $intro
	    or $intro = MINIMUM_PERL;
	defined $rem
	    or $rem = INFINITY;
	$intro != $rem
	    and push @rslt, {
		introduced	=> $intro,
		removed	=> $rem,
	    };
    }
    @rslt
	and $rslt[-1]{removed} == INFINITY
	and delete $rslt[-1]{removed};
    return @rslt;
}

sub __ns_can {
    my ( $class, $name ) = @_;
    my $fqn = join '::', ref $class || $class, $name;
    no strict qw{ refs };
    return defined &$fqn ? \&$fqn : undef;
}

sub __post_rebless_error {
    my ( $self, %arg ) = @_;
    my $rslt = 0;
    unless ( defined( $self->{error} = $arg{error} ) ) {
	my $class = ref $self;
	Carp::cluck( "Making $class with no error message" );
	$self->{error} = 'Unspecified error';
	$rslt++;
    }
    $self->{explanation} = defined $arg{explanation} ?
	$arg{explanation} :
	$arg{error};
    return $rslt;

}

# Unquantified number of characters matched.
sub raw_width {
    return ( 1, 1 );
}

sub __to_ordinal_en {
    my ( $num ) = @_;
    $num += 0;
    1 == int( ( $num % 100 ) / 10 )	# teens
	and return "${num}th";
    1 == $num % 10
	and return "${num}st";
    2 == $num % 10
	and return "${num}nd";
    3 == $num % 10
	and return "${num}rd";
    return "${num}th";
}

sub width {
    my ( $self ) = @_;
    my @raw_width = $self->raw_width();
    my ( $code, $next_sib );
    $next_sib = $self->snext_sibling()
	and $code = $next_sib->can( '__quantified_width' )
	or return @raw_width;
    return $code->( $next_sib, @raw_width );
}

1;

__END__