File Coverage

blib/lib/MouseX/NativeTraits/MethodProvider/ArrayRef.pm

Criterion	Covered	Total	%
statement	299	328	91.1
branch	87	104	83.6
condition	6	12	50.0
subroutine	69	69	100.0
pod	29	29	100.0
total	490	542	90.4

package MouseX::NativeTraits::MethodProvider::ArrayRef;
use Mouse;
use Mouse::Util::TypeConstraints ();

use List::Util ();

extends qw(MouseX::NativeTraits::MethodProvider);

sub generate_count {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        if(@_ != 1) {
            $self->argument_error('count', 1, 1, scalar @_);
        }
        return scalar @{ $reader->( $_[0] ) };
    };
}

sub generate_is_empty {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        if(@_ != 1) {
            $self->argument_error('is_empty', 1, 1, scalar @_);
        }
        return scalar(@{ $reader->( $_[0] ) }) == 0;
    };
}

sub generate_first {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ != 2) {
            $self->argument_error('first', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::CodeRef($block)
            or $instance->meta->throw_error(
                "The argument passed to first must be a code reference");

        return List::Util::first(\&{$block}, @{ $reader->($instance) });
    };
}

sub generate_any {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ != 2) {
            $self->argument_error('any', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::CodeRef($block)
            or $instance->meta->throw_error(
                "The argument passed to any must be a code reference");

        foreach (@{ $reader->($instance) }){
            if($block->($_)){
                return 1;
            }
        }
        return 0;
    };
}

sub generate_apply {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ != 2) {
            $self->argument_error('apply', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::CodeRef($block)
            or $instance->meta->throw_error(
                "The argument passed to apply must be a code reference");

        my @values = @{ $reader->($instance) };
        foreach (@values){
            $block->();
        }
        return @values;
    };
}

sub generate_map {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ != 2) {
            $self->argument_error('map', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::CodeRef($block)
            or $instance->meta->throw_error(
                "The argument passed to map must be a code reference");

        return map { $block->() } @{ $reader->($instance) };
    };
}

sub generate_reduce {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ != 2) {
            $self->argument_error('reduce', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::CodeRef($block)
            or $instance->meta->throw_error(
                "The argument passed to reduce must be a code reference");

        our ($a, $b);
        return List::Util::reduce { $block->($a, $b) } @{ $reader->($instance) };
    };
}

sub generate_sort {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ < 1 or @_ > 2) {
            $self->argument_error('sort', 1, 2, scalar @_);
        }

        if (defined $block) {
            Mouse::Util::TypeConstraints::CodeRef($block)
                or $instance->meta->throw_error(
                    "The argument passed to sort must be a code reference");

            return sort { $block->( $a, $b ) } @{ $reader->($instance) };
        }
        else {
            return sort @{ $reader->($instance) };
        }
    };
}

sub generate_sort_in_place {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        my ( $instance, $block ) = @_;

        if(@_ < 1 or @_ > 2) {
            $self->argument_error('sort_in_place', 1, 2, scalar @_);
        }

        my $array_ref = $reader->($instance);

        if(defined $block){
            Mouse::Util::TypeConstraints::CodeRef($block)
                or $instance->meta->throw_error(
                    "The argument passed to sort_in_place must be a code reference");
            @{$array_ref} = sort { $block->($a, $b) } @{$array_ref};
        }
        else{
            @{$array_ref} = sort @{$array_ref};
        }

        return $instance;
    };
}


# The sort_by algorithm comes from perlfunc/sort
# See also perldoc -f sort and perldoc -q sort

sub generate_sort_by {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block, $compare ) = @_;

        if(@_ < 1 or @_ > 3) {
            $self->argument_error('sort_by', 1, 3, scalar @_);
        }

        my $array_ref = $reader->($instance);
        my @idx;
        foreach (@{$array_ref}){ # intentinal use of $_
            push @idx, scalar $block->($_);
        }

        # NOTE: scalar(@idx)-1 is faster than $#idx
        if($compare){
            return @{ $array_ref }[
                sort { $compare->($idx[$a], $idx[$b]) }
                    0 .. scalar(@idx)-1
            ];
        }
        else{
            return @{ $array_ref }[
                sort { $idx[$a] cmp $idx[$b] }
                    0 .. scalar(@idx)-1
            ];
        }
    };
}


