File Coverage

lib/Badger/Codec/Unicode.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch	4	6	66.6
condition			n/a
subroutine	10	10	100.0
pod	4	4	100.0
total	46	50	92.0

#========================================================================
#
# Badger::Codec::Unicode
#
# DESCRIPTION
#   Codec module for encoding/decoding Unicode via Encode
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Codec::Unicode;

use 5.008;                      # Unicode not fully supported prior to 5.8
use Badger::Class
    version => 0.01,
    base    => 'Badger::Codec::Encode';

use Encode qw();
use bytes;

# Default encoding
our $ENCODING = 'UTF-8';

# Byte Order Markers for different UTF encodings
our $UTFBOMS = [
    'UTF-8'    => "\x{ef}\x{bb}\x{bf}",
    'UTF-32BE' => "\x{0}\x{0}\x{fe}\x{ff}",
    'UTF-32LE' => "\x{ff}\x{fe}\x{0}\x{0}",
    'UTF-16BE' => "\x{fe}\x{ff}",
    'UTF-16LE' => "\x{ff}\x{fe}",
];

sub encode {
    my ($self, $enc, $data) = @_ == 3 ? @_ : (shift, $ENCODING, shift);
    Encode::encode($enc, $data);
}

sub decode {
    my $self = shift;
    if (@_ >= 2) {
        goto &Encode::decode;       # not a real GOTO - more like a magic
    }                               # subroutine call - see perldoc -f goto
    else {
        my $data  = shift;
        my $count = 0;

        # try all the BOMs in order looking for one (order is important
        # 32bit BOMs look like 16bit BOMs)
        while ($count < @$UTFBOMS) {
            my $enc = $UTFBOMS->[$count++];
            my $bom = $UTFBOMS->[$count++];

            # does the string start with the bom?
            if ($bom eq substr($data, 0, length($bom))) {
                # decode it and hand it back
#                return Encode::decode($enc, $data);
                return Encode::decode($enc, substr($data, length($bom)), 1);
            }
        }
        return $data;
    }
}

sub encoder {
    my $self = shift;
    return sub { $self->encode(@_) };
}

sub decoder {
    my $self = shift;
    return sub { $self->decode(@_) };
}

1;

__END__