File Coverage

blib/lib/HOI/Comprehensions.pm

Criterion	Covered	Total	%
statement	103	106	97.1
branch	19	26	73.0
condition	3	3	100.0
subroutine	12	12	100.0
pod	4	7	57.1
total	141	154	91.5

package HOI::Comprehensions;

require Exporter;
our @ISA = qw( Exporter );
our @EXPORT_OK = qw( comp );
our $VERSION = '0.044';


sub comp {
    my $computation = shift;
    my $generators_ = \@_;
    sub {
        my @guards = @_;
        my %generators;
        my ($evalstr, $postfix) = ("", "");
        my $self_;
        while ($#$generators_ > -1) {
            my ($key, $value) = (shift @$generators_, shift @$generators_);
            $evalstr .= '$self->{generators}->{'.$key.'}->(';
            $postfix .= ')';
            $generators{$key} =
                (ref($value) eq 'ARRAY') ?
                    sub {
                        my $idx = 0;
                        sub {
                            if ($#_ == -1) {
                                my $last_ret = (defined $value->[$idx]) ? { $key => $value->[$idx] } : {};
                                $idx++;
                                my $last_done = ($idx > $#$value);
                                $idx %= ($#$value + 1) if ($#$value > -1);
                                return ($last_done, $last_ret);
                            }
                            my ($done, $res) = @_;
                            my $ret = { %$res, $key => $value->[$idx] };
                            $idx++ if ($done);
                            my $self_done = ($idx > $#$value);
                            $idx %= ($#$value + 1);
                            ($self_done, $ret);
                        }
                    }->() :
                    ( (ref($value) eq 'HOI::Comprehensions') ?
                        sub {
                            my $value_ = $value;
                            my $idx = 0;
                            sub {
                                my $forward =
                                sub {
                                    my ($ret, $forward_done);
                                    if ($value_->{all_done}) {
                                        ($ret) = $value_->{list}->[$idx];
                                        $idx++;
                                        $forward_done = ($idx > $#{$value_->{list}});
                                        $idx %= ($#{$value_->{list}} + 1);
                                        return ($forward_done, $ret);
                                    }
                                    ($ret, $forward_done) = $value_->next(0);
                                    ($forward_done, $ret)
                                };
                                if ($#_ == -1) {
                                    my ($last_done, $last_res) = $forward->();
                                    return ($last_done, { $key => $last_res });
                                }
                                my ($done, $res) = @_;
                                my ($self_done, $self_res) = $forward->();
                                my $ret = { %$res, $key => $self_res };
                                ($self_done * $done, $ret);
                            }
                        }->() :
                        sub {
                            if ($#_ == -1) {
                                my ($last_res, $last_done) = $value->();
                                return ($last_done, { $key => $last_res });
                            }
                            my ($done, $res) = @_;
                            my ($self_res, $self_done) =
                            sub {
                                my $scopestr = '';
                                my ($package_name) = $self_->{caller};
                                local $AttrPrefix = $package_name.'::';
                                for my $elt (keys %$res) {
                                    $scopestr = 'local $'."$AttrPrefix"."$elt"." = \$res->{$elt}; ";
                                }
                                eval $scopestr.'$value->()'
                                #$value->();
                            }->();
                            my $ret = { %$res, $key => $self_res };
                            ($self_done * $done, $ret);
                        }
                    );
        }
        $self_ =
        bless
        {
            computation => $computation,
            generators => \%generators,
            all_done => 0,
            geneitr => $evalstr.$postfix,
            guards => \@guards,
            list => [],
            caller => caller()
        }
    }
}

sub get_member {
    my ($self, $name) = @_;
    $self->{$name}
}

sub get_list {
    my ($self) = @_;
    $self->get_member('list')
}

sub is_over {
    my ($self) = @_;
    $self->get_member('all_done')
}

sub step_next_lazy {
    my ($self, $flag) = @_;
    return ($self->{list}, 1) if ($self->{all_done});
    my ($done, $arguments) = eval $self->{geneitr};
    $self->{all_done} = $done;
    my ($package_name) = $self->{caller};
    local $AttrPrefix = $package_name.'::';
    my $evalstr = '';
    for my $key (keys %$arguments) {
        $evalstr .= 'local $'."$AttrPrefix"."$key".' = $arguments->{'."$key".'}; ';
    }
    my %switches = (
        full => sub {
            my $guards_ok = 1;
            eval '{'.$evalstr.'($_->($arguments) or $guards_ok = 0) for (@{$self->{guards}}); '.'push @{$self->{list}}, $self->{computation}->($arguments) if ($guards_ok); '.'}';
            $guards_ok
        },
    );
    my $guard = 0;
    $guard = $switches{$flag}->() if (scalar(keys %$arguments) == scalar(keys %{$self->{generators}}));
    ($self->{list}, $done, $guard)
}

sub next {
    my ($l_, $done, $guard);
    for my $cnt (0..$_[1]) {
        do {
            ($l_, $done, $guard) = $_[0]->step_next_lazy('full');
        } until ($done or $guard);
    }
    ($l_->[$#$l_], $done, $guard)
}

sub next {
    my ($l_, $done, $guard);
    #print "cnt to $_[1]\n";
    for my $cnt (0..$_[1]) {
        do {
            ($l_, $done, $guard) = $_[0]->step_next_lazy('full');
        } until ($done or $guard);
    }
    ($l_->[$#$l_], $done, $guard)
}

use overload
    '<>' => sub { my @ret = $_[0]->next(0); \@ret },
    '+' =>
    sub {
        #print(scalar(@{$_[0]->{list}}), ' ', $_[1], "\n");
        my @ret = (scalar(@{$_[0]->{list}}) - 1 >= $_[1]) ? ($_[0]->{list}->[$_[1]], $_[0]->{all_done}) : ($_[0]->next($_[1] - scalar(@{$_[0]->{list}})));
        \@ret
    },
    ;

1;

sub force {
    my $self = shift;
    if (not $self->{all_done}) {
        my ($elt, $done);
        do {
            ($elt, $done) = @{<$self>};
        } while (not $done);
    }
    $self->{list}
}

__END__