File Coverage

blib/lib/Array/Each.pm

Criterion	Covered	Total	%
statement	186	186	100.0
branch	56	56	100.0
condition	35	36	97.2
subroutine	41	41	100.0
pod	20	25	80.0
total	338	344	98.2

package Array::Each;
$VERSION = 0.03;
use strict;
use warnings;

=head1 NAME

Array::Each - iterate over one or more arrays, returning one or more
elements from each array followed by the array index.

=head1 VERSION

This document refers to version 0.03 of Array::Each,
released March 26, 2004.

=head1 SYNOPSIS

 use Array::Each;

 # one array
 my @x = qw( a b c d e );

 my $one = Array::Each->new( \@x );
 while( my( $x, $i ) = $one->each() ) {
     printf "%3d: %s\n", $i, $x;
 }

 # multiple arrays
 my @y = ( 1,2,3,4,5 );

 my $set = Array::Each->new( \@x, \@y );
 while( my( $x, $y, $i ) = $set->each() ) {
     printf "%3d: %s %s\n", $i, $x, $y;
 }

 # groups of elements (note set=> parm syntax)
 my @z = ( a=>1, b=>2, c=>3, d=>4, e=>5 );

 my $hash_like = Array::Each->new( set=>[\@z], group=>2 );
 while( my( $key, $val ) = $hash_like->each() ) {
     printf "%s => %s\n", $key, $val;
 }

=cut

### more POD follows the __END__

use Carp;

# object attributes subscript mappings
use constant EACH     => 0; # sub ref to object's each()
use constant SET      => 1; # ref to array of array_refs
use constant ITERATOR => 2; # integer, used as array index
use constant REWIND   => 3; # integer, used as array index
use constant BOUND    => 4; # boolean, default is true
use constant UNDEF    => 5; # scalar value for non-existing elements
use constant STOP     => 6; # integer, will compare to iterator
use constant GROUP    => 7; # integer, number of elements per group
use constant COUNT    => 8; # integer, returned instead of iterator
use constant USER     => 9; # reserved for child classes(?)

# references => names mapping
my %_each_subs = (
    \&each_default  => '&Array::Each::each_default',
    \&each_unbound  => '&Array::Each::each_unbound',
    \&each_group    => '&Array::Each::each_group',
    \&each_complete => '&Array::Each::each_complete',
    );

# mappings of named arguments
my %_index_for;
@_index_for{ qw( _each set iterator rewind bound undef stop group count user ) } =
    ( EACH, SET, ITERATOR, REWIND, BOUND, UNDEF, STOP, GROUP, COUNT, USER );

my @_default;  # see also _set_each() for expectations about defaults
@_default[ EACH, SET, ITERATOR, REWIND, BOUND, UNDEF, STOP, GROUP, COUNT, USER ] =
    ( undef, [[]], 0, 0, 1, undef, undef, undef, undef, undef );

# attribute validations
my @_validate;
@_validate[ EACH, SET, ITERATOR, REWIND, BOUND, UNDEF, STOP, GROUP, COUNT, USER ] = (
    sub{ !defined $_[0] or exists $_each_subs{$_[0]} or
        croak "Invalid _each: '$_[0]'" },
    sub{ UNIVERSAL::isa( $_[0], 'ARRAY' ) and
        UNIVERSAL::isa( $_[0]->[0], 'ARRAY' ) or
        croak "Invalid set: '$_[0]'" },
    sub{ $_[0] =~ /^\d+$/ or
        croak "Invalid iterator: '$_[0]'" },
    sub{ $_[0] =~ /^\d+$/ or
        croak "Invalid rewind: '$_[0]'" },
    sub{ $_[0] =~ /[01]/ or
        croak "Invalid bound: '$_[0]'" },
    sub{ # Undef value can be anything
        },
    sub{ !defined $_[0] or $_[0] =~ /^\d+$/ or
        croak "Invalid stop: '$_[0]'" },
    sub{ !defined $_[0] or ($_[0] =~ /^\d+$/ and $_[0] > 0) or
        croak "Invalid group: '$_[0]'" },
    sub{ !defined $_[0] or $_[0] =~ /^\d+$/ or
        croak "Invalid count: '$_[0]'" },
    sub {}, # To be defined by child classes
    );

