view release on metacpan or  search on metacpan

lib/Sub/Curry.pm  view on Meta::CPAN

sub curry { __PACKAGE__->new(@_) }
sub new {
    if (not ref $_[0]) {
        my $class = shift;

        my $cb = shift;
        my $spice = \@_;

        my @str;
        my $arg_offset = 0;
        my $inc_arg_offset = sub {
            $arg_offset =~ /^\@_/
                ? $arg_offset .= '+1'
                : $arg_offset++;
            return;
        };
        for (my $c = 0; $c < @$spice; $c++) {
            local $_ = $spice->[$c];
            if (! defined $spice->[$c]) {
                push @str => "\$spice->[$c]";
            }
            elsif (spice_eq(HOLE)) {
                push @str => sprintf '$_[%s]', $arg_offset;
                #$arg_offset .= '+1';
                $inc_arg_offset->();
            }
            elsif (spice_eq(ANTISPICE)) {
                $arg_offset .= '+1';
                $inc_arg_offset->();
            }
            elsif (spice_eq(BLACKHOLE)) {
                push @str => sprintf '@_[%s .. $#_]', $arg_offset;
                $arg_offset = '@_';
            }
            else {
                push @str => "\$spice->[$c]";
            }
        }

        #push @str, sprintf '@_[%s .. $#_]', $arg_offset;
        if (1) {
            if ($arg_offset) {
                if ($arg_offset !~ /^\@_/) {
                    push @str, sprintf '@_[%s .. $#_]', $arg_offset;
                }
                # Otherwise you'll get something bigger than @_ in the range,
                # e.g. @_+1 .. $#_ and that will always evaluate to a
                # zero-length slice.
            }
            else {
                # No spice. Just do a regular pass-along.
                push @str, '@_';
            }
        }

        my $code_str = "sub { \$cb->(@{[join ', ', @str]}) }";
        my $self = eval $code_str or die;

        #return $self if $nobless;

        bless $self => $class;

        _code_str($self => $code_str);
        _real_spice($self => $spice);
        $self->uncurried($cb);

        return $self;
    }
    else {
        my $self = shift;

        my $spice = _real_spice($self);

        my $special = grep {
               spice_eq(HOLE)
            or spice_eq(ANTISPICE)
            or spice_eq(BLACKHOLE)
        } @$spice;

        my $new_spice;
        if ($special) {
            my $arg_offset = 0;
            my @str;
            #my $blackhole;
            my $c;
            for ($c = 0; $c < @$spice and $arg_offset < @_; $c++) {
                local $_ = $spice->[$c];
                if (not defined) {
                    push @str => "\$spice->[$c]";
                }
                elsif (spice_eq(ANTISPICE)) {
                    $arg_offset++;
                }
                elsif (spice_eq(HOLE)) {
                    push @str => sprintf '$_[%d]', $arg_offset
                        unless spice_eq(ANTIHOLE, $_[$arg_offset]);
                    $arg_offset++;
                }
                elsif (spice_eq(BLACKHOLE)) {
                    while ($arg_offset < @_ and not spice_eq(WHITEHOLE, $_[$arg_offset])) {
                        push @str => sprintf '$_[%d]', $arg_offset++;
                    }

                    if ($arg_offset < @_) {
                        $arg_offset++; # Skip the whitehole.
                    }
                    else {
                        push @str => "\$spice->[$c]"; # Keep the blackhole.
                    }
                }
                else {
                    push @str => "\$spice->[$c]";
                }
            }

            if ($c < @$spice) {
                push @str => map "\$spice->[$_]" => $c .. $#$spice;
            }
            else {
                push @str, sprintf '@_[%d .. $#_]', $arg_offset;
            }