File Coverage

blib/lib/Unicode/CheckUTF8/PP.pm

Criterion	Covered	Total	%
statement	10	10	100.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod	1	1	100.0
total	15	15	100.0

package Unicode::CheckUTF8::PP;
$Unicode::CheckUTF8::PP::VERSION = '0.003';
use base qw(Exporter);
# ABSTRACT: Pure Perl implementation of Unicode::CheckUTF8

use strict;
use warnings;

our @EXPORT    = qw();
our @EXPORT_OK = qw(is_utf8);

my @validSingleByte = (
    0,0,0,0,0,0,0,0,0,1,1,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0
);

my @trailingBytesForUTF8 = (
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
    1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
    2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,5,5,5,5
);

my $_isLegalUTF8 = sub {
    my ($bytes, $length) = @_;

    my $i = $length;
    if ( $length <= 4 ) {
       my $c;
       if ( $length == 4 ) {
          $c = $bytes->[--$i];
          return 0 unless defined $c;
          return 0 if $c < 0x80 || $c > 0xBF;
       }

       if ( $length >= 3 ) {
          $c = $bytes->[--$i];
          return 0 unless defined $c;
          return 0 if $c < 0x80 || $c > 0xBF;
       }

       if ( $length >= 2 ) {
          $c = $bytes->[--$i];
          return 0 unless defined $c;
          return 0 if $c > 0xBF;

          if    ( $bytes->[$i] == 0xE0 ) { return 0 if $c < 0xA0; }
          elsif ( $bytes->[$i] == 0xF0 ) { return 0 if $c < 0x90; }
          elsif ( $bytes->[$i] == 0xF0 ) { return 0 if $c > 0x8F; }
          else                           { return 0 if $c < 0x80; }
      }

       if ( $length >= 1 ) {
          return $validSingleByte[ $bytes->[0] ];
       }
    }
    else {
       return 0;
    }

    return 1;
};

my $_isLegalUTF8String = sub {
    my ($str) = @_;

    my @bytes = unpack 'U*', $str;
    my $len = @bytes;
    my $l = 0;

    my $i = 0;
    while ( $i < $len ) {
       my $byte = $bytes[$i];
       my $length = $trailingBytesForUTF8[$byte] + 1;

       # check for early termination of string
       foreach my $j ( 1 .. $length - 1 ) {
          return 0 unless defined $bytes[$j];
          return 0 if $bytes[$j] == 0;
       }

       return 0 unless
          $_isLegalUTF8->([@bytes[$i..$i+$length-1]], $length);

       $l = $bytes[$i];
       $i += $length;
    }

    return ($l || 0) == ($bytes[-1] || 0) ? 1 : 0;
};

sub is_utf8 {
    return $_isLegalUTF8String->(@_);
}

1;

__END__