[gitmo/Moose.git] / lib / Moose / Meta / Attribute / Native / MethodProvider / Array.pm

package Moose::Meta::Attribute::Native::MethodProvider::Array;
use Moose::Role;

our $VERSION = '0.89';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

sub count : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        scalar @{ $reader->( $_[0] ) };
    };
}

sub empty : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        scalar @{ $reader->( $_[0] ) } ? 0 : 1;
    };
}

sub first : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $predicate ) = @_;
        foreach my $val ( @{ $reader->($instance) } ) {
            local $_ = $val;
            return $val if $predicate->();
        }
        return;
    };
}

sub map : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $f ) = @_;
        CORE::map { $f->() } @{ $reader->($instance) };
    };
}

sub sort : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $predicate ) = @_;
        die "Argument must be a code reference"
          if $predicate && ref $predicate ne 'CODE';

        if ($predicate) {
            CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
        }
        else {
            CORE::sort @{ $reader->($instance) };
        }
    };
}

sub grep : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $predicate ) = @_;
        CORE::grep { $predicate->() } @{ $reader->($instance) };
    };
}

sub elements : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ($instance) = @_;
        @{ $reader->($instance) };
    };
}

sub join : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $separator ) = @_;
        join $separator, @{ $reader->($instance) };
    };
}

sub head : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        $reader->( $_[0] )->[0];
    };
}

sub tail : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my $arr = $reader->( $_[0] );
        return @{ $arr }[1..$#{ $arr }];
    };
}

sub last : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        $reader->( $_[0] )->[-1];
    };
}

sub push : method {
    my ( $attr, $reader, $writer ) = @_;

    if (
        $attr->has_type_constraint
        && $attr->type_constraint->isa(
            'Moose::Meta::TypeConstraint::Parameterized')
      )
    {
        my $container_type_constraint = $attr->type_constraint->type_parameter;
        return sub {
            my $instance = CORE::shift;
            $container_type_constraint->check($_)
              || confess "Value "
              . ( $_ || 'undef' )
              . " did not pass container type constraint '$container_type_constraint'"
              foreach @_;
            CORE::push @{ $reader->($instance) } => @_;
        };
    }
    else {
        return sub {
            my $instance = CORE::shift;
            CORE::push @{ $reader->($instance) } => @_;
        };
    }
}

sub pop : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        CORE::pop @{ $reader->( $_[0] ) };
    };
}

sub unshift : method {
    my ( $attr, $reader, $writer ) = @_;
    if (
        $attr->has_type_constraint
        && $attr->type_constraint->isa(
            'Moose::Meta::TypeConstraint::Parameterized')
      )
    {
        my $container_type_constraint = $attr->type_constraint->type_parameter;
        return sub {
            my $instance = CORE::shift;
            $container_type_constraint->check($_)
              || confess "Value "
              . ( $_ || 'undef' )
              . " did not pass container type constraint '$container_type_constraint'"
              foreach @_;
            CORE::unshift @{ $reader->($instance) } => @_;
        };
    }
    else {
        return sub {
            my $instance = CORE::shift;
            CORE::unshift @{ $reader->($instance) } => @_;
        };
    }
}

sub shift : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        CORE::shift @{ $reader->( $_[0] ) };
    };
}

sub get : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        $reader->( $_[0] )->[ $_[1] ];
    };
}

sub set : method {
    my ( $attr, $reader, $writer ) = @_;
    if (
        $attr->has_type_constraint
        && $attr->type_constraint->isa(
            'Moose::Meta::TypeConstraint::Parameterized')
      )
    {
        my $container_type_constraint = $attr->type_constraint->type_parameter;
        return sub {
            ( $container_type_constraint->check( $_[2] ) )
              || confess "Value "
              . ( $_[2] || 'undef' )
              . " did not pass container type constraint '$container_type_constraint'";
            $reader->( $_[0] )->[ $_[1] ] = $_[2];
        };
    }
    else {
        return sub {
            $reader->( $_[0] )->[ $_[1] ] = $_[2];
        };
    }
}

