File Coverage

blib/lib/List/MapMulti.pm

Criterion	Covered	Total	%
statement	117	119	98.3
branch	17	22	77.2
condition			n/a
subroutine	26	27	96.3
pod	2	2	100.0
total	162	170	95.2

package List::MapMulti;

use 5.006;
use strict;
use warnings;
no warnings qw/once void/;

BEGIN
{
	$List::MapMulti::AUTHORITY = 'cpan:TOBYINK';
	$List::MapMulti::VERSION   = '0.003';

	# use this module if it's installed.
	# don't panic if it's unavailable.
	eval {
		require autovivification;
		autovivification->unimport('warn');
	};
}

use Carp qw/carp croak/;

our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
use base qw/Exporter/;
BEGIN {
	@EXPORT      = qw/mapm/;
	@EXPORT_OK   = (@EXPORT, qw/map_multi iterator_multi/);
	%EXPORT_TAGS = (
		'all'      => \@EXPORT_OK,
		'standard' => \@EXPORT,
		'default'  => \@EXPORT,
		'nothing'  => [],
	);
}

sub iterator_multi
{
	join(q{::}, __PACKAGE__, 'Iterator')->new(@_);
}

sub map_multi (&@)
{
	my ($code, @arrays) = @_;
	my @results;

	if (@arrays)
	{
		my $iter = iterator_multi(@arrays);

		local $_ = $iter;

		# Localise $a, $b
		my ( $caller_a, $caller_b ) = do {
			my $pkg = caller;
			no strict 'refs';
			\*{$pkg.'::a'}, \*{$pkg.'::b'};
		};

		while (my @values = $iter->())
		{
			no strict 'refs';
			(*$caller_a, *$caller_b) = \( @values[0, 1] );
			push @results, $code->(@values);
		}
	}

	wantarray ? @results : scalar(@results);
}

sub mapm (&@); *mapm = \&map_multi;

package List::MapMulti::Iterator;

use strict;
use warnings;
no warnings qw/once void/;

use Carp qw/carp croak/;

use overload
	'&{}' => sub { my $self = shift; sub { $self->next } },
	'@{}' => sub { my $self = shift; [ $self->current ] },
;

BEGIN
{
	$List::MapMulti::Iterator::AUTHORITY = 'cpan:TOBYINK';
	$List::MapMulti::Iterator::VERSION   = '0.003';

	autovivification->unimport('warn');
}

sub new
{
	my ($class, @arrays) = @_;

	_array_check(\@arrays);

	my $self = bless {
		arrays          => \@arrays,
		lengths         => [ map { ;scalar @$_ } @arrays ],
		next_indices    => [ map { ;0 } @arrays ],
		current_indices => undef,
		last            => 0,
	}, $class;

	for my $arr (@arrays)
	{
		$self->{'last'}++ unless scalar @$arr;
	}

	return $self;
}

sub _array_check
{
	my ($arrays) = @_;
	my $callsub  = [caller(1)]->[3];

	if (warnings::enabled('misc'))
	{
		carp "no arrayrefs were passed to $callsub"
			unless @$arrays;
	}

	croak "non-arrayref passed to $callsub"
		if grep { ref ne 'ARRAY' } @$arrays;
}

sub _increment_indices
{
	my ($indices, $lengths) = @_;
	my $inc = $#$indices;

	while (1)
	{
		if ($inc < 0)
		{
			@$indices = ();
			return;
		}

		$indices->[$inc]++;
		if ($indices->[$inc] >= $lengths->[$inc])
		{
			$indices->[$inc] = 0;
			$inc--;
		}
		else
		{
			return $indices;
		}
	}
}

sub next
{
	my $self = shift;

	return if $self->{last};

	$self->{current_indices} = [ $self->next_indices ];

	my @values = map
		{ $self->{arrays}[$_][$self->{current_indices}[$_]] }
		0 .. $#{$self->{arrays}};

	$self->{last} = !_increment_indices($self->{next_indices}, $self->{lengths});

	return @values;
}

sub next_indices
{
	my $self = shift;

	if (@_)
	{
		$self->{next_indices} = [@_[ 0 .. $#{$self->{arrays}} ]];
	}

	@{ $self->{next_indices} };
}

sub current
{
	my $self = shift;

	if (@_)
	{
		my @ix = $self->current_indices;
		for my $i (0 .. $#_)
		{
			$self->{arrays}[$i][ $ix[$i] ] = $_[$i];
		}
	}

	my @values = map
		{ $self->{arrays}[$_][$self->{current_indices}[$_]] }
		0 .. $#{$self->{arrays}};
}

sub current_indices
{
	@{ (shift)->{current_indices} };
}

__PACKAGE__
__END__