File Coverage

blib/lib/Set/Array.pm

Criterion	Covered	Total	%
statement	258	644	40.0
branch	107	402	26.6
condition	16	72	22.2
subroutine	37	58	63.7
pod	34	38	89.4
total	452	1214	37.2

package Set::Array;

use strict;
use attributes qw(reftype);
use subs qw(foreach pack push pop shift join rindex splice unpack unshift);

use Want;
use Carp;
use Try::Tiny;

# Some not documented/implemented.  Waiting for Want-0.06 to arrive.
use overload
   "=="  => "is_equal",
   "!="  => "not_equal",
   "+"   => "union",
   "&"   => "bag",
   "*"   => "intersection",
   "-"   => "difference",
   "%"   => "symmetric_difference",
   "<<"  => "push",
   ">>"  => "shift",
   "<<=" => "unshift",
   ">>=" => "pop",
   "fallback" => 1;

our $VERSION = '0.30';

sub new{
   my($class,@array) = @_;
   @array = @$class if !@array && ref($class);
   return bless \@array, ref($class) || $class;
}

# Turn array into a hash
sub as_hash{
   my($self,$order,@arg) = @_;

   if (! defined $order) {
      $order = 'even';
   }
   elsif (ref $order eq 'HASH') {
      $order = $$order{'key_option'};
   }
   elsif ($order eq 'key_option') {
      $order = $arg[0];
   }

   $order = lc $order;

   if ($order =~ /^(?:odd|even)$/) {
   }
   else {
      Carp::croak "Unrecognized option ($order) passed to 'as_hash()' method";
   }

   my %hash;

   if($order eq 'odd') {
      %hash = CORE::reverse(@$self);
   }
   else {
      %hash = @$self;
   }

   if(want('OBJECT')){ return $self } # This shouldn't happen

   return %hash if wantarray;
   return \%hash;
}
*to_hash = \&as_hash;

# Return element at specified index
sub at{
   my($self,$index) = @_;
   if(want('OBJECT')){ return bless \${$self}[$index] }
   return @$self[$index];
}

# Delete (or undef) contents of array
sub clear{
   my($self,$undef) = @_;
   if($undef){ @{$self} = map{ undef } @{$self} }
   else{ @{$self} = () }

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@{$self} }
}

# Remove all undef elements. It can be chained.

sub compact{
   my($self) = @_;

   if( (want('OBJECT')) || (!defined wantarray) ){
      @$self = grep defined $_, @$self;
      return $self;
   }

   my @temp;
   CORE::foreach(@{$self}){ CORE::push(@temp,$_) if defined $_ }
   if(wantarray){ return @temp }
   if(defined wantarray){ return \@temp }
}

# Return the number of times the specified value appears within array
sub count{
   my($self,$val) = @_;

   my $hits = 0;

   # Count undefined elements
   unless(defined($val)){
      foreach(@$self){ $hits++ unless $_ }
      if(want('OBJECT')){ return bless \$hits }
      return $hits;
   }

   $hits = grep /^\Q$val\E$/, @$self;
   if(want('OBJECT')){ return bless \$hits }
   return $hits;
}

# Pops and returns /the object/. I.e it can be chained.

sub cpop{
   my($self) = @_;
   my $popped = CORE::pop(@$self);
   return $self;
}

# Shifts and returns /the object/. I.e it can be chained.

sub cshift{
   my($self) = @_;
   my $shifted = CORE::shift @$self;
   return $self;
}

# Delete all instances of the specified value within the array. It can be chained.

sub delete{
   my($self,@vals) = @_;

   unless(defined($vals[0])){
      Carp::croak "Undefined value passed to 'delete()' method";
   }

   foreach my $val(@vals){
      @$self = grep $_ !~ /^\Q$val\E$/, @$self;
   }

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@$self }
}

