File Coverage

blib/lib/Tie/Array/BoundedIndex.pm

Criterion	Covered	Total	%
statement	61	66	92.4
branch	13	20	65.0
condition	8	11	72.7
subroutine	14	16	87.5
pod			n/a
total	96	113	84.9

package Tie::Array::BoundedIndex;
use strict;
use warnings;
use Carp;

use Tie::Array;

our $VERSION = '0.06';

BEGIN
{
  $DB::single = 1;
  eval "require Attribute::Handlers";
  return if $@;
  Attribute::Handlers->import(autotie => { '__CALLER__::Bounded'
					   => __PACKAGE__ });
}

# The underlying object contains the bounds and also an
# inner object that is the result of tying an array to
# Tie::StdArray.  When the user performs an operation on
# the array tied to this class, it is passed on to the
# inner array after bounds checking and shifting the
# indices so that the inner array's indices start at 0
# and go up to -
sub TIEARRAY
{
  my ($class, %arg) = @_;
  my ($upper, $lower) = delete @arg{qw(upper lower)};
  croak "Illegal arguments in tie" if %arg;
  croak "No upper bound for array" unless defined $upper;

  $lower ||= 0;

  /\D/ and croak "Array bound '$_' must be integer" for ($upper, $lower);

  croak "Upper bound < lower bound" if $upper < $lower;

  my @array;
  my $inner = tie @array, 'Tie::StdArray';

  return bless { upper => $upper,
		 lower => $lower,
		 inner => $inner
	       }, $class;
}

# Delegate anything we haven't overridden to the inner array,
# which, being tied to Tie::StdArray, knows what to do.
# In this class we only need to implement methods that have
# to adjust an array index.
sub AUTOLOAD
{
  (my $method = our $AUTOLOAD) =~ s/.*://;
  my $self = shift;
  $self->{inner}->$method(@_);
}

sub DESTROY { }

sub _bound_check
{
  my ($self, $index) = @_;
  my ($upper, $lower) = @{$self}{qw(upper lower)};

  croak "Index $index out of range [$lower, $upper]"
    if $index < $lower || $index > $upper;

  return $lower;    # Convenience for several callers
}

# Only need to implement methods that can increase the
# size of the array or store outside the bounds.

sub STORE
{
  my ($self, $index, $value) = @_;
  my $lower = $self->_bound_check($index);
  $self->{inner}->STORE($index - $lower, $value);
}

sub FETCH
{
  my ($self, $index) = @_;
  my $lower = $self->_bound_check($index);
  $self->{inner}->FETCH($index - $lower);
}

sub STORESIZE
{
  my ($self, $size) = @_;
  $self->_bound_check($size-1);
  $self->{inner}->STORESIZE($size);
}

sub EXTEND
{
  my ($self, $newsize) = @_;

  # We may get called with a new size of 0, indicating that
  # the caller doesn't want to extend the array at all.
  # But since that would result in a bound check on
  #  - 1, we return at that point since otherwise
  # we would generate an exception.  Our arrays are
  # guaranteed to have at least one elenment in them.

  return unless $newsize;
  my $lower = $self->{lower};
  $self->_bound_check($lower+$newsize-1);
}

sub PUSH
{
  my ($self, @new) = @_;
  $self->EXTEND($self->FETCHSIZE + @new);
  $self->{inner}->PUSH(@new);
}

sub UNSHIFT
{
  my ($self, @new) = @_;
  $self->EXTEND($self->FETCHSIZE + @new);
  $self->{inner}->UNSHIFT(@new);
}

sub SPLICE
{
  my $self   = shift;
  my $lower = $self->{lower};

  my $offset = shift;
  defined($offset) or $offset = $lower;

  my $size = $self->FETCHSIZE;

  $offset < 0 and $offset = $size + $lower - $offset;
  $self->_bound_check($offset);

  my $length = shift || $size - $offset + $lower;
  $length < 0 and $length = $lower + $size - $offset + $length;
  $length > $lower + $size - $offset and $length = $lower + $size - $offset;

  $self->EXTEND($size + @_ - $length);
  $self->{inner}->SPLICE($offset - $lower, $length, @_)
}


1;

__END__