File Coverage

blib/lib/Tie/IntegerArray.pm

Criterion	Covered	Total	%
statement	103	107	96.2
branch	39	60	65.0
condition	5	6	83.3
subroutine	15	15	100.0
pod			n/a
total	162	188	86.1

package Tie::IntegerArray;

require 5.6.0;

use strict;
use warnings;
use integer;

our $VERSION = '0.01';

use base 'Tie::Array';

use Bit::Vector;
use Carp qw(croak);

sub TIEARRAY {
  my $pkg = shift;
  my $self = {};

  croak("Tie::IntegerArray : bad call to tie - options must be specifyed as key-value pairs.")
    if (@_ % 2);
  %$self = @_;

  # setup defaults
  $self->{size} = 1 unless exists $self->{size};
  $self->{undef} = 0 unless exists $self->{undef};
  $self->{signed} = 1 unless exists $self->{signed};
  $self->{bits} = Bit::Vector->Word_Bits() unless exists $self->{bits};
  $self->{trace} = 0 unless exists $self->{trace};

  # calculate range
  if ($self->{signed}) {
    $self->{min} = ((2 ** ($self->{bits} - 2)) * -1);
    $self->{max} = ($self->{min} * -1) - 1;
  } else {
    $self->{min} = 0;
    $self->{max} = 2 ** $self->{bits};
  }

  # create value vector
  $self->{vec} = Bit::Vector->new($self->{bits} * $self->{size});
  croak("Tie::IntegerArray : unable to create internal Bit::Vector object")
    unless defined $self->{vec};

  # create defined vector
  if ($self->{undef}) {
    $self->{dvec} =  Bit::Vector->new($self->{size});
    croak("Tie::IntegerArray : unable to create internal defined Bit::Vector object")
      unless defined $self->{dvec};
  }

  # create scratch vector for working with individual values
  $self->{svec} = Bit::Vector->new($self->{bits});
  croak("Tie::IntegerArray : unable to create internal scratch Bit::Vector object")
    unless defined $self->{svec};

  return bless($self, $pkg);
}

sub FETCH {
  my $self = shift;
  my $vec = $self->{vec};
  my $svec = $self->{svec};
  my $dvec = $self->{dvec};
  my $index = shift;

  print STDERR "FETCH($index) called.\n" if $self->{trace};

  # get bit_index for this value
  my $bit_index = $index * $self->{bits};

  # extend if necessary
  $self->STORESIZE($index + 1)
    if ($vec->Size() <= $bit_index);

  # check for undef in dvec
  return undef if $self->{undef} and not $dvec->bit_test($index);

  # copy into svec and return to_Bin
  $svec->Interval_Copy($vec,0,$bit_index,$svec->Size());
  return $svec->to_Dec();
}

sub STORESIZE {
  my $self = shift;
  my $vec = $self->{vec};
  my $dvec = $self->{dvec};
  my $index = shift;

  print STDERR "STORESIZE($index) called.\n" if $self->{trace};

  $vec->Resize($index * $self->{bits});
  $dvec->Resize($index) if $self->{undef};
}
sub EXTEND { goto &STORESIZE; }

sub CLEAR {
  my $self = shift;
  my $vec = $self->{vec};
  my $dvec = $self->{dvec};

  print STDERR "CLEAR() called.\n" if $self->{trace};

  $vec->Resize(0);
  $dvec->Resize(0) if $self->{undef};
}

sub FETCHSIZE {
  my $self = shift;
  my $vec = $self->{vec};

  print STDERR "FETCHSIZE() called.\n" if $self->{trace};

  return $vec->Size() / $self->{bits};
}

sub STORE {
  my $self = shift;
  my $vec = $self->{vec};
  my $svec = $self->{svec};
  my $dvec = $self->{dvec};
  my $index = shift;
  my $value = shift;

  print STDERR "STORE($index, $value) called.\n" if $self->{trace};

  # get bit_index for this value
  my $bit_index = $index * $self->{bits};

  # extend if necessary
  if ($vec->Size() <= $bit_index) {
    $vec->Resize(($index + 1) * $self->{bits});
    $dvec->Resize($index + 1) if $self->{undef};
  }

  # set undef appropriately if required
  if ($self->{undef}) {
    if (defined $value) {
      $dvec->Bit_On($index);
    } else {
      $dvec->Bit_Off($index);
      return undef; # all done if set to undef now
    }
  }

  croak("Tie::IntegerArray : cannot store non-integer value '$value'!")
    unless $value =~ /^-?\d+$/;

  croak("Tie::IntegerArray : Unable to store value '$value' - out of range ($self->{min} - $self->{max})")
    if $value < $self->{min} or $value > $self->{max};

  # store the number in svec and then copy into place
  $svec->from_Dec($value);
  $vec->Interval_Substitute($svec,$bit_index,$self->{bits},0,$self->{bits});

  return $value;
}

sub EXISTS {
  my $self = shift;
  my $vec = $self->{vec};
  my $index = shift;

  print STDERR "EXISTS($index) called.\n" if $self->{trace};

  # get bit_index for this value
  my $bit_index = $index * $self->{bits};

  # does this slot exist?
  return ($bit_index < $vec->Size());
}

sub DELETE {
  my $self = shift;
  my $vec = $self->{vec};
  my $dvec = $self->{dvec};
  my $svec = $self->{svec};
  my $index = shift;

  print STDERR "DELETE($index) called.\n" if $self->{trace};

  # get bit_index for this value
  my $bit_index = $index * $self->{bits};

  # extend if necessary
  return undef if $bit_index >= $vec->Size();

  $vec->Interval_Empty($bit_index,$bit_index + $self->{bits} - 1);
  $dvec->Bit_Off($index) if $self->{undef};
  return 1;
}

1;
__END__