File Coverage

blib/lib/Tie/Array/Packed/Auto.pm

Criterion	Covered	Total	%
statement	41	44	93.1
branch	3	4	75.0
condition	1	3	33.3
subroutine	10	11	90.9
pod	0	2	0.0
total	55	64	85.9

package Tie::Array::Packed::Auto;

use strict;
use warnings;
use Carp;

our $VERSION = '0.03';

our $force_pure_perl_backend;

if ($force_pure_perl_backend or
    not eval { require Tie::Array::Packed }) {

    our @ISA = 'Tie::Array::Packed';

    require Tie::Array::PackedC;

    my @short = qw(c C F f d i I i! I! s! S! l! L! n N v V);

    my %map = ( Char => 'c',
                UnsignedChar => 'C',
                NV => 'F',
                Number => 'F',
                FloatNative => 'f',
                DoubleNative => 'd',
                Integer => 'i',
                UnsignedInteger => 'I',
                IntegerNative => 'i!',
                UnsignedIntegerNative => 'I!',
                ShortNative => 's!',
                UnsignedShortNative => 'S!',
                LongNative => 'l!',
                UnsignedLongNative => 'L!',
                UnsignedShortNet => 'n',
                UnsignedShortBE => 'n',
                UnsignedLongNet => 'N',
                UnsignedLongBE => 'N',
                UnsignedShortVax => 'v',
                UnsignedShortLE => 'v',
                UnsignedLongVax => 'V',
                UnsignedLongLE => 'V' );

    @map{@short} = @short;

    for my $name (keys %map) {
        my $type = $map{$name};

        no strict 'refs';
        @{"Tie::Array::Packed::${name}::ISA"} = __PACKAGE__;
        *{"Tie::Array::Packed::${name}::packer"} = sub { $type };
    }

}

my $next_id = 'TieArrayPackedAuto0000';
my %id;
my %class;

our $AUTOLOAD;

sub AUTOLOAD {
    my $self = shift;
    my $class = ref $self || $self;
    $class{$class} and croak qq(Can't locate object method "$AUTOLOAD" via package "$class");
    $class{$class} = 1;
    my $packer = $self->packer;
    unless ($id{$packer}) {
        $next_id++;
        $id{$packer} = $next_id;
        Tie::Array::PackedC->import($id{$packer}, $packer);

        my $parent =  "Tie::Array::PackedC::$id{$packer}";
        no strict 'refs';
        *{$parent.'::_TieArrayPackedAuto_TIEARRAY'} = *{$parent.'::TIEARRAY'};
    }
    no strict 'refs';
    push @{$class.'::ISA'}, "Tie::Array::PackedC::$id{$packer}";
    $self->$AUTOLOAD(@_);
}

sub make {
    my $class = shift;
    tie my(@self), $class, '', @_;
    return \@self
}

sub make_with_packed {
    my $class = shift;
    tie my(@self), $class, @_;
    return \@self
}

sub TIEARRAY {
    # local $_[1] = $_[1];
    # shift->_TieArrayPackedAuto_TIEARRAY(@_);

    my $class = shift;
    my $str = shift;
    $class->_TieArrayPackedAuto_TIEARRAY($str, @_);
}

1;

__END__