# constructor methods: new(), copy()
# Note, the code for new() is taken not quite in whole
# cloth from section 4.2 of "Object Oriented Perl"[1].
sub new {
    my $caller = shift;
    my $caller_is_obj = ref $caller;
    my $class = $caller_is_obj || $caller;
    my %arg;

    ### if only array refs are passed to new() ...
    if( ref $_[0] ) { $arg{ 'set' } = [@_] }
    else            { %arg = @_ }

    my $self = bless [], $class;
    foreach my $member ( keys %_index_for ) {
        my $index = $_index_for{ $member };
        if ( exists $arg{ $member } ) {
            $self->[ $index ] = $arg{ $member } }
        elsif ($caller_is_obj) {
            $self->[ $index ] = $caller->[ $index ] }
        else {
            $self->[ $index ] = $_default[ $index ] }
        $_validate[ $index ]->( $self->[ $index ] );
    }
    $self->_set_each() unless defined $self->[EACH];
    $self;
}

### do not rely on copy() being an alias of new(), see POD
*copy = \&new;

# accessor methods
sub _get_each_name { $_each_subs{$_[0]->[EACH]}; }
sub _get_each_ref  { $_[0]->[EACH]     }
sub get_set        { @{$_[0]->[SET]}   }
sub get_iterator   { $_[0]->[ITERATOR] }
sub get_rewind     { $_[0]->[REWIND]   }
sub get_bound      { $_[0]->[BOUND]    }
sub get_undef      { $_[0]->[UNDEF]    }
sub get_stop       { $_[0]->[STOP]     }
sub get_group      { $_[0]->[GROUP]    }
sub get_count      { $_[0]->[COUNT]    }
sub get_user       { $_[0]->[USER]     }

sub _set_each {
    my $self = shift;
    if( defined $_[0] ) {
        $self->[EACH] = $_[0];
        $_validate[EACH]->( $self->[EACH] );
        return $self->[EACH];
    }

    # are these set to defaults?
    my $r = ( $self->[REWIND] == $_default[REWIND] );
    my $b = ( $self->[BOUND]  == $_default[BOUND]  );
    my $s = ( !defined $self->[STOP]  );  # default is undef
    my $g = ( !defined $self->[GROUP] );  # default is undef
    my $c = ( !defined $self->[COUNT] );  # default is undef
    CASE: {
        # all are defaults
        ($r && $b && $s && $g && $c) and
            $self->[EACH] = \&each_default, last CASE;
        # all except bound
        ($r && $s && $g && $c) and
            $self->[EACH] = \&each_unbound, last CASE;
        # all except group
        ($r && $b && $s && $c) and
            $self->[EACH] = \&each_group, last CASE;
        # else
        $self->[EACH] = \&each_complete;
    }
    $self->[EACH];
}

sub set_set {
    my $self = shift;
    $self->[SET] = [@_];
    $_validate[SET]->( $self->[SET] );
    @{$self->[SET]};
}
sub set_iterator {
    my $self = shift;
    $self->[ITERATOR] = $_[0];
    $_validate[ITERATOR]->( $self->[ITERATOR] );
    $self->[ITERATOR];
}
sub set_rewind {
    my $self = shift;
    $self->[REWIND] = $_[0];
    $_validate[REWIND]->( $self->[REWIND] );
    $self->_set_each;
    $self->[REWIND];
}
sub set_bound {
    my $self = shift;
    $self->[BOUND] = $_[0];
    $_validate[BOUND]->( $self->[BOUND] );
    $self->_set_each;
    $self->[BOUND];
}
sub set_undef {
    my $self = shift;
    $self->[UNDEF] = $_[0];
    $_validate[UNDEF]->( $self->[UNDEF] );
    $self->[UNDEF];
}
sub set_stop {
    my $self = shift;
    $self->[STOP] = $_[0];
    $_validate[STOP]->( $self->[STOP] );
    $self->_set_each;
    $self->[STOP];
}
sub set_group {
    my $self = shift;
    $self->[GROUP] = $_[0];
    $_validate[GROUP]->( $self->[GROUP] );
    $self->_set_each;
    $self->[GROUP];
}
sub set_count {
    my $self = shift;
    $self->[COUNT] = $_[0];
    $_validate[COUNT]->( $self->[COUNT] );
    $self->_set_each;
    $self->[COUNT];
}

