File Coverage

blib/lib/Tie/Array/Pack.pm

Criterion	Covered	Total	%
statement	83	93	89.2
branch	26	50	52.0
condition	1	2	50.0
subroutine	19	21	90.4
pod			n/a
total	129	166	77.7

package Tie::Array::Pack;
#
# $Id: Pack.pm,v 0.2 2006/12/22 03:20:22 dankogai Exp $
#
use 5.008001;
use strict;
use warnings;
our $VERSION = sprintf "%d.%02d", q$Revision: 0.2 $ =~ /(\d+)/g;
use Carp;

# we don't need Tie::Array anymore -- all methods implemented!
# use base 'Tie::Array';
use bytes ();

our $DEBUG = 0;

sub DESTROY { }    # no-op

sub TIEARRAY {
    my $class = shift;
    my $fmt   = shift;
    my $empty = shift || 0;
    my $size  = eval { bytes::length( pack( $fmt, $empty ) ) };
    croak $@ if $@;
    bless {
        str   => '',
        fmt   => $fmt,
        size  => $size,
        empty => $empty
    };
}

sub FETCH {
    $DEBUG and warn sprintf "%s->FETCH(%d)", @_;
    unpack( $_[0]->{fmt},
        substr( $_[0]->{str}, $_[0]->{size} * $_[1], $_[0]->{size} ) );
}

sub FETCHSIZE {
    $DEBUG and warn sprintf( "%s->FETCHSIZE", $_[0] );
    use integer;
    bytes::length( $_[0]->{str} ) / $_[0]->{size};
}

sub STORE {
    my ( $this, $index, $value ) = @_;
    $DEBUG and warn "$this->STORE($index, $value)";
    my $retval =
        $this->FETCHSIZE - $index < 1
      ? $this->STORESIZE( $index + 1 )
      : $value;
    substr(
        $this->{str}, $this->{size} * $index,
        $this->{size}, pack( $this->{fmt}, $value )
    );
}

sub STORESIZE {
    my ( $this, $count ) = @_;
    $DEBUG and warn "$this->STORESIZE($count)";
    return $this->EXTEND($count) if $this->FETCHSIZE < $count;
    if ( $this->FETCHSIZE > $count ) {
        substr( $this->{str}, $this->{size} * $count, $this->{size}, '' );
    }
    return $count;
}

sub EXISTS {
    my ( $this, $key ) = @_;
    $DEBUG and warn "$this->EXISTS($key)";
    return $this->FETCHSIZE > $key;
}

sub EXTEND {
    my ( $this, $count ) = @_;
    $DEBUG and warn "$this->EXTEND($count)";
    my $extend = $count - $this->FETCHSIZE;
    if ( $extend > 0 ) {
        $this->{str} .= pack( $this->{fmt}, $this->{empty} ) x $extend;
        $this->STORESIZE($count);
    }
    return undef;
}

sub DELETE {
    my ( $this, $index ) = @_;
    $DEBUG and warn "$this->DELETE($index)";
    substr( $this->{str}, $this->{size} * $index, $this->{size}, '' );
}

sub CLEAR {
    my ( $this, $index ) = @_;
    $DEBUG and warn "$this->CLEAR";
    $this->{str} = '';
}

sub PUSH {    # append
    my $this = shift;
    if ($DEBUG) {
        local ($") = ",";
        warn "$this->PUSH(@_)";
    }
    $this->{str} .= pack( $this->{fmt} x @_, @_ );
}

sub UNSHIFT {    # prepend
    my $this = shift;
    if ($DEBUG) {
        local ($") = ",";
        warn "$this->UNSHIFT(@_)";
    }
    $this->{str} = pack( $this->{fmt} x @_, @_ ) . $this->{str};
}

sub POP {
    my $this = shift;
    $DEBUG and warn "$this->POP";
    my $val;
    my $newsize = $this->FETCHSIZE - 1;
    if ( $newsize >= 0 ) {
        $val = $this->FETCH($newsize);
        $this->STORESIZE($newsize);
    }
    $val;
}

sub SHIFT {
    my $this = shift;
    $DEBUG and warn "$this->SHIFT";
    my $val;
    my $newsize = $this->FETCHSIZE - 1;
    if ( $newsize >= 0 ) {
        $val = $this->FETCH(0);
        $this->DELETE(0);
    }
    $val;
}

sub SPLICE {
    my $this = shift;
    if ($DEBUG) {
        local ($") = ",";
        warn "$this->SPLICE(@_)";
    }
    my $off = (@_) ? shift: 0;
    $off += $this->FETCHSIZE if ( $off < 0 );
    my $len = (@_) ? shift: $this->FETCHSIZE - $off;
    $len += $this->FETCHSIZE - $off if $len < 0;
    my @result = unpack(
        $this->{fmt} . $len,
        substr( $this->{str}, $off * $this->{size}, $len * $this->{size} )
    );
    substr(
        $this->{str},
        $off * $this->{size},
        $len * $this->{size},
        pack( $this->{fmt} x @_, @_ )
    );
    return wantarray ? @result : pop @result;
}

1;
__END__