File Coverage

blib/lib/Test/Regexp.pm

Criterion	Covered	Total	%
statement	246	250	98.4
branch	92	102	90.2
condition	49	60	81.6
subroutine	28	28	100.0
pod	4	7	57.1
total	419	447	93.7

package Test::Regexp;

use 5.010;

BEGIN {
    binmode STDOUT, ":utf8";
}

use strict;
use warnings;
use charnames ":full";
no  warnings 'syntax';

use Exporter ();
use Test::Builder;

our @EXPORT  = qw [match no_match];
our @ISA     = qw [Exporter Test::More];

our $VERSION = '2016060501';


my $Test = Test::Builder -> new;

my $ESCAPE_NONE           = 0;
my $ESCAPE_WHITE_SPACE    = 1;
my $ESCAPE_NAMES          = 2;
my $ESCAPE_CODES          = 3;
my $ESCAPE_NON_PRINTABLE  = 4;
my $ESCAPE_DEFAULT        = ${^UNICODE} ? $ESCAPE_NON_PRINTABLE
                                        : $ESCAPE_CODES;

sub import {
    my $self = shift;
    my $pkg  = caller;

    my %arg  = @_;

    $Test -> exported_to ($pkg);

    $arg {import} //= [qw [match no_match]];

    while (my ($key, $value) = each %arg) {
        if ($key eq "tests") {
            $Test -> plan ($value);
        }
        elsif ($key eq "import") {
            $self -> export_to_level (1, $self, $_) for @{$value || []};
        }
        else {
            die "Unknown option '$key'\n";
        }
    }
}


my $__ = "    ";

sub escape {
    my ($str, $escape) = @_;
    $escape //= $ESCAPE_DEFAULT;
    return $str if $escape == $ESCAPE_NONE;
    $str =~ s/\n/\\n/g;
    $str =~ s/\t/\\t/g;
    $str =~ s/\r/\\r/g;
    if ($escape == $ESCAPE_NAMES) {
        $str =~ s{([^\x20-\x7E])}
                 {my $name = charnames::viacode (ord $1);
                  $name ? sprintf "\\N{%s}"   => $name
                        : sprintf "\\x{%02X}" => ord $1}eg;
    }
    elsif ($escape == $ESCAPE_CODES) {
        $str =~ s{([^\x20-\x7E])}
                 {sprintf "\\x{%02X}" => ord $1}eg;
    }
    elsif ($escape == $ESCAPE_NON_PRINTABLE) {
        $str =~ s{([\x00-\x1F\xFF])}
                 {sprintf "\\x{%02X}" => ord $1}eg;
    }
    $str;
}

sub pretty {
    my $str = shift;
    my %arg = @_;
    substr ($str, 50, -5, "...") if length $str > 55 && !$arg {full_text};
    $str = escape $str, $arg {escape};
    $str;
}


sub mess {
    my $val = shift;
    unless (defined $val) {return 'undefined'}
    my %arg = @_;
    my $pretty = pretty $val, full_text => $arg {full_text},
                              escape    => $arg {escape};
    if ($pretty eq $val && $val !~ /'/) {
        return "eq '$val'";
    }
    elsif ($pretty !~ /"/) {
        return 'eq "' . $pretty . '"';
    }
    else {
        return "eq qq {$pretty}";
    }
}


