Tie::Array::Pack - An array implemented as a packed string

  use Tie::Array::Pack
  tie @array, Tie::Array::Pack => 'd';
  $array[$_] = rand() for (1..1e6); # slow but memory-efficient

   perl Makefile.PL
   make
   make test
   make install

  tie @array, Tie::Array::Pack => $fmt

    c   A signed char value.
    C   An unsigned char value.
    s   A signed short value.
    S   An unsigned short value.
    i   A signed integer value.
    I   An unsigned integer value.
    l   A signed long value.
    L   An unsigned long value.
    n   An unsigned short in "network" (big-endian) order.
    N   An unsigned long in "network" (big-endian) order.
    v   An unsigned short in "VAX" (little-endian) order.
    V   An unsigned long in "VAX" (little-endian) order.
    q   A signed quad (64-bit) value.
    Q   An unsigned quad value.
    j   A signed integer value (a Perl internal integer, IV).
    J   An unsigned integer value (a Perl internal unsigned integer, UV).
    f   A single-precision float in the native format.
    d   A double-precision float in the native format.
    F   A floating point value in the native native format
    D   A long double-precision float in the native format.

  tie @array, Tie::Array::Pack => l, -1; # -1 represents an empty value;

  tie @array, Tie::Array::Pack => d;
  $array[4] = 2;
  print join(",", @array), "\n" # 0,0,0,0,2;

  tie @array, Tie::Array::Pack => C;
  @array = (251..260);
  print join(",", @array), "\n" # 251,252,253,254,255,0,1,2,3,4

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__