sub accessor : method {
    my ( $attr, $reader, $writer ) = @_;

    if (
        $attr->has_type_constraint
        && $attr->type_constraint->isa(
            'Moose::Meta::TypeConstraint::Parameterized')
      )
    {
        my $container_type_constraint = $attr->type_constraint->type_parameter;
        return sub {
            my $self = shift;

            if ( @_ == 1 ) {    # reader
                return $reader->($self)->[ $_[0] ];
            }
            elsif ( @_ == 2 ) {    # writer
                ( $container_type_constraint->check( $_[1] ) )
                  || confess "Value "
                  . ( $_[1] || 'undef' )
                  . " did not pass container type constraint '$container_type_constraint'";
                $reader->($self)->[ $_[0] ] = $_[1];
            }
            else {
                confess "One or two arguments expected, not " . @_;
            }
        };
    }
    else {
        return sub {
            my $self = shift;

            if ( @_ == 1 ) {    # reader
                return $reader->($self)->[ $_[0] ];
            }
            elsif ( @_ == 2 ) {    # writer
                $reader->($self)->[ $_[0] ] = $_[1];
            }
            else {
                confess "One or two arguments expected, not " . @_;
            }
        };
    }
}

sub clear : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        @{ $reader->( $_[0] ) } = ();
    };
}

sub delete : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1;
      }
}

sub insert : method {
    my ( $attr, $reader, $writer ) = @_;
    if (
        $attr->has_type_constraint
        && $attr->type_constraint->isa(
            'Moose::Meta::TypeConstraint::Parameterized')
      )
    {
        my $container_type_constraint = $attr->type_constraint->type_parameter;
        return sub {
            ( $container_type_constraint->check( $_[2] ) )
              || confess "Value "
              . ( $_[2] || 'undef' )
              . " did not pass container type constraint '$container_type_constraint'";
            CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
        };
    }
    else {
        return sub {
            CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
        };
    }
}

sub splice : method {
    my ( $attr, $reader, $writer ) = @_;
    if (
        $attr->has_type_constraint
        && $attr->type_constraint->isa(
            'Moose::Meta::TypeConstraint::Parameterized')
      )
    {
        my $container_type_constraint = $attr->type_constraint->type_parameter;
        return sub {
            my ( $self, $i, $j, @elems ) = @_;
            ( $container_type_constraint->check($_) )
              || confess "Value "
              . ( defined($_) ? $_ : 'undef' )
              . " did not pass container type constraint '$container_type_constraint'"
              for @elems;
            CORE::splice @{ $reader->($self) }, $i, $j, @elems;
        };
    }
    else {
        return sub {
            my ( $self, $i, $j, @elems ) = @_;
            CORE::splice @{ $reader->($self) }, $i, $j, @elems;
        };
    }
}

sub sort_in_place : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $predicate ) = @_;

        die "Argument must be a code reference"
          if $predicate && ref $predicate ne 'CODE';

        my @sorted;
        if ($predicate) {
            @sorted =
              CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
        }
        else {
            @sorted = CORE::sort @{ $reader->($instance) };
        }

        $writer->( $instance, \@sorted );
    };
}

1;

__END__

=pod

=head1 NAME

Moose::Meta::Attribute::Native::MethodProvider::Array

=head1 DESCRIPTION

This is a role which provides the method generators for
L<Moose::Meta::Attribute::Trait::Native::Array>. Please check there for
documentation on what methods are provided.

=head1 METHODS

=over 4

=item B<meta>

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 AUTHOR

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2007-2009 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut
Commit	Line	Data
c466e58f	1	package Moose::Meta::Attribute::Native::MethodProvider::Array;
e3c07b19	2	use Moose::Role;
e3c07b19	3
122a129a	4	our $VERSION = '0.89';
e3c07b19	5	$VERSION = eval $VERSION;
	6	our $AUTHORITY = 'cpan:STEVAN';
	7
e11fb12c	8	sub count : method {
	9	my ( $attr, $reader, $writer ) = @_;
	10	return sub {
	11	scalar @{ $reader->( $_[0] ) };
	12	};
	13	}
	14
	15	sub empty : method {
	16	my ( $attr, $reader, $writer ) = @_;
	17	return sub {
af44c00c	18	scalar @{ $reader->( $_[0] ) } ? 0 : 1;
e11fb12c	19	};
	20	}
	21