# Deletes an element at a specified index, or range of indices
# I'm not sure I like the range behavior for this method and may change it
# (or remove it) in the future.
sub delete_at{
   my($self,$start_index, $end_index) = @_;

   unless(defined($start_index)){
      Carp::croak "No index passed to 'delete_at()' method";
   }

   unless(defined($end_index)){ $end_index = 0 }
   if( ($end_index eq 'end') || ($end_index == -1) ){ $end_index = $#$self }

   my $num = ($end_index - $start_index) + 1;

   CORE::splice(@{$self},$start_index,$num);

   if(want('OBJECT') || !(defined wantarray)){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@{$self} }
}

# Returns a list of duplicate items in the array. It can be chained.

sub duplicates{
   my($self) = @_;

   my(@dups,%count);

   CORE::foreach(@$self){
      $count{$_}++;
      if($count{$_} > 1){ CORE::push(@dups,$_) }
   }

   if(want('OBJECT') || !(defined wantarray)){
      @$self = @dups;
      return $self;
   }

   if(wantarray){ return @dups }
   if(defined wantarray){ return \@dups }
}

# Tests to see if value exists anywhere within array
sub exists{
   my($self,$val) = @_;

   # Check specifically for undefined values
   unless(defined($val)){
      foreach(@$self){ unless($_){ return 1 } }
      return 0;
   }

   if(grep /^\Q$val\E$/, @$self){ return 1 }

   return 0;
}

*contains = \&exists;

# Fills the elements of the array.  Does not create new elements
sub fill{
   my($self,$val, $start, $length) = @_;  # Start may also be a range
   return unless(scalar(@{$self}) > 0);   # Test for empty array

   unless(defined($start)){ $start = 0 }

   if($length){ $length += $start }
   else{ $length = $#$self + 1}

   if($start =~ /^(\d+)\.\.(\d+)$/){
      CORE::foreach($1..$2){ @{$self}[$_] = $val }
      return $self;
   }

   CORE::foreach(my $n=$start; $n<$length; $n++){ @{$self}[$n] = $val }

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@{$self} }
}

# Returns the first element of the array
sub first{
   my($self) = @_;
   if(want('OBJECT')){ return bless \@{$self}[0] }
   return @{$self}[0];
}

# Flattens any list references into a plain list
sub flatten{
   my($self) = @_;

   if( (want('OBJECT')) || (!defined wantarray) ){
      for(my $n=0; $n<=$#$self; $n++){
   if( ref($$self[$n]) eq 'ARRAY' ){
        CORE::splice(@$self,$n,1,@{$$self[$n]});
        $n--;
        next;
   }
         if( ref($$self[$n]) eq 'HASH' ){
            CORE::splice(@$self,$n,1,%{$$self[$n]});
            --$n;
            next;
         }
      }
      return $self
   }

   my @temp = @$self;
   for(my $n=0; $n<=$#temp; $n++){
      if( ref($temp[$n]) eq 'ARRAY' ){
         CORE::splice(@temp,$n,1,@{$temp[$n]});
         $n--;
         next;
      }
      if( ref($temp[$n]) eq 'HASH' ){
         CORE::splice(@temp,$n,1,%{$temp[$n]});
         --$n;
         next;
      }
   }
   if(wantarray){ return @temp }
   if(defined wantarray){ return \@temp }
}

# Loop mechanism
sub foreach{
   my($self,$coderef) = @_;

   unless(ref($coderef) eq 'CODE'){
      Carp::croak "Invalid code reference passed to 'foreach' method";
   }

   CORE::foreach (@$self){ &$coderef }

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@{$self} }
}

# Append or prepend a string to each element of the array
sub impose{
   my($self,$placement,$string) = @_;

   # Set defaults
   unless($placement =~ /\bappend\b|\bprepend\b/i){
      $string = $placement;
      $placement = 'append';
   }

   unless(CORE::defined($string)){
      Carp::croak "No string supplied to 'impose()' method";
   }

   if(want('OBJECT') or !(defined wantarray)){
      if($placement =~ /append/){ foreach(@$self){ $_ = $_ . $string } }
      if($placement =~ /prepend/){ foreach(@$self){ $_ = $string . $_ } }
      return $self;
   }

   my @copy = @$self;
   if($placement =~ /append/){ foreach(@copy){ $_ = $_ . $string } }
   if($placement =~ /prepend/){ foreach(@copy){ $_ = $string . $_ } }

   if(wantarray){ return @copy }
   if(defined wantarray){ return \@copy }
}

# Returns the index of the first occurrence within the array
# of the specified value
sub index{
   my($self,$val) = @_;

   # Test for undefined value
   unless(defined($val)){
      for(my $n=0; $n<=$#$self; $n++){
         unless($self->[$n]){
            if(want('OBJECT')){ return bless \$n }
            if(defined wantarray){ return $n }
         }
      }
   }

   for(my $n=0; $n<=$#$self; $n++){
      next unless defined $self->[$n];
      if( $self->[$n] =~ /^\Q$val\E$/ ){
         if(want('OBJECT')){ return bless \$n }
         if(defined wantarray){ return $n }
      }
   }
   return undef;
}