sub generate_sort_in_place_by {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        my ( $instance, $block, $compare ) = @_;

        if(@_ < 1 or @_ > 3) {
            $self->argument_error('sort_by', 1, 3, scalar @_);
        }

        my $array_ref = $reader->($instance);
        my @idx;
        foreach (@{$array_ref}){
            push @idx, scalar $block->($_);
        }

        if($compare){
            @{ $array_ref } = @{ $array_ref }[
                sort { $compare->($idx[$a], $idx[$b]) }
                    0 .. scalar(@idx)-1
            ];
        }
        else{
            @{ $array_ref } = @{ $array_ref }[
                sort { $idx[$a] cmp $idx[$b] }
                    0 .. scalar(@idx)-1
            ];
        }
        return $instance;
    };
}


sub generate_shuffle {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance ) = @_;

        if(@_ != 1) {
            $self->argument_error('shuffle', 1, 1, scalar @_);
        }

        return List::Util::shuffle @{ $reader->($instance) };
    };
}

sub generate_grep {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $block ) = @_;

        if(@_ != 2) {
            $self->argument_error('grep', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::CodeRef($block)
            or $instance->meta->throw_error(
                "The argument passed to grep must be a code reference");

        return grep { $block->() } @{ $reader->($instance) };
    };
}

sub generate_uniq {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance ) = @_;

        if(@_ != 1) {
            $self->argument_error('uniq', 1, 1, scalar @_);
        }

        my %seen;
        my $seen_undef;
        return  grep{
            ( defined($_)
                ? ++$seen{$_}
                : ++$seen_undef
            ) == 1
        } @{ $reader->($instance) };
    };
}

sub generate_elements {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ($instance) = @_;

        if(@_ != 1) {
            $self->argument_error('elements', 1, 1, scalar @_);
        }

        return @{ $reader->($instance) };
    };
}

sub generate_join {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        my ( $instance, $separator ) = @_;

        if(@_ != 2) {
            $self->argument_error('join', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::Str($separator)
            or $instance->meta->throw_error(
                "The argument passed to join must be a string");

        return join $separator, @{ $reader->($instance) };
    };
}

sub generate_push {
    my($self) = @_;
    my $reader     = $self->reader;
    my $writer     = $self->writer;

    return sub {
        my($instance, @values) = @_;

        my @new_values = @{ $reader->($instance) };
        push @new_values, @values;
        $writer->($instance, \@new_values); # commit
        return scalar @new_values;
    };
}

sub generate_pop {
    my($self) = @_;
    my $reader = $self->reader;
    return sub {
        if(@_ != 1) {
            $self->argument_error('pop', 1, 1, scalar @_);
        }
        return pop @{ $reader->( $_[0] ) };
    };
}

sub generate_unshift {
    my($self) = @_;
    my $reader     = $self->reader;
    my $writer     = $self->writer;

    return sub {
        my($instance, @values) = @_;

        my @new_values = @{ $reader->($instance) };
        unshift @new_values, @values;
        $writer->($instance, \@new_values); # commit
        return scalar @new_values;
    };
}

sub generate_shift {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        if(@_ != 1) {
            $self->argument_error('shift', 1, 1, scalar @_);
        }

        return shift @{ $reader->( $_[0] ) };
    };
}

