File Coverage

blib/lib/Regexp/Exhaustive.pm

Criterion	Covered	Total	%
statement	61	61	100.0
branch	22	22	100.0
condition	5	6	83.3
subroutine	10	10	100.0
pod	1	1	100.0
total	99	100	99.0

package Regexp::Exhaustive;
use 5.006001;

$VERSION = 0.04;

use base 'Exporter';
@EXPORT_OK = qw/ exhaustive /;
$EXPORT_TAGS{ALL} = \@EXPORT_OK;

use strict;
use Carp;
use Scalar::Util qw/ blessed /;
use warnings ();

use vars qw/ $Vars $Count @Matches /;

my %Translate = (
    q[$`]  => 'substr($$str_ref, 0, $-[0])',
    q[$&]  => 'substr($$str_ref, $-[0], $+[0] - $-[0])',
    q[$']  => 'substr($$str_ref, $+[0])',
    q[$+]  => '$+',
    q[$^N] => '$^N',
    q[@-]  => '[ @- ]',
    q[@+]  => '[ @+ ]',
    q[%-]  => '{ %- }',
    q[%+]  => '{ %+ }',
    q[$^R] => '$^R',
);

my %Aliases = qw/
    $PREMATCH                   $`
    $MATCH                      $&
    $POSTMATCH                  $'
    $LAST_PAREN_MATCH           $+
    $LAST_REGEXP_CODE_RESULT    $^R
    @LAST_MATCH_START           @-
    @LAST_MATCH_END             @+
/;

my $Unique = 0;
sub exhaustive {
    my $str_ref = \shift;
    my $re = shift;
    my @vars = @_;

    defined $$str_ref
        or warnings::warnif(uninitialized => "Use of uninitialized value in &@{[__PACKAGE__]}::exhaustive");

    blessed($re) && $re->isa('Regexp')
        or croak("The second argument to &@{[__PACKAGE__]}::exhaustive must be a Regexp object (qr//)");

    for (@vars) {
        defined
            or croak("Uninitialized value passed to &@{[__PACKAGE__]}::exhaustive as variable name");

        $_ = $Aliases{$_} if exists $Aliases{$_};
    }

    if (my @bad = grep { not $Translate{$_} || /^\$[1-9]\d?\z/ } @vars) {
        $_ = qq{"$_"} for @bad;
        my $s = @bad >= 2 ? 's' : '';
        croak("Bad variable name$s to &@{[__PACKAGE__]}::exhaustive: " . join ', ', @bad);
    }

    local $Vars;
    local $Count = 0;
    local @Matches;
    my $save_match;
    {
        if (wantarray) {
            if (@vars) {
                my $vars = join ',', map { $Translate{$_} || $_ } @vars;
                $vars = "[ $vars ]" if @vars > 1;

                use re 'eval';
                my $pattern = "(?{push \@Matches, $vars})"; # So $vars interpolates.
                $save_match = qr/$pattern/;
            }
            else {
                no warnings 'closure';
                $save_match = qr/
                    (?{
                        $Vars ||= $#+
                            ? eval 'sub { \\@_ }->(' . join(',', map "\$$_", 1 .. $#+) .')'
                            : []
                        ;
                        push @Matches,
                            @$Vars == 1 ? $Vars->[0] :
                            @$Vars >  1 ? [ @$Vars ] :
                                substr($$str_ref, $-[0], $+[0] - $-[0])
                        ;
                    })
                /x;
            }
        }
        else {
            $save_match = qr/(?{$Count++})/;
        }
    }

    $Unique++;
    $$str_ref =~ /
        (?:$Unique){0} # I don't understand why $Unique is needed to
        $re            # make qr[.*] work. Do you?
        $save_match
        (?!)
    /x;

    return wantarray ? @Matches : $Count;
}

1;

__END__