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(charscript num);

our $VERSION = '0.02';
$VERSION = eval $VERSION;

our @EXPORT_OK = qw(
    skeleton confusable soss restriction_level mixed_number
);

our %MA;

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]);
}


sub soss {
    return map { charscript(ord($_)) => \1 } split //, $_[0];
}

# 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;
}


sub mixed_number {
    my %z;
    for my $char (split //, $_[0]) {
        my $num = num $char;
        return unless defined $num;
        $z{ ord($char) - $num } = \1;
    }

    return 1 < keys %z;
}


1;

__END__

=head1 NAME

Unicode::Security - Unicode security mechanisms

=head1 SYNOPSIS

    use Unicode::Security qw(confusable restriction_level)

    $truth = confusable($string1, $string2);
    $level = restriction_level($string);

=head1 DESCRIPTION

Implements the Unicode security mechanisms as described in the Unicode
Technical Standard #39.

=head1 FUNCTIONS

=head2 confusable

    $truth = confusable($string1, $string2)

Returns true if if the two strings are confusable.

=head2 skeleton

    $skel = skeleton($string)

The skeleton transform is used internally by the confusable algorithm. The
result is not intended for display, storage or transmission. It should be
thought of as an intermediate processing form, similar to a hashcode. The
characters in the skeleton are not guaranteed to be identifier characters.

=head2 restriction_level

    $level = restriction_level($string [, $non_id_regex])

Returns the restriction level (0-5) of the string. The default Identifier
Profile matches against B<\P{ID_Continue}>. If you want to use a different
Identifier Profile, you can pass in an optional regular expression to test for
non-identifier characters.

=head2 soss

    %soss = soss($string)

The set of Unicode character script names for a given string. Used internally
by the restriction level algorithm.


=head2 mixed_number

    $truth = mixed_number

Returns true if the string is composed of characters from different decimal
number systems. Returns undef if the string contains characters other than
decimal numbers.

=head1 SEE ALSO

L<http://www.unicode.org/reports/tr39/>

=head1 TODO

=over

=item * whole-script confusable detection
L<http://www.unicode.org/reports/tr39/#Whole_Script_Confusables>

=item * mixed-script confusable detection
L<http://www.unicode.org/reports/tr39/#Mixed_Script_Confusables>

=item * mixed-script detection
L<http://www.unicode.org/reports/tr39/#Mixed_Script_Detection>

=back

=head1 REQUESTS AND BUGS

Please report any bugs or feature requests to
L<http://rt.cpan.org/Public/Bug/Report.html?Queue=Unicode-Security>. I will be
notified, and then you'll automatically be notified of progress on your bug as
I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Unicode::Security

You can also look for information at:

=over

=item * GitHub Source Repository

L<http://github.com/gray/unicode-security>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Unicode-Security>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Unicode-Security>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/Public/Dist/Display.html?Name=Unicode-Security>

=item * Search CPAN

L<http://search.cpan.org/dist/Unicode-Security/>

=back

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 gray <gray at cpan.org>, all rights reserved.

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

gray, <gray at cpan.org>

=cut
