[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] ) } ? 1 : 0;
    };
}

sub find : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        my ( $instance, $predicate ) = @_;
        foreach my $val ( @{ $reader->($instance) } ) {
            return $val if $predicate->($val);
        }
        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 first : method {
    my ( $attr, $reader, $writer ) = @_;
    return sub {
        $reader->( $_[0] )->[0];
    };
}

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