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