File Coverage

lib/Badger/Codecs.pm

Criterion	Covered	Total	%
statement	54	56	96.4
branch	17	22	77.2
condition	2	2	100.0
subroutine	13	15	86.6
pod	9	9	100.0
total	95	104	91.3

#========================================================================
#
# Badger::Codecs
#
# DESCRIPTION
#   Manager of Badger::Codec modules for encoding and decoding data.
#
# AUTHOR
#   Andy Wardley
#
#========================================================================

package Badger::Codecs;

use Carp;
use Badger::Codec::Chain 'CHAIN CHAINED';
use Badger::Factory::Class
    version   => 0.01,
    debug     => 0,
    item      => 'codec',
    path      => 'Badger(X)::Codec',
    import    => 'class CLASS',
    constants => 'HASH ARRAY DELIMITER PKG',
    constant  => {
        CODEC_METHOD  => 'codec',
        ENCODE_METHOD => 'encode',
        DECODE_METHOD => 'decode',
        ENCODING      => 'Badger::Codec::Encoding',
    },
    exports   => {
        any   => 'Codec',
    };

our $CODECS     = {
    # any codecs with non-standard capitalisation can go here, but
    # generally we grok the module name from the $CODEC_PATH, e.g.
    uri      => 'Badger::Codec::URI',
    url      => 'Badger::Codec::URL',
    yaml     => 'Badger::Codec::YAML',
    json     => 'Badger::Codec::JSON',
    html     => 'Badger::Codec::HTML',
    tt       => 'Badger::Codec::TT',
    map {
        my $name = $_; $name =~ s/\W//g;
        $_ => [ENCODING, ENCODING.PKG.$name],
    } qw( utf8 UTF8 UTF16BE UTF16LE UTF32BE UTF32LE )
};


sub Codec {
    CLASS->codec(@_);
}


sub codec {
    my $self = shift->prototype;

    # quick turn-around if we're handling chains
    return $_[0] =~ CHAINED
        ? $self->chain(@_)
        : $self->item(@_);
}


sub chain {
    my $self = shift;
    $self->debug("creating chain for $_[0]\n") if $DEBUG;
    return CHAIN->new(@_);
}


sub found_object {
    my ($self, $name, $item, $args) = @_;

    # TODO: assert $item is a codec object?

    # We cache any codecs that are created without configuration items
    # but we can only use those "bare" codecs if $args is empty.  Otherwise
    # we must create a new object
    if (@$args) {
        $self->debug("creating new ", ref $item, " codec for $name\n") if DEBUG;
        return $self->construct($name, ref $item, $args);
    }
    else {
        $self->debug("re-using cached codec for $name: $item\n") if $DEBUG;
        return $item;
    }
}


sub result {
    my ($self, $name, $codec, $args) = @_;
    # only cache codec objects created with no arguments
    unless (@$args) {
        $self->debug("Caching $name codec for subsequent re-used: $codec") if DEBUG;
        $self->{ codecs }->{ $name } = $codec;
    }
    return $codec;
}


sub encode {
    shift->codec(shift)->encode(@_);
}


sub decode {
    shift->codec(shift)->decode(@_);
}


#-----------------------------------------------------------------------
# export hooks
#-----------------------------------------------------------------------

class->exports(
    hooks => {
        map { ($_ => \&_export_hook) }
        qw( codec codecs )
    }
);


sub _export_hook {
    my ($class, $target, $key, $symbols) = @_;
    croak "You didn't specify a value for the '$key' load option."
        unless @$symbols;
    my $method = "export_$key";
    $class->$method($target, shift @$symbols);
}


sub export_codec {
    my ($class, $target, $name, $alias) = @_;
    my $codec   = $class->codec($name);
    my $cmethod = $alias || CODEC_METHOD;
    my $emethod = $alias ? join('_', ENCODE_METHOD, $alias) : ENCODE_METHOD;
    my $dmethod = $alias ? join('_', DECODE_METHOD, $alias) : DECODE_METHOD;
    no strict 'refs';

    # prefix target class onto above method names
    $_= "${target}::$_" for ($cmethod, $emethod, $dmethod);

    $class->debug("exporting $codec codec to $target\n") if $DEBUG;

    # NOTE: I think it's more correct to attempt the export regardless of
    # any existing sub and allow a redefine warning to be raised.  This is
    # better than silently failing to export the requested items.
    my $temp = $codec; # make sure this is a constant on 5.22
    *{$cmethod} = sub() { $temp };  # unless defined &{$cmethod};
    *{$emethod} = $codec->encoder;  # unless defined &{$emethod};
    *{$dmethod} = $codec->decoder;  # unless defined &{$dmethod};
}


sub export_codecs {
    my ($class, $target, $names) = @_;
    if (ref $names eq HASH) {
        while (my ($key, $value) = each %$names) {
            $class->export_codec($target, $value, $key);
        }
    }
    else {
        $names = [ split(DELIMITER, $names) ] unless ref $names eq ARRAY;
        $class->export_codec($target, $_, $_) for @$names;
    }
}

1;


__END__