File Coverage

lib/Badger/Codec/Encoding.pm

Criterion	Covered	Total	%
statement	23	23	100.0
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod	4	4	100.0
total	36	36	100.0

#========================================================================
#
# Badger::Codec::Encoding
#
# DESCRIPTION
#   A codec wrapper for Encode that binds a specific encoding with it.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Codec::Encoding;

use Badger::Class
    version   => 0.01,
    debug     => 0,
    base      => 'Badger::Codec',
    import    => 'class',
    constants => 'PKG',
    constant  => {
        encoding => 'ASCII',
    };

use Encode qw();
use bytes;

sub encode {
    # replace $self with $self->encoding
    unshift(@_, shift->encoding);
    # you don't need to turn away, this isn't your average GOTO - it's a
    # special kind of subroutine call that Larry called goto for a laugh
    goto &Encode::encode;
}

sub decode {
    # as above: monkey with the args so the goto works as expected
    unshift(@_, shift->encoding);
    goto &Encode::decode;
}

sub encoder {
    my $self = shift;
    my $enc  = $self->encoding;
    return sub {
        unshift(@_, $enc);
        goto &Encode::encode
    };
}

sub decoder {
    my $self = shift;
    my $enc  = $self->encoding;
    return sub {
        unshift(@_, $enc);
        goto &Encode::decode
    };
}


#-----------------------------------------------------------------------
# generate subclasses for various UTF encodings
#-----------------------------------------------------------------------

my $base = __PACKAGE__;
my @encs = qw( utf8 UTF-8 UTF-16BE UTF-16LE UTF-32BE UTF-32LE );

for my $enc (@encs) {
    my $name = $enc;
    $name =~ s/\W//g;

    # fetch a Badger::Class object for the subclass so we can define
    # a base class and set the constant encoding() method
    my $subclass = class($base.PKG.$name);
    $subclass->base($base);
    $subclass->constant( encoding => $enc );

    $base->debug("$name => $enc => ", $subclass->name->encoding, "\n") if $DEBUG;
}
1;


__END__