sub todo {
    my %arg       =  @_;
    my $subject   =  $arg {subject};
    my $comment   =  $arg {comment};
    my $upgrade   =  $arg {upgrade};
    my $downgrade =  $arg {downgrade};
    my $neg       =  $arg {match} ? "" : "not ";
    my $full_text =  $arg {full_text};
    my $escape    =  $arg {escape};

    my $line      = "";

    if ($arg {show_line}) {
        no warnings 'once';
        my ($file, $l_nr)  = (caller ($Test::Builder::deepness // 1)) [1, 2];
        $line = " [$file:$l_nr]";
    }

    my $subject_pretty = pretty $subject, full_text => $full_text,
                                          escape    => $escape;
    my $Comment        = qq {qq {$subject_pretty}};
       $Comment       .= qq { ${neg}matched by "$comment"};

    my @todo = [$subject, $Comment, $line];

    #
    # If the subject isn't already UTF-8, and there are characters in
    # the range "\x{80}" .. "\x{FF}", we do the test a second time,
    # with the subject upgraded to UTF-8.
    #
    # Otherwise, if the subject is in UTF-8 format, and there are *no*
    # characters with code point > 0xFF, but with characters in the
    # range 0x80 .. 0xFF, we downgrade and test again.
    #
    if ($upgrade && ($upgrade == 2 ||    !utf8::is_utf8 ($subject)
                                      && $subject =~ /[\x80-\xFF]/)) {
        my $subject_utf8 = $subject;
        if (utf8::upgrade ($subject_utf8)) {
            my $Comment_utf8   = qq {qq {$subject_pretty}};
               $Comment_utf8  .= qq { [UTF-8]};
               $Comment_utf8  .= qq { ${neg}matched by "$comment"};

            push @todo => [$subject_utf8, $Comment_utf8, $line];
        }
    }
    elsif ($downgrade && ($downgrade == 2 ||     utf8::is_utf8 ($subject)
                                             && $subject =~ /[\x80-\xFF]/
                                             && $subject !~ /[^\x00-\xFF]/)) {
        my $subject_non_utf8 = $subject;
        if (utf8::downgrade ($subject_non_utf8)) {
            my $Comment_non_utf8  = qq {qq {$subject_pretty}};
               $Comment_non_utf8 .= qq { [non-UTF-8]};
               $Comment_non_utf8 .= qq { ${neg}matched by "$comment"};

            push @todo => [$subject_non_utf8, $Comment_non_utf8, $line];
        }
    }

    @todo;
}



#
# Arguments:
#   name:         'Name' of the pattern.
#   pattern:       Pattern to be tested, without captures.
#   keep_pattern:  Pattern to be tested, with captures.
#   subject:       String to match.
#   captures:      Array of captures; elements are either strings
#                  (match for the corresponding numbered capture),
#                  or an array, where the first element is the name
#                  of the capture and the second its value.
#   comment:       Comment to use, defaults to name or "".
#   utf8_upgrade:  If set, upgrade the string if applicable. Defaults to 1.
#   utf8_downgrade If set, downgrade the string if applicable. Defaults to 1.
#   match          If true, pattern(s) should match, otherwise, should fail
#                  to match. Defaults to 1.
#   reason         The reason a match should fail.
#   test           What is tested.
#   todo           This test is a todo test; argument is the reason.
#   show_line      Show file name/line number of call to 'match'.
#   full_text      Don't shorten long messages.
#

sub match {
    my %arg            = @_;

    my $name           = $arg {name};
    my $pattern        = $arg {pattern};
    my $keep_pattern   = $arg {keep_pattern};
    my $subject        = $arg {subject};
    my $captures       = $arg {captures}       // [];
    my $comment        = escape $arg {comment} // $name // "";
    my $upgrade        = $arg {utf8_upgrade}   // 1;
    my $downgrade      = $arg {utf8_downgrade} // 1;
    my $match          = $arg {match}          // 1;
    my $reason         = defined $arg {reason}
                                       ? " [Reason: " . $arg {reason} . "]"
                                       : "";
    my $test           = defined $arg {test}
                                       ? " [Test: "   . $arg {test}   . "]"
                                       : "";
    my $show_line      = $arg {show_line};
    my $full_text      = $arg {full_text};
    my $escape         = $arg {escape};
    my $todo           = $arg {todo};
    my $keep_message   = $arg {no_keep_message} ? "" : " (with -Keep)";

    my $numbered_captures;
    my $named_captures;

    my $pass           = 1;

    #
    # First split the captures into a hash (for named captures) and
    # an array (for numbered captures) so we can check $1 and friends, and %-.
    #
    foreach my $capture (@$captures) {
        if (ref $capture eq 'ARRAY') {
            my ($name, $match) = @$capture;
            push   @$numbered_captures => $match;
            push @{$$named_captures {$name}} => $match;
        }
        else {
            push @$numbered_captures => $capture;
        }
    }

    $numbered_captures ||= [];
    $named_captures    ||= {};

    my @todo = todo subject   => $subject,
                    comment   => $comment,
                    upgrade   => $upgrade,
                    downgrade => $downgrade,
                    match     => $match,
                    show_line => $show_line,
                    full_text => $full_text,
                    escape    => $escape;

    $Test -> todo_start ($todo) if defined $todo;

    #
    # Now we will do the tests.
    #
    foreach my $todo (@todo) {
        my $subject = $$todo [0];
        my $comment = $$todo [1];
        my $line    = $$todo [2];

        if ($match && defined $pattern) {
            my $comment = $comment;
            my $pat     =  ref $pattern ?     $pattern
                                        : qr /$pattern/;
               $comment =~ s{""$}{/$pat/};
               $comment .= "$line$test";
            #
            # Test match; match should also be complete, and not
            # have any captures.
            #
            SKIP: {
                my $result = $subject =~ /^$pattern/;
                unless ($Test -> ok ($result, $comment)) {
                    $Test -> skip ("Match failed") for 1 .. 3;
                    $pass = 0;
                    last SKIP;
                }

                #
                # %- contains an entry for *each* named group, regardless
                # whether it's a capture or not.
                #
                my $named_matches  = 0;
                   $named_matches += @$_ for values %-;

                unless ($Test -> is_eq ($&, $subject,
                                       "${__}match is complete")) {
                    $Test -> skip ("Match failed") for 2 .. 3;
                    $pass = 0;
                    last SKIP;
                }

                $pass = 0 unless
                    $Test -> is_eq (scalar @+, 1,
                                    "${__}no numbered captures");
                $pass = 0 unless
                    $Test -> is_eq ($named_matches, 0,
                                   "${__}no named captures");
            }
        }


        if ($match && defined $keep_pattern) {
            my $comment = $comment;
            my $pat     =  ref $keep_pattern ?     $keep_pattern
                                             : qr /$keep_pattern/;
               $comment =~ s{""$}{/$pat/};
               $comment .= $keep_message;
               $comment .= "$line$test";
            #
            # Test keep. Should match, and the parts as well.
            #
            # Total number of tests:
            #   - 1 for match.
            #   - 1 for match complete.
            #   - 1 for each named capture.
            #   - 1 for each capture name.
            #   - 1 for number of different capture names.
            #   - 1 for each capture.
            #   - 1 for number of captures.
            # So, if you only have named captures, and all the names
            # are different, you have 4 + 3 * N tests.
            # If you only have numbered captures, you have 4 + N tests.
            #
            SKIP: {
                my $nr_of_tests  = 0;
                   $nr_of_tests += 1;  # For match.
                   $nr_of_tests += 1;  # For match complete.
                   $nr_of_tests += @{$_} for values %$named_captures;
                                       # Number of named captures.
                   $nr_of_tests += scalar keys %$named_captures;
                                       # Number of different named captures.
                   $nr_of_tests += 1;  # Right number of named captures.
                   $nr_of_tests += @$numbered_captures;
                                       # Number of numbered captures.
                   $nr_of_tests += 1;  # Right number of numbered captures.

                my ($amp, @numbered_matches, %minus);

                my $result = $subject =~ /^$keep_pattern/;
                unless ($Test -> ok ($result, $comment)) {
                    $Test -> skip ("Match failed") for 2 .. $nr_of_tests;
                    $pass = 0;
                    last SKIP;
                }


                #
                # Copy $&, $N and %- before doing anything that
                # migh override them.
                #

                $amp = $&;

                #
                # Grab numbered captures.
                #
                for (my $i = 1; $i < @+; $i ++) {
                    no strict 'refs';
                    push @numbered_matches => $$i;
                }

                #
                # Copy %-;
                #
                while (my ($key, $value) = each %-) {
                    $minus {$key} = [@$value];
                }

                #
                # Test to see if match is complete.
                #
                unless ($Test -> is_eq ($amp, $subject,
                                       "${__}match is complete")) {
                    $Test -> skip ("Match incomplete") for 3 .. $nr_of_tests;
                    $pass = 0;
                    last SKIP;
                }

                #
                # Test named captures.
                #
                while (my ($key, $value) = each %$named_captures) {
                    for (my $i = 0; $i < @$value; $i ++) {
                        $pass = 0 unless
                            $Test -> is_eq (
                                $minus {$key} ? $minus {$key} [$i] : undef,
                                $$value [$i],
                               "${__}\$- {$key} [$i] " .
                                mess ($$value [$i], full_text => $full_text,
                                                    escape    => $escape));
                    }
                    $pass = 0 unless
                        $Test -> is_num (scalar @{$minus {$key} || []},
                                 scalar @$value, "$__${__}capture '$key' has " .
                                 (@$value == 1 ? "1 match" :
                                        @$value . " matches"));
                }
                #
                # Test for the right number of captures.
                #
                $pass = 0 unless
                    $Test -> is_num (scalar keys %minus,
                                     scalar keys %$named_captures,
                              $__ . scalar (keys %$named_captures)
                                  . " named capture groups"
                    );


                #
                # Test numbered captures.
                #
                for (my $i = 0; $i < @$numbered_captures; $i ++) {
                    $pass = 0 unless
                        $Test -> is_eq ($numbered_matches [$i],
                                        $$numbered_captures [$i],
                                       "${__}\$" . ($i + 1) . " " .
                                        mess ($$numbered_captures [$i],
                                                full_text => $full_text,
                                                escape    => $escape));
                }
                $pass = 0 unless
                    $Test -> is_num (scalar @numbered_matches,
                                     scalar @$numbered_captures,
                                     $__ .
                                     (@$numbered_captures == 1     ?
                                        "1 numbered capture group" :
                                      @$numbered_captures .
                                         " numbered capture groups"));
            }
        }

        if (!$match && defined $pattern) {
            my $comment = $comment;
            my $pat     =  ref $pattern ?     $pattern
                                        : qr /$pattern/;
               $comment =~ s{""$}{/$pat/};
               $comment .= "$line$reason";
            my $r = $subject =~ /^$pattern/;
            $pass = 0 unless
                $Test -> ok (!$r || $subject ne $&, $comment);
        }
        if (!$match && defined $keep_pattern) {
            my $comment = $comment;
            my $pat     =  ref $keep_pattern ?     $keep_pattern
                                             : qr /$keep_pattern/;
               $comment =~ s{""$}{/$pat/};
               $comment .= $keep_message;
               $comment .= "$line$reason";
            my $r = $subject =~ /^$keep_pattern/;
            $pass = 0 unless
                $Test -> ok (!$r || $subject ne $&, $comment);
        }
    }

    $Test -> todo_end if defined $todo;

    $pass;
}

sub no_match {
    push @_ => match => 0;
    goto &match;
}

sub new {
    "Test::Regexp::Object" -> new
}

package Test::Regexp::Object;

sub new {
    bless \do {my $var} => shift;
}

use Hash::Util::FieldHash qw [fieldhash];

fieldhash my %pattern;
fieldhash my %keep_pattern;
fieldhash my %name;
fieldhash my %comment;
fieldhash my %utf8_upgrade;
fieldhash my %utf8_downgrade;
fieldhash my %match;
fieldhash my %reason;
fieldhash my %test;
fieldhash my %show_line;
fieldhash my %full_text;
fieldhash my %escape;
fieldhash my %todo;
fieldhash my %tags;
fieldhash my %no_keep_message;

sub init {
    my $self = shift;
    my %arg  = @_;

    $pattern             {$self} = $arg {pattern};
    $keep_pattern        {$self} = $arg {keep_pattern};
    $name                {$self} = $arg {name};
    $comment             {$self} = $arg {comment};
    $utf8_upgrade        {$self} = $arg {utf8_upgrade};
    $utf8_downgrade      {$self} = $arg {utf8_downgrade};
    $match               {$self} = $arg {match};
    $reason              {$self} = $arg {reason};
    $test                {$self} = $arg {test};
    $show_line           {$self} = $arg {show_line};
    $full_text           {$self} = $arg {full_text};
    $escape              {$self} = $arg {escape};
    $todo                {$self} = $arg {todo};
    $tags                {$self} = $arg {tags} if exists $arg {tags};
    $no_keep_message     {$self} = $arg {no_keep_message};

    $self;
}

sub args {
    my  $self = shift;
    (
        pattern             => $pattern             {$self},
        keep_pattern        => $keep_pattern        {$self},
        name                => $name                {$self},
        comment             => $comment             {$self},
        utf8_upgrade        => $utf8_upgrade        {$self},
        utf8_downgrade      => $utf8_downgrade      {$self},
        match               => $match               {$self},
        reason              => $reason              {$self},
        test                => $test                {$self},
        show_line           => $show_line           {$self},
        full_text           => $full_text           {$self},
        escape              => $escape              {$self},
        todo                => $todo                {$self},
        no_keep_message     => $no_keep_message     {$self},
    )
}

sub match {
    my  $self     = shift;
    my  $subject  = shift;
    my  $captures = @_ % 2 ? shift : undef;

    Test::Regexp::match subject  => $subject,
                        captures => $captures,
                        $self    -> args,
                        @_;
}

sub no_match {
    my  $self    = shift;
    my  $subject = shift;

    Test::Regexp::no_match subject  => $subject,
                           $self    -> args,
                           @_;
}

sub name {$name {+shift}}

sub set_tag {
    my $self = shift;
    $tags {$self} {$_ [0]} = $_ [1];
}
sub tag {
    my $self = shift;
    $tags {$self} {$_ [0]};
}



1;

__END__