File Coverage

blib/lib/Tie/Array/Unique.pm

Criterion	Covered	Total	%
statement	65	70	92.8
branch	32	44	72.7
condition	14	15	93.3
subroutine	14	17	82.3
pod	0	1	0.0
total	125	147	85.0

package Tie::Array::Unique;

use constant DIFF => 2;
use Carp;

$VERSION = '0.01';


sub TIEARRAY {
  my $class = shift;
  my $self = bless [ {}, 0 ], $class;

  $self->[1] = shift @_
    if UNIVERSAL::isa($_[0], 'Tie::Array::Unique::How');

  $self->[0]{ $self->[1] ? $self->[1]->($_) : $_ }++ or push @$self, $_
    for @_;

  return $self;
}


sub CLEAR {
  my ($self) = @_;
  splice @$self, 2;
  $self->[0] = {};
}


sub FETCHSIZE {
  my ($self) = @_;
  return @$self - DIFF;
}


sub STORESIZE {
  croak "STORESIZE not implemented on unique arrays";
}


sub EXTEND { }


sub FETCH {
  my ($self, $idx) = @_;
  return $self->[$idx + DIFF];
}


sub STORE {
  my ($self, $idx, $value) = @_;

  # $old is true if this is not a new index to the array
  my $old = $idx < @$self - DIFF;

  # $dup is true if this value will be a duplicate
  my $dup = $self->[0]{ $self->[1] ? $self->[1]->($value) : $value };

  # if we're adding a NEW element and it's a duplicate, don't bother
  return $value if $dup and not $old;

  my $r = \$self->[$idx + DIFF];

  # remove old element
  delete $self->[0]{ $self->[1] ? $self->[1]->($$r) : $$r } if $old;

  $$r = $value;

  # add new one
  $self->[0]{ $self->[1] ? $self->[1]->($$r) : $$r } = 1;

  # if it was a duplicate, get rid of the older value
  if ($dup) {
    for (my $i = 2; $i < @$self; ++$i) {
      if (($self->[1] ? $self->[1]->($self->[$i]) : $self->[$i]) eq ($self->[1] ? $self->[1]->($value) : $value) and $i != DIFF + $idx) {
        splice @$self, $i, 1;
        last;
      }
    }
  }

  return $value;
}


sub PUSH {
  my $self = shift;

  $self->[0]{ $self->[1] ? $self->[1]->($_) : $_ }++ or push @$self, $_ for @_;
  return @$self - DIFF;
}


sub POP {
  my ($self) = @_;
  return if @$self == DIFF;

  # remove element
  delete $self->[0]{ $self->[1] ? $self->[1]->($self->[-1]) : $self->[-1] };
  return pop @$self;
}


sub UNSHIFT {
  my $self = shift;
  $self->[0]{ $self->[1] ? $self->[1]->($_) : $_ }++
    or splice @$self, DIFF, 0, $_ for reverse @_;
  return @$self - DIFF;
}


sub SHIFT {
  my ($self) = @_;
  return if @$self == DIFF;

  # remove element
  delete $self->[0]{ $self->[1] ? $self->[1]->($self->[DIFF]) : $self->[DIFF] };
  return splice @$self, DIFF, 1;
}


sub SPLICE {
  my $self = shift;
  my $idx = DIFF + shift;
  my $len = shift;

  my @removed = defined($len) ?
    splice(@$self, $idx, $len) :
    splice(@$self, $idx);
  delete @{$self->[0]}{map { $self->[1] ? $self->[1]->($_) : $_ } @removed};

  if (@_) {
    my %seen;
    my @replace = grep !$seen{ $self->[1] ? $self->[1]->($_) : $_ }++ && !$self->[0]{ $self->[1] ? $self->[1]->($_) : $_ }, @_;
    splice @$self, $idx, 0, @replace;
    @{$self->[0]}{map { $self->[1] ? $self->[1]->($_) : $_ } @replace} = (1) x @replace;
  }

  return @removed;
}


sub DEFINED {
  my ($self, $idx) = @_;
  return defined $self->[$idx + DIFF];
}


sub EXISTS {
  my ($self, $idx) = @_;
  return exists $self->[$idx + DIFF];
}



package Tie::Array::Unique::How;

sub new {
  my $class = shift;
  Carp::croak("How->new() argument must be code ref")
    unless UNIVERSAL::isa($_[0], "CODE");
  bless $_[0], $class;
}


1;

__END__