391c761c	22	sub first : method {
e11fb12c	23	my ( $attr, $reader, $writer ) = @_;
	24	return sub {
	25	my ( $instance, $predicate ) = @_;
	26	foreach my $val ( @{ $reader->($instance) } ) {
c9edbf05	27	local $_ = $val;
c9edbf05	28	return $val if $predicate->();
e11fb12c	29	}
	30	return;
	31	};
	32	}
	33
	34	sub map : method {
	35	my ( $attr, $reader, $writer ) = @_;
	36	return sub {
	37	my ( $instance, $f ) = @_;
c9edbf05	38	CORE::map { $f->() } @{ $reader->($instance) };
e11fb12c	39	};
	40	}
	41
	42	sub sort : method {
	43	my ( $attr, $reader, $writer ) = @_;
	44	return sub {
	45	my ( $instance, $predicate ) = @_;
	46	die "Argument must be a code reference"
33f819e1	47	if $predicate && ref $predicate ne 'CODE';
e11fb12c	48
	49	if ($predicate) {
	50	CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
	51	}
	52	else {
	53	CORE::sort @{ $reader->($instance) };
	54	}
	55	};
	56	}
	57
	58	sub grep : method {
	59	my ( $attr, $reader, $writer ) = @_;
	60	return sub {
	61	my ( $instance, $predicate ) = @_;
c9edbf05	62	CORE::grep { $predicate->() } @{ $reader->($instance) };
e11fb12c	63	};
	64	}
	65
	66	sub elements : method {
	67	my ( $attr, $reader, $writer ) = @_;
	68	return sub {
	69	my ($instance) = @_;
	70	@{ $reader->($instance) };
	71	};
	72	}
	73
	74	sub join : method {
	75	my ( $attr, $reader, $writer ) = @_;
	76	return sub {
	77	my ( $instance, $separator ) = @_;
	78	join $separator, @{ $reader->($instance) };
	79	};
	80	}
	81
391c761c	82	sub head : method {
e11fb12c	83	my ( $attr, $reader, $writer ) = @_;
	84	return sub {
	85	$reader->( $_[0] )->[0];
	86	};
	87	}
	88