# note: no set_user() defined in this class

# utility methods
sub rewind {
    my $self = shift;
    $self->set_iterator(
        defined $_[0] ? $_[0] : $self->[REWIND] );
}
sub incr_iterator {
    my $self = shift;
    return $self->[ITERATOR]++ unless $self->[GROUP];
    my $i = $self->[ITERATOR];
    $self->[ITERATOR] += $self->[GROUP];
    $i;
}

# each methods
sub each { &{$_[0]->[EACH]} }  # call this object's each()

sub each_default {  # enough attributes are default
    my $self  = shift;
    my $i = $self->[ITERATOR]++;          # inlined incr_iterator
    $self->[ITERATOR] = $self->[REWIND],  # inlined rewind
        return if grep {$i >= @$_} @{$self->[SET]};
    ( (map $_->[$i], @{$self->[SET]}), $i );
}

sub each_unbound {  # bound not true
    my $self  = shift;
    my $i = $self->[ITERATOR]++;          # inlined incr_iterator
    $self->[ITERATOR] = $self->[REWIND],  # inlined rewind
        return unless grep {$i < @$_} @{$self->[SET]};
    ( (map {$i<@$_ ? $_->[$i] : $self->[UNDEF]} @{$self->[SET]}), $i );
}

sub each_group {  # group is defined
    my $self  = shift;
    my $group = $self->[GROUP];
    my $i = $self->[ITERATOR];            # inlined
    $self->[ITERATOR] += $group;          #     incr_iterator
    $self->[ITERATOR] = $self->[REWIND],  # inlined rewind
        return if grep {$i >= @$_} @{$self->[SET]};
    my @ret;
    foreach my $aref ( @{$self->[SET]} ) {
        push @ret,
            map {$_<@$aref ? $aref->[$_] : $self->[UNDEF]}
            ($i..$i+$group-1) }
    ( @ret, $i );
}

sub each_complete {  # enough attributes aren't default
    my $self  = shift;
    my $i     = $self->incr_iterator();  # increment for next time, use current
    my $set   = $self->[SET];
    my $stop  = $self->[STOP];
    my $undef = $self->[UNDEF];
    my $group = $self->[GROUP];
    my $c;

    # if bound to the shortest array, stop there (or at stop) ...
    if( $self->[BOUND] ) {
        if( defined $stop ) {
            $self->rewind(), return if $i > $stop || grep {$i >= @$_} @$set }
        else {
            $self->rewind(), return if grep {$i >= @$_} @$set }
        $c = defined $self->[COUNT] ? $self->[COUNT]++ : $i;
        return ( (map $_->[$i], @$set), $c ) unless defined $group;
    }

    # else not bound to the shortest array, so (maybe) go farther ...
    else {
        if( defined $stop ) {  # may go past longest array, too
            $self->rewind(), return if $i > $stop }
        else {
            $self->rewind(), return unless grep {$i < @$_} @$set }
        $c = defined $self->[COUNT] ? $self->[COUNT]++ : $i;
        return ( (map {$i<@$_ ? $_->[$i] : $undef} @$set), $c )
            unless defined $group;
    }

    # or return groups of elements, i.e., $group is defined
    my @ret;
    foreach my $aref ( @$set ) {
        push @ret, map {$_<@$aref ? $aref->[$_] : $undef} ($i..$i+$group-1) }
    ( @ret, $c );
}

1;  # true

__END__