File Coverage

blib/lib/Convert/RACE.pm

Criterion	Covered	Total	%
statement	85	99	85.8
branch	28	42	66.6
condition	17	24	70.8
subroutine	13	14	92.8
pod	3	3	100.0
total	146	182	80.2

package Convert::RACE;

use strict;
use vars qw($VERSION @ISA @EXPORT);

BEGIN {
    require Exporter;
    @ISA = qw(Exporter);
    @EXPORT = qw(to_race from_race);

    $VERSION = '0.07';
}

use Carp ();
use Convert::Base32 qw(encode_base32 decode_base32);

use constant COMPRESS_EXCEPTION		=> 'Invalid encoding to compress';
use constant DECOMPRESS_EXCEPTION	=> 'Invalid format to decompress';

my $_prefix_tag = 'bq--';

sub prefix_tag {
    my $class = shift;
    $_prefix_tag = $_[0] if (@_);
    return $_prefix_tag;
}

sub to_race($) {
    my $str = shift;

    # 2.2.1 Check the input string for disallowed names
    unless (_include_disallowed_names($str)) {
        Carp::croak('String includes no internationalized characters');
    }

    # 2.2.2 Compress the pre-converted string
    my $compressed = _compress($str);

    # 2.2.3 Check the length of the compressed string
    if (length($compressed) > 36) {
        Carp::croak('String too long');
    }

    # 2.2.4 Encode the compressed string with Base32
    my $encoded = encode_base32($compressed);

    # 2.2.5 Prepend "bq--" to the encoded string and finish
    return $_prefix_tag . $encoded;
}

sub from_race($) {
    my $str = lc(shift);

    # 2.3.1 Strip the "bq--"
    $str =~ s/^$_prefix_tag// or Carp::croak("String not begin with $_prefix_tag");

    # 2.3.2 Decode the stripped string with Base32
    my $decoded = decode_base32($str);

    # 2.3.3 Decompress the decoded string
    my $decompressed = _decompress($decoded);

    # 2.3.4 Check the internationalized string for disallowed names
    unless (_include_disallowed_names($decompressed)) {
        Carp::croak('Decoded string includes no internationalized characters');
    }

    return $decompressed;
}


sub _compress($) {
    my $str = shift;

    my @unique_upper_octet = _make_uniq_upper_octet($str);
    if (@unique_upper_octet > 2 ||
	 (@unique_upper_octet == 2 &&
	  ! grep { $_ eq "\x00" } @unique_upper_octet)) {
	# from more than 2 rows
	# or from 2 rows neither of with is 0
	return "\xD8" . $str;
    }

    my $u1 = @unique_upper_octet == 1
	? $unique_upper_octet[0] : (grep { $_ ne "\x00" } @unique_upper_octet)[0];
    if ($u1 =~ /^[\xd8-\xdc]{1}$/) {
        Carp::croak(COMPRESS_EXCEPTION);
    }

    my $res = $u1;

    while ($str =~ m/(.)(.)/gs) {
	my ($u2, $n1) = ($1, $2);
	if ($u2 eq "\x00" and $n1 eq "\x99") {
	    Carp::croak(COMPRESS_EXCEPTION);
	} elsif ($u2 eq $u1 and $n1 ne "\xff") {
	    $res .= $n1;
	} elsif ($u2 eq $u1 and $n1 eq "\xff") {
	    $res .= "\xff\x99";
	} else {
	    $res .= "\xff$n1";
	}
    }

    return $res;
}


sub _decompress($) {
    my $str = shift;

    # 1)
    my ($u1, $rest) = (substr($str,0,1), substr($str,1));
    if (length($str) == 1) {
        Carp::croak(DECOMPRESS_EXCEPTION);
    }

    if ($u1 eq "\xd8") {
	# 8)
	my $lcheck = $rest;
	if (length($lcheck) % 2) {
	    Carp::croak(DECOMPRESS_EXCEPTION);
	}
	# 9)
	my @unique_upper_octet = _make_uniq_upper_octet($lcheck);
	if (@unique_upper_octet == 1 ||
	    (@unique_upper_octet == 2 &&
	     grep { $_ eq "\x00" } @unique_upper_octet)) {
	    Carp::croak(DECOMPRESS_EXCEPTION);
	}
	# 10)
	return $lcheck;
    }

    my $buffer = '';
    my $pos = 0;
    # 2)
    while (1) {
	if ($pos == length($rest)) {
	    # 11)
	    if (length($buffer) % 2) {
	        Carp::croak(DECOMPRESS_EXCEPTION);
	    }
	    return $buffer;
	}

	my $n1 = substr($rest, $pos, 1);
	if ($n1 eq "\xff") {
	    # 5)
	    if ($pos == length($rest)-1) {
	      Carp::croak(DECOMPRESS_EXCEPTION);
	    }
	    # 6)
	    $pos++;
	    $n1 = substr($rest, $pos, 1);
	    if ($n1 eq "\x99") {
		$buffer .= $u1 . "\xff";
		next;
	    }
	    # 7)
	    $buffer .= "\x00" . $n1;
	    next;
	} elsif ($u1 eq "\x00" and $n1 eq "\x99") {
	    # 3)
	    Carp::croak(DECOMPRESS_EXCEPTION);
	}
	# 4)
	$buffer .= $u1 . $n1;
	next;
    } continue { $pos++; }
}


sub _make_uniq_upper_octet($) {
    my $str = shift;

    my %seen;
    while ($str =~ m/(.)./gs) {
	$seen{$1}++;
    }
    return keys %seen;
}

sub _include_disallowed_names($) {
    # RFC 1035: letter, digit, hyphen
    return $_[0] !~ /^(?:\x00[\x30-\x39\x41-\x5a\x61-\x7a\x2d])*$/;
}


1;
__END__