# Given an index, or range of indices, returns the value at that index
# (or a list of values for a range).
sub indices{
   my($self,@indices) = @_;
   my @iArray;

   unless(defined($indices[0])){
      Carp::croak "No index/indices passed to 'indices' (aka 'get') method";
   }

   CORE::foreach(@indices){
      if($_ =~ /(\d+)\.\.(\d+)/){ for($1..$2){
         CORE::push(@iArray,@{$self}[$_]) };
         next;
      }
      if(@{$self}[$_]){ CORE::push(@iArray,@{$self}[$_]) }
      else{ CORE::push(@iArray,undef) }
   }

   if(scalar(@iArray) == 1){
      if(want('OBJECT')){ return bless \$iArray[0] }
      return $iArray[0];
   }

   if(want('OBJECT')){ return bless \@iArray }
   if(wantarray){ return @iArray }
   if(defined wantarray){ return \@iArray }
}

# Alias for 'indices()'
*get = \&indices;

# Tests to see if array contains any elements
sub is_empty{
   my($self) = @_;
   if( (scalar @{$self}) > 0){ return 0 }
   return 1;
}

# Set a specific index to a specific value
sub set{
   my($self,$index,$val) = @_;

   unless(defined($index) && $val){
      Carp::croak "No index or value passed to 'set()' method";
   }

   if(want('OBJECT')){
      $self->[$index] = $val;
      return $self;
   }

   my @copy = @$self;
   $copy[$index] = $val;

   if(wantarray){ return @copy }
   if(defined wantarray){ return \@copy }
}

# Joins the contents of the list with the specified string
sub join{
   my($self,$s) = @_;

   $s = ',' unless $s;

   my $string;

   if(want('OBJECT')){
      $string = CORE::join($s,@$self);
      return bless \$string;
   }

   $string = CORE::join($s,@$self);
   return $string;
}

# Returns the last element of the array
sub last{
   my($self) = @_;
   if(want('OBJECT')){ return bless \@{$self}[-1] }
   return @$self[-1];
}

# Returns the number of elements within the array
sub length{
   my($self) = @_;
   my $length = scalar(@$self);
   if(want('OBJECT')){ return bless \$length }
   return $length;
}

# Returns the maximum numerical value in the array
sub max{
   my($self) = @_;
   my $max;

   no warnings 'uninitialized';
   CORE::foreach(@{$self}){ $max = $_ if $_ > $max }

   if(want('OBJECT')){ return bless \$max }
   return $max;
}

sub pack{
   my($self,$template) = @_;

   Carp::croak "No template provided to 'pack()' method" unless $template;

   if(want('OBJECT') || !(defined wantarray)){
      $self->[0] = CORE::pack($template, @$self);
      $#$self = 0;
      return $self;
   }

   return CORE::pack($template,@$self);
}

# Pops and returns the last element off the array
sub pop{
   my($self) = @_;
   my $popped = CORE::pop(@$self);
   if(want('OBJECT')){ return bless \$popped }
   return $popped;
}

# Prints the contents of the array as a flat list. Optional newline
sub print{
   my($self,$nl) = @_;

   if(reftype($self) eq 'ARRAY'){
      if(wantarray){ return @$self }
      if(defined wantarray){ return \@{$self} }
      CORE::print @$self;
      if($nl){ CORE::print "\n" }
   }
   elsif(reftype($self) eq 'SCALAR'){
      if(defined wantarray){ return $$self }
      CORE::print $$self;
      if($nl){ CORE::print "\n" }
   }
   else{
      CORE::print @$self;
      if($nl){ CORE::print "\n" }
   }
   return $self;
}

# Pushes an element onto the end of the array
sub push{
   my($self,@list) = @_;

   CORE::push(@{$self},@list);

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@{$self} };
}

# Randomizes the order of the contents of the array
# Taken from "The Perl Cookbook"
sub randomize{
   my($self) = @_;
   my($i,$ref,@temp);

   unless( (want('OBJECT')) || (!defined wantarray) ){
      @temp = @{$self};
      $ref = \@temp;
   }
   else{ $ref = $self }

   for($i = @$ref; --$i; ){
      my $j = int rand ($i+1);
      next if $i == $j;
      @$ref[$i,$j] = @$ref[$j,$i];
   }

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @temp }
   if(defined wantarray){ return \@temp }
}

# Reverses the contents of the array
sub reverse{
   my($self) = @_;

   if( (want('OBJECT')) || (!defined wantarray) ){
      @$self = CORE::reverse @$self;
      return $self;
   }

   my @temp = CORE::reverse @$self;
   if(wantarray){ return @temp }
   if(defined wantarray){ return \@temp }
}