__PACKAGE__->meta->add_method(generate_get => \&generate_fetch); # alias
sub generate_fetch {
    my($self, $handle_name) = @_;
    my $reader = $self->reader;

    return sub {
        my($instance, $idx) = @_;

        if(@_ != 2) {
            $self->argument_error('get', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::Int($idx)
            or $instance->meta->throw_error(
                "The index passed to get must be an integer");

        return $reader->( $instance )->[ $idx ];
    };
}

__PACKAGE__->meta->add_method(generate_set => \&generate_store); # alias
sub generate_store {
    my($self) = @_;
    my $reader     = $self->reader;
    my $writer     = $self->writer;

    return sub {
        my($instance, $idx, $value) = @_;

        if(@_ != 3) {
            $self->argument_error('set', 3, 3, scalar @_);
        }

        Mouse::Util::TypeConstraints::Int($idx)
            or $instance->meta->throw_error(
                "The index argument passed to set must be an integer");

        my @new_values = @{ $reader->($instance) };
        $new_values[$idx] = $value;
        $writer->($instance, \@new_values); # commit
        return $value;
    };
}

sub generate_accessor {
    my($self) = @_;
    my $reader     = $self->reader;
    my $writer     = $self->writer;

    return sub {
        my($instance, $idx, $value) = @_;


        if ( @_ == 2 ) {    # reader
            Mouse::Util::TypeConstraints::Int($idx)
                or $instance->meta->throw_error(
                    "The index argument passed to accessor must be an integer");

            return $reader->($instance)->[ $idx ];
        }
        elsif ( @_ == 3) {    # writer
            Mouse::Util::TypeConstraints::Int($idx)
                or $instance->meta->throw_error(
                    "The index argument passed to accessor must be an integer");

            my @new_values = @{ $reader->($instance) };
            $new_values[$idx] = $value;
            $writer->($instance, \@new_values); # commit
            return $value;
        }
        else {
            $self->argument_error('accessor', 2, 3, scalar @_);
        }
    };
}

sub generate_clear {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        my($instance) = @_;

        if(@_ != 1) {
            $self->argument_error('clear', 1, 1, scalar @_);
        }

        @{ $reader->( $instance ) } = ();
        return $instance;
    };
}

__PACKAGE__->meta->add_method(generate_delete => \&generate_remove); # alias
sub generate_remove {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        my($instance, $idx) = @_;

        if(@_ != 2) {
            $self->argument_error('delete', 2, 2, scalar @_);
        }

        Mouse::Util::TypeConstraints::Int($idx)
            or $instance->meta->throw_error(
                "The index argument passed to delete must be an integer");

        return splice @{ $reader->( $instance ) }, $idx, 1;
    };
}

sub generate_insert {
    my($self) = @_;
    my $reader     = $self->reader;
    my $writer     = $self->writer;

    return sub {
        my($instance, $idx, $value) = @_;

        if(@_ != 3) {
            $self->argument_error('insert', 3, 3, scalar @_);
        }

        Mouse::Util::TypeConstraints::Int($idx)
            or $instance->meta->throw_error(
                "The index argument passed to insert must be an integer");

        my @new_values = @{ $reader->($instance) };
        splice @new_values, $idx, 0, $value;
        $writer->($instance, \@new_values); # commit
        return $instance;
    };
}

sub generate_splice {
    my($self) = @_;
    my $reader     = $self->reader;
    my $writer     = $self->writer;

    return sub {
        my ( $instance, $idx, $len, @elems ) = @_;

        if(@_ < 2) {
            $self->argument_error('splice', 2, undef, scalar @_);
        }

        Mouse::Util::TypeConstraints::Int($idx)
            or $instance->meta->throw_error(
                "The index argument passed to splice must be an integer");

        if(defined $len) {
            Mouse::Util::TypeConstraints::Int($len)
                or $instance->meta->throw_error(
                    "The length argument passed to splice must be an integer");
        }

        my @new_values = @{ $reader->($instance) };
        my @ret_values = defined($len)
            ? splice @new_values, $idx, $len, @elems
            : splice @new_values, $idx;
        $writer->($instance, \@new_values); # commit
        return wantarray ? @ret_values : $ret_values[-1];
    };
}

sub generate_for_each {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        my ( $instance, $block ) = @_;

        foreach my $element(@{ $reader->instance($instance) }){
            $block->($element);
        }
        return $instance;
    };
}

sub generate_for_each_pair {
    my($self) = @_;
    my $reader = $self->reader;

    return sub {
        my ( $instance, $block ) = @_;

        my $array_ref = $reader->($instance);
        for(my $i = 0; $i < @{$array_ref}; $i += 2){
            $block->($array_ref->[$i], $array_ref->[$i + 1]);
        }
        return $instance;
    };
}

no Mouse;
__PACKAGE__->meta->make_immutable();

__END__