391c761c	89	sub tail : method {
	90	my ( $attr, $reader, $writer ) = @_;
	91	return sub {
	92	my $arr = $reader->( $_[0] );
	93	return @{ $arr }[1..$#{ $arr }];
	94	};
	95	}
	96
e11fb12c	97	sub last : method {
	98	my ( $attr, $reader, $writer ) = @_;
	99	return sub {
	100	$reader->( $_[0] )->[-1];
	101	};
	102	}
e3c07b19	103
e3c07b19	104	sub push : method {
046c8b5e	105	my ( $attr, $reader, $writer ) = @_;
	106
	107	if (
	108	$attr->has_type_constraint
	109	&& $attr->type_constraint->isa(
	110	'Moose::Meta::TypeConstraint::Parameterized')
33f819e1	111	)
	112	{
	113	my $container_type_constraint = $attr->type_constraint->type_parameter;
e3c07b19	114	return sub {
	115	my $instance = CORE::shift;
	116	$container_type_constraint->check($_)
33f819e1	117	\|\| confess "Value "
	118	. ( $_ \|\| 'undef' )
	119	. " did not pass container type constraint '$container_type_constraint'"
	120	foreach @_;
046c8b5e	121	CORE::push @{ $reader->($instance) } => @_;
e3c07b19	122	};
	123	}
	124	else {
	125	return sub {
	126	my $instance = CORE::shift;
046c8b5e	127	CORE::push @{ $reader->($instance) } => @_;
e3c07b19	128	};
	129	}
	130	}
	131
	132	sub pop : method {
046c8b5e	133	my ( $attr, $reader, $writer ) = @_;
e3c07b19	134	return sub {
046c8b5e	135	CORE::pop @{ $reader->( $_[0] ) };
e3c07b19	136	};
	137	}
	138
	139	sub unshift : method {
046c8b5e	140	my ( $attr, $reader, $writer ) = @_;
	141	if (
	142	$attr->has_type_constraint
	143	&& $attr->type_constraint->isa(
	144	'Moose::Meta::TypeConstraint::Parameterized')
33f819e1	145	)
	146	{
	147	my $container_type_constraint = $attr->type_constraint->type_parameter;
e3c07b19	148	return sub {
	149	my $instance = CORE::shift;
	150	$container_type_constraint->check($_)
33f819e1	151	\|\| confess "Value "
	152	. ( $_ \|\| 'undef' )
	153	. " did not pass container type constraint '$container_type_constraint'"
	154	foreach @_;
046c8b5e	155	CORE::unshift @{ $reader->($instance) } => @_;
e3c07b19	156	};
	157	}
	158	else {
	159	return sub {
	160	my $instance = CORE::shift;
046c8b5e	161	CORE::unshift @{ $reader->($instance) } => @_;
e3c07b19	162	};
	163	}
	164	}
	165
	166	sub shift : method {
046c8b5e	167	my ( $attr, $reader, $writer ) = @_;
e3c07b19	168	return sub {
046c8b5e	169	CORE::shift @{ $reader->( $_[0] ) };
e3c07b19	170	};
	171	}
	172
	173	sub get : method {
046c8b5e	174	my ( $attr, $reader, $writer ) = @_;
e3c07b19	175	return sub {
046c8b5e	176	$reader->( $_[0] )->[ $_[1] ];
e3c07b19	177	};
	178	}
	179
	180	sub set : method {
046c8b5e	181	my ( $attr, $reader, $writer ) = @_;
	182	if (
	183	$attr->has_type_constraint
	184	&& $attr->type_constraint->isa(
	185	'Moose::Meta::TypeConstraint::Parameterized')
33f819e1	186	)
	187	{
	188	my $container_type_constraint = $attr->type_constraint->type_parameter;
e3c07b19	189	return sub {
046c8b5e	190	( $container_type_constraint->check( $_[2] ) )
33f819e1	191	\|\| confess "Value "
	192	. ( $_[2] \|\| 'undef' )
	193	. " did not pass container type constraint '$container_type_constraint'";
046c8b5e	194	$reader->( $_[0] )->[ $_[1] ] = $_[2];
e3c07b19	195	};
	196	}
	197	else {
	198	return sub {
046c8b5e	199	$reader->( $_[0] )->[ $_[1] ] = $_[2];
e3c07b19	200	};
	201	}
	202	}
	203
	204	sub accessor : method {
046c8b5e	205	my ( $attr, $reader, $writer ) = @_;
	206
	207	if (
	208	$attr->has_type_constraint
	209	&& $attr->type_constraint->isa(
	210	'Moose::Meta::TypeConstraint::Parameterized')
33f819e1	211	)
	212	{
	213	my $container_type_constraint = $attr->type_constraint->type_parameter;
e3c07b19	214	return sub {
	215	my $self = shift;
	216
046c8b5e	217	if ( @_ == 1 ) { # reader
046c8b5e	218	return $reader->($self)->[ $_[0] ];
e3c07b19	219	}
046c8b5e	220	elsif ( @_ == 2 ) { # writer
046c8b5e	221	( $container_type_constraint->check( $_[1] ) )
33f819e1	222	\|\| confess "Value "
	223	. ( $_[1] \|\| 'undef' )
	224	. " did not pass container type constraint '$container_type_constraint'";
046c8b5e	225	$reader->($self)->[ $_[0] ] = $_[1];
e3c07b19	226	}
	227	else {
	228	confess "One or two arguments expected, not " . @_;
	229	}
	230	};
	231	}
	232	else {
	233	return sub {
	234	my $self = shift;
	235
046c8b5e	236	if ( @_ == 1 ) { # reader
046c8b5e	237	return $reader->($self)->[ $_[0] ];
e3c07b19	238	}
046c8b5e	239	elsif ( @_ == 2 ) { # writer
046c8b5e	240	$reader->($self)->[ $_[0] ] = $_[1];
e3c07b19	241	}
	242	else {
	243	confess "One or two arguments expected, not " . @_;
	244	}
	245	};
	246	}
	247	}
	248
	249	sub clear : method {
046c8b5e	250	my ( $attr, $reader, $writer ) = @_;
e3c07b19	251	return sub {
046c8b5e	252	@{ $reader->( $_[0] ) } = ();
e3c07b19	253	};
	254	}
	255
	256	sub delete : method {
046c8b5e	257	my ( $attr, $reader, $writer ) = @_;
e3c07b19	258	return sub {
046c8b5e	259	CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1;
33f819e1	260	}
e3c07b19	261	}
	262
	263	sub insert : method {
046c8b5e	264	my ( $attr, $reader, $writer ) = @_;
	265	if (
	266	$attr->has_type_constraint
	267	&& $attr->type_constraint->isa(
	268	'Moose::Meta::TypeConstraint::Parameterized')
33f819e1	269	)
	270	{
	271	my $container_type_constraint = $attr->type_constraint->type_parameter;
e3c07b19	272	return sub {
046c8b5e	273	( $container_type_constraint->check( $_[2] ) )
33f819e1	274	\|\| confess "Value "
	275	. ( $_[2] \|\| 'undef' )
	276	. " did not pass container type constraint '$container_type_constraint'";
046c8b5e	277	CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
e3c07b19	278	};
	279	}
	280	else {
	281	return sub {
046c8b5e	282	CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
e3c07b19	283	};
	284	}
	285	}
	286
	287	sub splice : method {
046c8b5e	288	my ( $attr, $reader, $writer ) = @_;
	289	if (
	290	$attr->has_type_constraint
	291	&& $attr->type_constraint->isa(
	292	'Moose::Meta::TypeConstraint::Parameterized')
33f819e1	293	)
	294	{
	295	my $container_type_constraint = $attr->type_constraint->type_parameter;
e3c07b19	296	return sub {
e3c07b19	297	my ( $self, $i, $j, @elems ) = @_;
046c8b5e	298	( $container_type_constraint->check($_) )
33f819e1	299	\|\| confess "Value "
	300	. ( defined($_) ? $_ : 'undef' )
	301	. " did not pass container type constraint '$container_type_constraint'"
	302	for @elems;
046c8b5e	303	CORE::splice @{ $reader->($self) }, $i, $j, @elems;
e3c07b19	304	};
	305	}
	306	else {
	307	return sub {
	308	my ( $self, $i, $j, @elems ) = @_;
046c8b5e	309	CORE::splice @{ $reader->($self) }, $i, $j, @elems;
e3c07b19	310	};
	311	}
	312	}
	313
	314	sub sort_in_place : method {
046c8b5e	315	my ( $attr, $reader, $writer ) = @_;
e3c07b19	316	return sub {
046c8b5e	317	my ( $instance, $predicate ) = @_;
e3c07b19	318
e3c07b19	319	die "Argument must be a code reference"
33f819e1	320	if $predicate && ref $predicate ne 'CODE';
e3c07b19	321
	322	my @sorted;
	323	if ($predicate) {
33f819e1	324	@sorted =
33f819e1	325	CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
e3c07b19	326	}
e3c07b19	327	else {
046c8b5e	328	@sorted = CORE::sort @{ $reader->($instance) };
e3c07b19	329	}
e3c07b19	330
046c8b5e	331	$writer->( $instance, \@sorted );
e3c07b19	332	};
	333	}
	334
	335	1;
	336
	337	__END__
	338
	339	=pod
	340
	341	=head1 NAME
	342
c466e58f	343	Moose::Meta::Attribute::Native::MethodProvider::Array
e3c07b19	344
	345	=head1 DESCRIPTION
	346
	347	This is a role which provides the method generators for
9da49e13	348	L<Moose::Meta::Attribute::Trait::Native::Array>. Please check there for
9da49e13	349	documentation on what methods are provided.
e3c07b19	350
	351	=head1 METHODS
	352
	353	=over 4
	354
	355	=item B<meta>
	356
	357	=back
	358
e3c07b19	359	=head1 BUGS
	360
	361	All complex software has bugs lurking in it, and this module is no
	362	exception. If you find a bug please either email me, or add the bug
	363	to cpan-RT.
	364
	365	=head1 AUTHOR
	366
	367	Stevan Little E<lt>stevan@iinteractive.comE<gt>
	368
	369	=head1 COPYRIGHT AND LICENSE
	370
	371	Copyright 2007-2009 by Infinity Interactive, Inc.
	372
	373	L<http://www.iinteractive.com>
	374
	375	This library is free software; you can redistribute it and/or modify
	376	it under the same terms as Perl itself.
	377
	378	=cut