File Coverage

blib/lib/Syntax/Keyword/Gather.pm

Criterion	Covered	Total	%
statement	42	45	93.3
branch	11	14	78.5
condition	5	8	62.5
subroutine	10	12	83.3
pod	0	4	0.0
total	68	83	81.9

package Syntax::Keyword::Gather;
$Syntax::Keyword::Gather::VERSION = '1.003001';
use strict;
use warnings;

# ABSTRACT: Implements the Perl 6 'gather/take' control structure in Perl 5

use Carp 'croak';

use Sub::Exporter::Progressive -setup => {
   exports => [qw{ break gather gathered take }],
   groups => {
      default => [qw{ break gather gathered take }],
   },
};

my %gatherers;

sub gather(&) {
   croak "Useless use of 'gather' in void context" unless defined wantarray;
   my ($code) = @_;
   my $caller = caller;
   local @_;
   push @{$gatherers{$caller}}, bless \@_, 'Syntax::Keyword::Gather::MagicArrayRef';
   die $@
      if !eval{ &$code } && $@ && !UNIVERSAL::isa($@, 'Syntax::Keyword::Gather::Break');
   return @{pop @{$gatherers{$caller}}} if wantarray;
   return   pop @{$gatherers{$caller}}  if defined wantarray;
}

sub gathered() {
   my $caller = caller;
   croak "Call to gathered not inside a gather" unless @{$gatherers{$caller}};
   return $gatherers{$caller}[-1];
}

sub take(@) {
   my $caller = caller;
   croak "Call to take not inside a gather block"
      unless ((caller 3)[3]||"") eq 'Syntax::Keyword::Gather::gather';
   @_ = $_ unless @_;
   push @{$gatherers{$caller}[-1]}, @_;
   return 0+@_;
}

my $breaker = bless [], 'Syntax::Keyword::Gather::Break';

sub break() {
   die $breaker;
}

package Syntax::Keyword::Gather::MagicArrayRef;
$Syntax::Keyword::Gather::MagicArrayRef::VERSION = '1.003001';
use overload
   'bool'   => sub { @{$_[0]} > 0      },
   '0+'     => sub { @{$_[0]} + 0      },
   '""'     => sub { join q{}, @{$_[0]} },
   fallback => 1;

1;

__END__