# Same as index, except that it returns the position of the
# last occurrence, instead of the first.
sub rindex{
   my($self,$val) = @_;

   # Test for undefined value
   unless(defined($val)){
      for(my $n = $#$self; $n >= 0; $n--){
         unless($self->[$n]){
            if(want('OBJECT')){ return bless \$n }
            if(defined wantarray){ return $n }
         }
      }
   }

   for(my $n = $#$self; $n >= 0; $n--){
      next unless defined $self->[$n];
      if( $self->[$n] =~ /^\Q$val\E$/ ){
         if(want('OBJECT')){ return bless \$n }
         if(defined wantarray){ return $n }
      }
   }
   return undef;

}

# Moves the last element of the array to the front, or vice-versa
sub rotate{
   my($self,$dir) = @_;

   if( (want('OBJECT')) || (!defined wantarray) ){
      unless(defined($dir) && $dir eq 'ftol'){
         CORE::unshift(@$self, CORE::pop(@$self));
         return $self;
      }
      CORE::push(@$self,CORE::shift(@$self));
      return $self;
   }

   my @temp = @$self;
   unless(defined($dir) && $dir eq 'ftol'){
      CORE::unshift(@temp, CORE::pop(@temp));
      if(wantarray){ return @temp }
      if(defined wantarray){ return \@temp }
   }
   CORE::push(@temp,CORE::shift(@temp));
   if(wantarray){ return @temp }
   if(defined wantarray){ return \@temp }
}

# Shifts and returns the first element off the array
sub shift{
   my($self) = @_;
   my $shifted = CORE::shift @$self;
   if(want('OBJECT')){ return bless \$shifted }
   return $shifted;
}

# Sorts the array alphabetically.
sub sort{
   my($self,$coderef) = @_;

   if($coderef){

      # Complements of Sean McAfee
      my $caller = caller();
      local(*a,*b) = do{
         no strict 'refs';
         (*{"${caller}::a"},*{"${caller}::b"});
      };

      if( (want('OBJECT')) || (!defined wantarray) ){
         @$self = CORE::sort $coderef @$self;
         return $self;
      }

      my @sorted = CORE::sort $coderef @$self;
      if(wantarray){ return @sorted }
      if(defined wantarray){ return \@sorted }
   }
   else{
      if( (want('OBJECT')) || (!defined wantarray) ){
         @$self = CORE::sort @$self;
         return $self;
      }
      my @sorted = CORE::sort @$self;
      if(wantarray){ return @sorted }
      if(defined wantarray){ return \@sorted }
   }
}

# Splices a value, or range of values, from the array
sub splice{
   my($self,$offset,$length,@list) = @_;

   no warnings 'uninitialized';

   my @deleted;
   unless(defined($offset)){
      @deleted = CORE::splice(@$self);
      if(want('OBJECT')){ return $self }
      if(wantarray){ return @deleted }
      if(defined wantarray){ return \@deleted }
   }
   unless(defined($length)){
      @deleted = CORE::splice(@$self,$offset);
      if(want('OBJECT')){ return $self }
      if(wantarray){ return @deleted }
      if(defined wantarray){ return \@deleted }
   }
   unless(defined($list[0])){
      @deleted = CORE::splice(@$self,$offset,$length);
      if(want('OBJECT')){ return $self }
      if(wantarray){ return @deleted }
      if(defined wantarray){ return \@deleted }
   }

   @deleted = CORE::splice(@$self,$offset,$length,@list);
   if(want('OBJECT')){ return $self }
   if(wantarray){ return @deleted }
   if(defined wantarray){ return \@deleted }
}

# Returns a list of unique items in the array. It can be chained.

sub unique{
   my($self) = @_;

   my %item;

   CORE::foreach(@$self){ $item{$_}++ }

   if(want('OBJECT') || !(defined wantarray)){
      @$self = keys %item;
      return $self;
   }

   my @temp = keys %item;

   if(wantarray){ return @temp }
   if(defined wantarray){ return \@temp }
}

# Unshifts a value to the front of the array
sub unshift{
   my($self,@list) = @_;
   CORE::unshift(@$self,@list);

   if(want('OBJECT')){ return $self }
   if(wantarray){ return @$self }
   if(defined wantarray){ return \@{$self} };
}

#### OVERLOADED OPERATOR METHODS ####

# Really just a 'push', but needs to handle ops
sub append{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   CORE::push(@{$op1},@{$op2});

   if(want('OBJECT')){ return $op1 }
   return @$op1 if wantarray;
   return \@{$op1} if defined wantarray;
}

