File Coverage

blib/lib/Regexp/CharClasses.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	2	2	100.0
condition			n/a
subroutine	64	64	100.0
pod	0	56	0.0
total	156	212	73.5

package Regexp::CharClasses;

use strict;
use warnings;

use 5.010;

use Exporter  ();
use charnames ();

our  @ISA      = qw (Exporter);
our  $VERSION  = '2009102801';

our %EXPORT_TAGS = (
    digits       => [qw [IsDigit0 IsDigit1 IsDigit2 IsDigit3 IsDigit4
                         IsDigit5 IsDigit6 IsDigit7 IsDigit8 IsDigit9
                         IsLatinDigit]],
    perl         => [qw [IsPerlSigil IsLeftParen IsRightParen IsParen]],
    english      => [qw [IsLcVowel IsUcVowel IsVowel
                         IsLcConsonant IsUcConsonant IsConsonant]],
    encode       => [qw [IsUuencode IsBase64 IsBase64url IsBase32 IsBase32hex
                         IsBase16 IsBinHex]],
);

#
# @EXPORT is defined at the bottom of the file.
#

sub _d {
    my $number = shift;
    join "\n" => map {
        my $char = $_ ? "$_ DIGIT $number" : "DIGIT $number";
        sprintf "%04X" => charnames::vianame ($char)
    } @_;
}

sub _n {
    join "\n" => map {
        s/^\s+//;
        sprintf "%04X" => charnames::vianame ($_)
    } split "\n" => shift;
}

sub __ {
    my $_ = shift;
    s/^\s+//mg;
    $_;
}

#
# I'd prefer 'state', but that gives errors.
#
my $digits = [map {s/^\s+//; $_} split "\n" => <<"--"];

    ARABIC-INDIC
    EXTENDED ARABIC-INDIC
    NKO
    DEVANAGARI
    BENGALI
    GURMUKHI
    GUJARATI
    ORIYA
    TAMIL
    TELUGU
    KANNADA
    MALAYALAM
    THAI
    LAO
    TIBETAN
    MYANMAR
    KHMER
    MONGOLIAN
    LIMBU
    NEW TAI LUE
    BALINESE
    FULLWIDTH
    OSMANYA
    MATHEMATICAL BOLD
    MATHEMATICAL DOUBLE-STRUCK
    MATHEMATICAL SANS-SERIF
    MATHEMATICAL SANS-SERIF BOLD
    MATHEMATICAL MONOSPACE
--

my $numbers = [map {s/^\s+//; $_} split "\n" => <<"--"];
    ZERO
    ONE
    TWO
    THREE
    FOUR
    FIVE
    SIX
    SEVEN
    EIGHT
    NINE
--

sub IsDigit0    {state $return = _d ZERO  => @$digits}
sub IsDigit1    {state $return = _d ONE   => @$digits}
sub IsDigit2    {state $return = _d TWO   => @$digits}
sub IsDigit3    {state $return = _d THREE => @$digits}
sub IsDigit4    {state $return = _d FOUR  => @$digits}
sub IsDigit5    {state $return = _d FIVE  => @$digits}
sub IsDigit6    {state $return = _d SIX   => @$digits}
sub IsDigit7    {state $return = _d SEVEN => @$digits}
sub IsDigit8    {state $return = _d EIGHT => @$digits}
sub IsDigit9    {state $return = _d NINE  => @$digits}

foreach my $language (@$digits) {
    next if !$language;
    my $t_name   =  join "" => map {ucfirst lc} split /\W+/ => $language;
    my $sub_name = "Is${t_name}Digit";
    push @{$EXPORT_TAGS {digits}} => $sub_name;
    if ($language eq "FULLWIDTH" || $language =~ /^MATHEMATICAL/
                                 || $language =~ /ARABIC-INDIC$/) {
        eval <<"        --";
            sub $sub_name {
                state \$return = _n join "\n" =>
                                    map {"$language DIGIT \$_"} \@\$numbers;
            }
        --
        die $@ if $@;
    }
    else {
        eval <<"        --";
            sub $sub_name {state \$return = __ <<"            --"}
                +utf8::Is${t_name}
                &utf8::IsDigit
            --
        --
        die $@ if $@;
    }
}

sub IsLatinDigit {
    state $return = _n join "\n" => map {"DIGIT $_"} @$numbers
}

sub IsPerlSigil {state $return = _n <<"--"}
    DOLLAR SIGN
    PERCENT SIGN
    AMPERSAND
    ASTERISK
    COMMERCIAL AT
--

sub IsLeftParen {state $return = _n <<"--"}
    LEFT PARENTHESIS
    LESS-THAN SIGN
    LEFT SQUARE BRACKET
    LEFT CURLY BRACKET
--

sub IsRightParen {state $return = _n <<"--"}
    RIGHT PARENTHESIS
    GREATER-THAN SIGN
    RIGHT SQUARE BRACKET
    RIGHT CURLY BRACKET
--

sub IsParen {state $return = __ <<"--"}
    +Regexp::CharClasses::IsLeftParen
    +Regexp::CharClasses::IsRightParen
--

sub IsLcVowel {state $return = _n <<"--"}
    LATIN SMALL LETTER A
    LATIN SMALL LETTER E
    LATIN SMALL LETTER I
    LATIN SMALL LETTER O
    LATIN SMALL LETTER U
--

sub IsUcVowel {state $return = _n <<"--"}
    LATIN CAPITAL LETTER A
    LATIN CAPITAL LETTER E
    LATIN CAPITAL LETTER I
    LATIN CAPITAL LETTER O
    LATIN CAPITAL LETTER U
--

sub IsVowel {state $return = __ <<"--"}
    +Regexp::CharClasses::IsLcVowel
    +Regexp::CharClasses::IsUcVowel
--

sub IsLcConsonant {state $return = __ <<"--"}
    0061 007A
    -Regexp::CharClasses::IsLcVowel
--

sub IsUcConsonant {state $return = __ <<"--"}
    0041 005A
    -Regexp::CharClasses::IsUcVowel
--

sub IsConsonant {state $return = __ <<"--"}
    +Regexp::CharClasses::IsLcConsonant
    +Regexp::CharClasses::IsUcConsonant
--

# Space to grave accent.
sub IsUuencode {state $return = __ <<"--"}
    0020 0060
--

# A-Z, a-z, 0-9, '+' and '/'; '=' is use for padding. (RFC 4648)
sub IsBase64 {state $return = __ <<"--"}
    0030 0039
    0041 005A
    0061 007A
    002B
    002F
    003D
--

# A-Z, a-z, 0-9, '-' and '_'; '=' is use for padding. (RFC 4648)
sub IsBase64url {state $return = __ <<"--"}
    0030 0039
    0041 005A
    0061 007A
    002D
    005F
    003D
--

# A-Z, 2-7; '=' is use for padding. (RFC 4648)
sub IsBase32 {state $return = __ <<"--"}
    0032 0037
    0041 005A
    003D
--


# 0-9, A-V; '=' is use for padding. (RFC 4648)
sub IsBase32hex {state $return = __ <<"--"}
    0030 0039
    0041 0056
    003D
--


# 0-9, A-F. (RFC 4648)
sub IsBase16 {state $return = __ <<"--"}
    0030 0039
    0041 0046
--

# !"#$%&'()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr
# Note, no 'O', no 'W', no 'g', no 'n', no 'o'
sub IsBinHex {state $return = __ <<"--"}
    0021 002D
    0030 0039
    0040 004E
    0050 0056
    0058 005B
    0060 0066
    0068 006D
    0070 0072
--


our @EXPORT = map {@$_} values %EXPORT_TAGS;

1;

__END__