File Coverage

blib/lib/YATT/Lite/RegexpNames.pm

Criterion	Covered	Total	%
statement	24	27	88.8
branch	3	4	75.0
condition			n/a
subroutine	8	11	72.7
pod	0	7	0.0
total	35	49	71.4

package YATT::Lite::RegexpNames;
use strict;
use warnings qw(FATAL all NONFATAL misc);

use Exporter qw/import/;
use YATT::Lite::Util qw/globref symtab/;

#========================================

sub wrap {
  my ($re, $partial) = @_;
  $partial ? $re : qq!^$re\\z!;
}

# $this->re_name     returns ^\w+$  -- Total pattern, usually for user input.
# $this->re_name(1)  returns  \w+   -- Partial pattern.

sub re_name     { wrap(qr{\w+}, $_[1]) }

sub re_digit    { wrap(qr{(?:[0-9]+)}, $_[1]) }

sub re_integer  { wrap(qr{(?:0|[1-9]\d*)}, $_[1]) }

# Mainly for untainting.
sub re_any      { wrap(qr{.*}s, $_[1]) }

# 'nonempty'-check should not complain about surrounding white spaces.
sub re_nonempty { qr{\S.*}s }

# aliases
*re_word = *re_name; *re_word = *re_name;
*re_int = *re_integer; *re_int = *re_integer;
*re_digits = *re_digit; *re_digits = *re_digit;


#========================================

__PACKAGE__->build_exports(\ our(@EXPORT, @EXPORT_OK));

sub build_exports {
  my ($pack, @vars) = @_;
  my $symtab = symtab($pack);
  foreach my $name (grep {/^re_/} keys %$symtab) {
    my $glob = $symtab->{$name};
    next unless *{$glob}{CODE};
    push @$_, $name for @vars;
  }
}

1;