File Coverage

blib/lib/Tie/Array/Packed.pm

Criterion	Covered	Total	%
statement	24	59	40.6
branch	2	22	9.0
condition	0	3	0.0
subroutine	7	13	53.8
pod	6	7	85.7
total	39	104	37.5

package Tie::Array::Packed;

our $VERSION = '0.13';

use strict;
use warnings;
use Carp;

require XSLoader;
XSLoader::load('Tie::Array::Packed', $VERSION);

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

my %map = ( Char => 'c',
            UnsignedChar => 'C',
            Hex => 'h',
            NV => 'F',
            Number => 'F',
            FloatNative => 'f',
            DoubleNative => 'd',
            Integer => 'j',
            UnsignedInteger => 'J',
            IntegerPerl => 'j',
            IV => 'j',
            UnsignedIntegerPerl => 'J',
            UV => 'J',
            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',
            Quad => 'q',
            UnsignedQuad => 'Q',
            LongLong => 'q',
            UnsignedLongLong => 'Q',
            Int64 => 'q',
            UInt64 => 'Q',
            Int128 => 'e',
            UInt128 => 'E',
          );


@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}::TIEARRAY"} =
        sub {
            my $class = shift;
            my $self;
            $self = TIEARRAY($class, $type, defined $_[0] ? $_[0] : '');
            if (@_ > 1) {
                shift;
                $self->SPLICE(0, scalar(@_), @_);
            }
            $self;
        };
}

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 make_clone {
    my $self = shift;
    tie my(@clone), ref($self), $$self;
    return \@clone;
}

sub string {
    my $self = shift;
    $$self;
}

my $sort_packed_loaded;

sub _load_sort_packed {
    eval { require Sort::Packed };
    croak __PACKAGE__ ."::sort requires package Sort::Packed"
        if ($@ or !$Sort::Packed::VERSION);
    $sort_packed_loaded++
}

sub sort {
    @_ > 2 and croak 'Usage: tied(@parray)->sort([sub { CMP($a, $b) }])';
    $sort_packed_loaded or _load_sort_packed;

    my $self = shift;
    my $packer = $self->packer;
    if (@_) {
        my $cmp = shift;
        &Sort::Packed::sort_packed_custom($cmp, $packer, $$self);
    }
    else {
        &Sort::Packed::sort_packed($packer, $$self);
    }
}


sub shuffle {
    @_ != 1 and croak 'Usage: tied(@parray)->shuffle';
    $sort_packed_loaded or _load_sort_packed;

    my $self = shift;
    Sort::Packed::shuffle_packed($self->packer, $$self)
}

sub grep {
    @_ != 2 and croak 'Usage: tied(@parray)->grep(sub { SELECT($_) })';

    my $self = shift;
    my $select = shift;

    my $last = $self->FETCHSIZE - 1;
    my $slow = 0;
    for my $i (0..$last) {
        for ($self->FETCH($i)) {
            my $cp = $_;
            if (&$select) {
                $self->STORE($slow, $cp) if $slow < $i;
                $slow++
            }
        }
    }
    $self->STORESIZE($slow);
    $slow;
}

1;
__END__