File Coverage

blib/lib/Regexp/Pattern.pm

Criterion	Covered	Total	%
statement	84	85	98.8
branch	67	70	95.7
condition	4	5	80.0
subroutine	3	3	100.0
pod	1	1	100.0
total	159	164	96.9

package Regexp::Pattern;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-02-08'; # DATE
our $DIST = 'Regexp-Pattern'; # DIST
our $VERSION = '0.2.13'; # VERSION

use strict 'subs', 'vars';
#use warnings;

sub re {
    my $name = shift;
    my %args = ref($_[0]) eq 'HASH' ? %{$_[0]} : @_;

    my ($mod, $patname) = $name =~ /(.+)::(.+)/
        or die "Invalid pattern name '$name', should be 'MODNAME::PATNAME'";

    $mod = "Regexp::Pattern::$mod";
    (my $mod_pm = "$mod.pm") =~ s!::!/!g;
    require $mod_pm;

    my $var = \%{"$mod\::RE"};

    exists($var->{$patname})
        or die "No regexp pattern named '$patname' in package '$mod'";

    my $pat;
    if ($var->{$patname}{pat}) {
        $pat = $var->{$patname}{pat};
    } elsif ($var->{$patname}{gen}) {
        $pat = $var->{$patname}{gen}->(%args);
    } else {
        die "Bug in module '$mod': pattern '$patname': no pat/gen declared";
    }

    if ($args{-anchor}) {
            $pat = qr/\A(?:$pat)\z/;
    }

    return $pat;
}

sub import {
    my $package = shift;

    my $caller = caller();

    my @args = @_;
    @args = ('re') unless @args;

    while (@args) {
        my $arg = shift @args;
        my ($mod, $name0, $as, $prefix, $suffix,
            $has_tag, $lacks_tag, $has_tag_matching, $lacks_tag_matching, $gen_args);
        if ($arg eq 're') {
            *{"$caller\::re"} = \&re;
            next;
        } elsif ($arg =~ /\A(\w+(?:::\w+)*)::(\w+|\*)\z/) {
            ($mod, $name0) = ($1, $2);
            ($as, $prefix, $suffix, $has_tag, $lacks_tag, $has_tag_matching, $lacks_tag_matching) =
                (undef, undef, undef, undef, undef);
            $gen_args = {};
            while (@args >= 2 && $args[0] =~ /\A-?\w+\z/) {
                my ($k, $v) = splice @args, 0, 2;
                if ($k eq '-as') {
                    die "Cannot use -as on a wildcard import '$arg'"
                        if $name0 eq '*';
                    die "Please use a simple identifier for value of -as"
                        unless $v =~ /\A\w+\z/;
                    $as = $v;
                } elsif ($k eq '-prefix') {
                    $prefix = $v;
                } elsif ($k eq '-suffix') {
                    $suffix = $v;
                } elsif ($k eq '-has_tag') {
                    $has_tag = $v;
                } elsif ($k eq '-lacks_tag') {
                    $lacks_tag = $v;
                } elsif ($k eq '-has_tag_matching') {
                    $has_tag_matching = ref $v eq 'Regexp' ? $v : qr/$v/;
                } elsif ($k eq '-lacks_tag_matching') {
                    $lacks_tag_matching = ref $v eq 'Regexp' ? $v : qr/$v/;
                } elsif ($k !~ /\A-/) {
                    $gen_args->{$k} = $v;
                } else {
                    die "Unknown import option '$k'";
                }
            }
        } else {
            die "Invalid import '$arg', either specify 're' or a qualified ".
                "pattern name e.g. 'Foo::bar', which can be followed by ".
                "name-value pairs";
        }

        *{"$caller\::RE"} = \%{"$caller\::RE"};

        my @names;
        if ($name0 eq '*') {
            my $mod = "Regexp::Pattern::$mod";
            (my $mod_pm = "$mod.pm") =~ s!::!/!g;
            require $mod_pm;
            my $var = \%{"$mod\::RE"};
            for my $n (sort keys %$var) {
                my $tags = $var->{$n}{tags} || [];
                if (defined $has_tag) {
                    next unless grep { $_ eq $has_tag } @$tags;
                }
                if (defined $lacks_tag) {
                    next if grep { $_ eq $lacks_tag } @$tags;
                }
                if (defined $has_tag_matching) {
                    next unless grep { $_ =~ $has_tag_matching } @$tags;
                }
                if (defined $lacks_tag_matching) {
                    next if grep { $_ =~ $lacks_tag_matching } @$tags;
                }
                push @names, $n;
            }
            unless (@names) {
                warn "No patterns imported in wildcard import '$mod\::*'";
            }
        } else {
            @names = ($name0);
        }
        for my $n (@names) {
            my $name = defined($as) ? $as :
                (defined $prefix ? $prefix : "") . $n .
                (defined $suffix ? $suffix : "");
            if (exists ${"$caller\::RE"}{$name}) {
                warn "Overwriting pattern '$name' by importing '$mod\::$n'";
            }
            ${"$caller\::RE"}{$name} = re("$mod\::$n", $gen_args);
        }
    }
}

1;
# ABSTRACT: Convention/framework for modules that contain collection of regexes

__END__