File Coverage

blib/lib/Unicode/Security.pm

Criterion	Covered	Total	%
statement	89	89	100.0
branch	32	38	84.2
condition	7	9	77.7
subroutine	16	16	100.0
pod	8	8	100.0
total	152	160	95.0

package Unicode::Security;

use 5.008;
use strict;
use warnings;
use Exporter qw(import);

use Unicode::Security::Confusables;
use Unicode::Normalize qw(NFD);
use Unicode::UCD qw(charinfo charscript);

our $VERSION = '0.08';
$VERSION = eval $VERSION;

our @EXPORT_OK = qw(
    skeleton confusable soss restriction_level mixed_script
    mixed_number mixed_num
    whole_script_confusable mixed_script_confusable
    ws_confusable ms_confusable
);

our (%MA, %WS);

use constant {
    UNRESTRICTED           => 0,
    ASCII_ONLY             => 1,
    SINGLE_SCRIPT          => 2,
    HIGHLY_RESTRICTIVE     => 3,
    MODERATELY_RESTRICTIVE => 4,
    MINIMALLY_RESTRICTIVE  => 5,
};

my %recommended_script = map { $_ => \1 } qw(
    Common Inherited Arabic Armenian Bengali Bopomofo Cyrillic Devanagari
    Ethiopic Georgian Greek Gujarati Gurmukhi Han Hangul Hebrew Hiragana
    Kannada Katakana Khmer Lao Latin Malayalam Myanmar Oriya Sinhala Tamil
    Telugu Thaana Thai Tibetan
);

my %aspirational_script = map { $_ => \1 } qw(
    Canadian_Aboriginal Miao Mongolian Tifinagh Yi
);

my %highly_restrictive = map { $_ => \1 } (
    '', 'Hiragana', 'Katakana', 'Hiragana, Katakana', 'Bopomofo', 'Hangul',
);


sub skeleton {
    my $str = NFD shift;
    my $m = $str =~ s{(.)}{ my $c = $MA{$1}; defined $c ? $c : $1 }eg;
    return $m ? NFD $str : $str;
}


sub confusable {
    return skeleton($_[0]) eq skeleton($_[1]);
}


# Algorithm described here:
#   http://www.unicode.org/reports/tr39/#Whole_Script_Confusables
sub whole_script_confusable {
    my ($target, $str) = @_;

    # Canonicalize the script name to match the format used in %WS.
    $target = ucfirst lc $target;

    my %soss = soss(NFD $str);
    delete @soss{qw(Common Inherited)};

    my $count = keys %soss or return '';
    return if 1 < $count;
    my ($source) = keys %soss;

    my $chars = $WS{$source}{$target};
    do { return 1 if $chars->{$_} } for keys %{ $soss{$source} };
}
*ws_confusable = *ws_confusable = \&whole_script_confusable;


# Algorithm described here:
#   http://www.unicode.org/reports/tr39/#Mixed_Script_Confusables
sub mixed_script_confusable {
    my %soss = soss(NFD $_[0]);
    delete @soss{qw(Common Inherited)};

    my @soss = keys %soss;
    for my $source (@soss) {
        my $sum = 0;
        for my $target (@soss) {
            next if $target eq $source;

            my $nok = 0;
            my $chars = $WS{$target}{$source};
            for my $char (keys %{ $soss{$target} }) {
                $nok = 1, last unless $chars->{$char};
            }
            last if $nok;
            $sum++;
        }

        return 1 if 1 == @soss - $sum;
    }

    return '';
}
*ms_confusable = *ms_confusable = \&mixed_script_confusable;


sub soss {
    my %soss;
    for my $char (split //, $_[0]) {
        my $script = charscript(ord($char));
        $script = 'Unknown' unless defined $script;
        $soss{$script}{$char} = \1;
    }
    return %soss;
}


sub mixed_script {
    my %soss = soss($_[0]);
    delete @soss{qw(Common Inherited)};
    return 1 < keys %soss;
}


sub mixed_number {
    my %z;
    for my $char (split //, $_[0]) {
        my $info = charinfo(ord $char) or next;

        my $num = $info->{decimal};
        next unless length $num;

        $z{ ord($char) - $num } = \1;
    }

    return 1 < keys %z;
}
*mixed_num = *mixed_num = \&mixed_number;


# Algorithm described here:
#   http://www.unicode.org/reports/tr39/#Restriction_Level_Detection
sub restriction_level {
    my ($str, $non_id_regex) = @_;

    $non_id_regex = qr/\P{ID_Continue}/ unless defined $non_id_regex;

    return UNRESTRICTED if $str =~ /$non_id_regex/;
    return ASCII_ONLY   if $str !~ /\P{ASCII}/;

    my %soss = soss($str);
    delete @soss{qw(Common Inherited)};
    return SINGLE_SCRIPT if 1 == keys %soss;

    delete $soss{Latin};
    my %copy = %soss;
    delete $copy{Han};
    my $soss = join ', ', sort keys %copy;
    return HIGHLY_RESTRICTIVE if $highly_restrictive{$soss};

    if (1 == keys %soss) {
        my ($script) = keys %soss;
        return MODERATELY_RESTRICTIVE
            if ($recommended_script{$script} or $aspirational_script{$script})
                and not ($soss{Cyrillic} or $soss{Greek});

    }

    return MINIMALLY_RESTRICTIVE;
}


1;

__END__