# A union that includes non-unique values (i.e. everything)
sub bag{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   if(want('OBJECT') || !(defined wantarray)){
      CORE::push(@$op1,@$op2);
      return $op1;
   }
   my @copy = (@$op1,@$op2);
   return @copy if wantarray;
   return \@copy if defined wantarray;
}

# Needs work
sub complement{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   my(%item1,%item2,@comp);
   CORE::foreach(@$op1){ $item1{$_}++ }
   CORE::foreach(@$op2){ $item2{$_}++ }

   CORE::foreach(keys %item2){
      if($item1{$_}){ next }
      CORE::push(@comp,$_);
   }

   if(want('OBJECT')){ return bless \@comp }
   if(wantarray){ return @comp }
   if(defined wantarray){ return \@comp }
}

# Returns elements in left set that are not in the right set
sub difference{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   my(%item1,%item2,@diff);
   CORE::foreach(@$op1){ $item1{$_}=$_ }
   CORE::foreach(@$op2){ $item2{$_}=$_ }

   CORE::foreach(keys %item1){
      if(exists $item2{$_}){ next }
      CORE::push(@diff,$item1{$_});
   }

   try
   {
	   if (want('OBJECT') || ! defined wantarray)
	   {
		   @$op1 = @diff;
		   return $op1;
	   }
   };

   if(wantarray){ return @diff }
   if(defined wantarray){ return \@diff }
}

# Returns the elements common to both arrays
sub intersection{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;
   my($result) = [];

   my($i1, $i2);
   my(%seen);

   CORE::foreach $i1 (0 .. $#$op1){
      CORE::foreach $i2 (0 .. $#$op2){
         # If we have matched this value in @$op2 before,
         # do not match it in the same place again in @$op1.

         next if (defined $seen{$$op2[$i2]} && ($seen{$$op2[$i2]} eq $i1) );

         if ($$op1[$i1] eq $$op2[$i2]){
            CORE::push @$result, $$op1[$i1];

            $seen{$$op2[$i2]} = $i1;
         }
      }
   }

   if(want('OBJECT') || !(defined wantarray)){
      return $result;
   }

   if(wantarray){ return @$result }
   if(defined wantarray){ return $result }
}

# Tests to see if arrays are equal (regardless of order)
sub is_equal{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   my(%count1, %count2);

   if(scalar(@$op1) != scalar(@$op2)){ return 0 }

   CORE::foreach(@$op1){ $count1{$_}++ }
   CORE::foreach(@$op2){ $count2{$_}++ }

   CORE::foreach my $key(keys %count1){
      return 0 unless CORE::defined($count1{$key});
      return 0 unless CORE::defined($count2{$key});
      if($count1{$key} ne $count2{$key}){ return 0 }
   }
   return 1;
}

# Tests to see if arrays are not equal (order ignored)
sub not_equal{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   my(%count1, %count2);

   if(scalar(@$op1) != scalar(@$op2)){ return 1 }

   CORE::foreach(@$op1){ $count1{$_}++ }
   CORE::foreach(@$op2){ $count2{$_}++ }

   CORE::foreach my $key(keys %count1){
      return 1 unless CORE::defined($count1{$key});
      return 1 unless CORE::defined($count2{$key});
      if($count1{$key} ne $count2{$key}){ return 1 }
   }
   return 0;
}

# Returns elements in one set or the other, but not both
sub symmetric_difference{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   my(%count1,%count2,%count3,@symdiff);
   @count1{@$op1} = (1) x @$op1;
   @count2{@$op2} = (1) x @$op2;

   CORE::foreach(CORE::keys %count1,CORE::keys %count2){ $count3{$_}++ }

   if(want('OBJECT') || !(defined wantarray)){
      @$op1 = CORE::grep{$count3{$_} == 1} CORE::keys %count3;
      return $op1;
   }

   @symdiff = CORE::grep{$count3{$_} == 1} CORE::keys %count3;
   if(wantarray){ return @symdiff }
   if(defined wantarray){ return \@symdiff }
}

*sym_diff = \&symmetric_difference;

# Returns the union of two arrays, non-unique values excluded
sub union{
   my($op1, $op2, $reversed) = @_;
   ($op2,$op1) = ($op1,$op2) if $reversed;

   my %union;
   CORE::foreach(@$op1, @$op2){ $union{$_}++ }

   if(want('OBJECT') || !(defined wantarray)){
      @$op1 = CORE::keys %union;
      return $op1;
   }

   my @union = CORE::keys %union;

   if(wantarray){ return @union }
   if(defined wantarray){ return \@union }
}
1;
__END__