Also see Moose::Manual::Delta for more details of, and workarounds
for, noteworthy changes.
+ * Moose::Meta::Attribute
+ - Added the currying syntax for delegation from AttributeHelpers
+ to the existing delegation API. (hdp)
+
+ * Moose::Meta::Attribute::Native
+ - Moved in from MooseX::AttributeHelpers with API tweaks. See
+ Moose::Manual::Delta for details. (hdp, jhannah, rbuels, Sartak,
+ perigrin, doy)
+
* Moose::Error::Croak
* Moose::Error::Confess
- Clarify documentation on how to use. (Curtis Jewell)
use Moose::Util::TypeConstraints;
use Moose::Util ();
+use Moose::Meta::Attribute::Native;
+
sub throw_error {
# FIXME This
shift;
which delegate to the C<node> and C<children> methods (respectively) of the Tree
instance stored in the C<parent> slot.
+You may also use an array reference to curry arguments to the original method.
+
+ has 'thing' => (
+ ...
+ handles => { set_foo => [ set => 'foo' ] },
+ );
+
+ # $self->set_foo(...) calls $self->thing->set('foo', ...)
+
+The first element of the array reference is the original method name, and the
+rest is a list of curried arguments.
+
=item C<REGEXP>
The regexp option works very similar to the ARRAY option, except that it builds
When declaring an attribute, you can declare a metaclass or a set of
traits for the attribute:
- use MooseX::AttributeHelpers;
+ use Moose::AttributeHelpers;
has 'mapping' => (
- metaclass => 'Collection::Hash',
+ metaclass => 'Hash',
is => 'ro',
default => sub { {} },
);
-In this case, the metaclass C<Collection::Hash> really refers to
-L<MooseX::AttributeHelpers::Collection::Hash>.
+In this case, the metaclass C<Hash> really refers to
+L<Moose::Meta::Attribute::Trait::Native::Hash>.
You can also apply one or more traits to an attribute:
=head1 WHAT IS DELEGATION?
-Delegation is a feature that lets you create "shadow" methods that
+Delegation is a feature that lets you create "proxy" methods that
do nothing more than call some other method on an attribute. This
is quite handy since it lets you simplify a complex set of "has-a"
relationships and present a single unified API from one class.
mapping. You probably won't need this version often (if ever). See the
L<Moose> docs for more details on exactly how this works.
+=head1 PERL DATA STRUCTURES
+
+Handles also will allow you to delegate to "helper" methods that work on
+common Perl data structures. If you remember or have ever used
+L<MooseX::AttributeHelpers|MooseX::AttributeHelpers> the mechanism is very
+similar.
+
+ has 'queue' => (
+ isa => 'ArrayRef[Item]',
+ traits => ['Array'],
+ default => sub { [ ] },
+ handles => {
+ add_item => 'push',
+ next_item => 'shift',
+ },
+ )
+
+By providing the C<Array> trait to the C<traits> parameter you signal to
+Moose that you would like to use the set of Array helpers. Moose will then
+create C<add_item> and C<next_item> method that "just works". Behind the
+scenes C<add_item> is something like
+
+ sub add_item {
+ my ($self, @items) = @_;
+
+ for my $item (@items) {
+ $Item_TC->validate($item);
+ }
+
+ push @{ $self->queue }, @items;
+ }
+
+There are traits for not only C<Array> but also C<Hash>, C<Bool>, C<String>,
+C<Number>, and C<Counter>. For more information see the documentation in
+L<Moose::Meta::Attribute::Native|Moose::Meta::Attribute::Native>.
+
+=head1 CURRYING
+
+Currying is a way of creating a method or function from another method or
+function with some of the parameters pre-defined. Moose provides the ability to
+curry methods when creating delegates.
+
+ package Spider;
+ use Moose;
+
+ has request => (
+ is => 'ro'
+ isa => 'HTTP::Request',
+ handles => {
+ set_user_agent => [ header => 'UserAgent' ],
+ },
+ )
+
+With this definition, calling C<< $spider->set_user_agent('MyClient') >> will
+behind the scenes call C<< $spider->request->header('UserAgent', 'MyClient')>>.
+
=head1 MISSING ATTRIBUTES
It is perfectly valid to delegate methods to an attribute which is not
=head1 Version 0.89
+L<Moose::Meta::Attribute::Native> has been moved into the Moose core from
+L<MooseX::AttributeHelpers>. Major changes include:
+
+=over
+
+=item C<traits>, not C<metaclass>
+
+Method providers are only available via traits.
+
+=item C<handles>, not C<provides> or C<curries>
+
+The C<provides> syntax was like core Moose C<< handles => HASHREF >>
+syntax, but with the keys and values reversed. This was confusing,
+and AttributeHelpers now uses C<< handles => HASHREF >> in a way that
+should be intuitive to anyone already familiar with how it is used for
+other attributes.
+
+The C<curries> functionality provided by AttributeHelpers has been
+generalized to apply to all cases of C<< handles => HASHREF >>, though
+not every piece of functionality has been ported (currying with a
+CODEREF is not supported).
+
+=item C<empty> is now C<is_empty>, and means empty, not non-empty
+
+Previously, the C<empty> method provided by Arrays and Hashes returned true if
+the attribute was B<not> empty (no elements). Now it returns true if the
+attribute B<is> empty. It was also renamed to C<is_empty>, to reflect this.
+
+=item C<find> was renamed to C<first>, and C<first> and C<last> were removed
+
+L<List::Util> refers to the functionality that we used to provide under C<find>
+as L<first|List::Util/first>, so that will likely be more familiar (and will
+fit in better if we decide to add more List::Util functions). C<first> and
+C<last> were removed, since their functionality is easily duplicated with
+curries of C<get>.
+
+=item Helpers that take a coderef of one argument now use C<$_>
+
+Subroutines passed as the first argument to C<first>, C<map>, and C<grep> now
+receive their argument in C<$_> rather than as a parameter to the subroutine.
+Helpers that take a coderef of two or more arguments remain using the argument
+list (there are technical limitations to using C<$a> and C<$b> like C<sort>
+does).
+
+=back
+
+See L<Moose::Meta::Attribute::Native> for the new documentation.
+
C<< use Moose -metaclass => 'Foo' >> now does alias resolution, just like
C<-traits> (and the C<metaclass> and C<traits> options to C<has>).
));
__PACKAGE__->meta->add_attribute('handles' => (
reader => 'handles',
+ writer => '_set_handles',
predicate => 'has_handles',
));
__PACKAGE__->meta->add_attribute('documentation' => (
$method_body = $method_to_call
if 'CODE' eq ref($method_to_call);
+ my @curried_arguments;
+
+ ($method_to_call, @curried_arguments) = @$method_to_call
+ if 'ARRAY' eq ref($method_to_call);
+
return $self->delegation_metaclass->new(
name => $handle_name,
package_name => $self->associated_class->name,
attribute => $self,
delegate_to_method => $method_to_call,
+ curried_arguments => \@curried_arguments,
);
}
--- /dev/null
+package Moose::Meta::Attribute::Native;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+my @trait_names = qw(Bool Counter Number String Array Hash);
+
+for my $trait_name (@trait_names) {
+ my $trait_class = "Moose::Meta::Attribute::Native::Trait::$trait_name";
+ my $meta = Class::MOP::Class->initialize(
+ "Moose::Meta::Attribute::Custom::Trait::$trait_name"
+ );
+ if ($meta->find_method_by_name('register_implementation')) {
+ my $class = $meta->name->register_implementation;
+ Moose->throw_error(
+ "An implementation for $trait_name already exists " .
+ "(found '$class' when trying to register '$trait_class')"
+ );
+ }
+ $meta->add_method(register_implementation => sub {
+ # resolve_metatrait_alias will load classes anyway, but throws away
+ # their error message; we WANT to die if there's a problem
+ Class::MOP::load_class($trait_class);
+ return $trait_class;
+ });
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native - Extend your attribute interfaces
+
+=head1 SYNOPSIS
+
+ package MyClass;
+ use Moose;
+
+ has 'mapping' => (
+ traits => [ 'Hash' ],
+ is => 'rw',
+ isa => 'HashRef[Str]',
+ default => sub { {} },
+ handles => {
+ exists_in_mapping => 'exists',
+ ids_in_mapping => 'keys',
+ get_mapping => 'get',
+ set_mapping => 'set',
+ set_quantity => [ set => [ 'quantity' ] ],
+ },
+ );
+
+
+ # ...
+
+ my $obj = MyClass->new;
+ $obj->set_quantity(10); # quantity => 10
+ $obj->set_mapping(4, 'foo'); # 4 => 'foo'
+ $obj->set_mapping(5, 'bar'); # 5 => 'bar'
+ $obj->set_mapping(6, 'baz'); # 6 => 'baz'
+
+
+ # prints 'bar'
+ print $obj->get_mapping(5) if $obj->exists_in_mapping(5);
+
+ # prints '4, 5, 6'
+ print join ', ', $obj->ids_in_mapping;
+
+=head1 DESCRIPTION
+
+While L<Moose> attributes provide a way to name your accessors, readers,
+writers, clearers and predicates, this library provides commonly
+used attribute helper methods for more specific types of data.
+
+As seen in the L</SYNOPSIS>, you specify the data structure via the
+C<trait> parameter. Available meta classes are below; see L</METHOD PROVIDERS>.
+
+This module used to exist as the L<MooseX::AttributeHelpers> extension. It was
+very commonly used, so we moved it into core Moose. Since this gave us a chance
+to change the interface, you will have to change your code or continue using
+the L<MooseX::AttributeHelpers> extension.
+
+=head1 PARAMETERS
+
+=head2 handles
+
+This is like C<< handles >> in L<Moose/has>, but only HASH references are
+allowed. Keys are method names that you want installed locally, and values are
+methods from the method providers (below). Currying with delegated methods
+works normally for C<< handles >>.
+
+=head1 METHOD PROVIDERS
+
+=over
+
+=item L<Number|Moose::Meta::Attribute::Native::Trait::Number>
+
+Common numerical operations.
+
+ has 'integer' => (
+ traits => ['Number'],
+ is => 'ro',
+ isa => 'Int',
+ default => 5,
+ handles => {
+ set => 'set',
+ add => 'add',
+ sub => 'sub',
+ mul => 'mul',
+ div => 'div',
+ mod => 'mod',
+ abs => 'abs',
+ }
+ );
+
+=item L<String|Moose::Meta::Attribute::Native::Trait::String>
+
+Common methods for string operations.
+
+ has 'text' => (
+ traits => ['String'],
+ is => 'rw',
+ isa => 'Str',
+ default => q{},
+ handles => {
+ add_text => 'append',
+ replace_text => 'replace',
+ }
+ );
+
+=item L<Counter|Moose::Meta::Attribute::Native::Trait::Counter>
+
+Methods for incrementing and decrementing a counter attribute.
+
+ has 'counter' => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Num',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ reset_counter => 'reset',
+ }
+ );
+
+=item L<Bool|Moose::Meta::Attribute::Native::Trait::Bool>
+
+Common methods for boolean values.
+
+ has 'is_lit' => (
+ traits => ['Bool'],
+ is => 'rw',
+ isa => 'Bool',
+ default => 0,
+ handles => {
+ illuminate => 'set',
+ darken => 'unset',
+ flip_switch => 'toggle',
+ is_dark => 'not',
+ }
+ );
+
+=item L<Hash|Moose::Meta::Attribute::Native::Trait::Hash>
+
+Common methods for hash references.
+
+ has 'options' => (
+ traits => ['Hash'],
+ is => 'ro',
+ isa => 'HashRef[Str]',
+ default => sub { {} },
+ handles => {
+ set_option => 'set',
+ get_option => 'get',
+ has_option => 'exists',
+ }
+ );
+
+=item L<Array|Moose::Meta::Attribute::Native::Trait::Array>
+
+Common methods for array references.
+
+ has 'queue' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Str]',
+ default => sub { [] },
+ handles => {
+ add_item => 'push',
+ next_item => 'shift',
+ }
+ );
+
+=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>
+
+B<with contributions from:>
+
+Robert (rlb3) Boone
+
+Paul (frodwith) Driver
+
+Shawn (Sartak) Moore
+
+Chris (perigrin) Prather
+
+Robert (phaylon) Sedlacek
+
+Tom (dec) Lanyon
+
+Yuval Kogman
+
+Jason May
+
+Cory (gphat) Watson
+
+Florian (rafl) Ragwitz
+
+Evan Carroll
+
+Jesse (doy) Luehrs
+
+=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
--- /dev/null
+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 is_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 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
--- /dev/null
+
+package Moose::Meta::Attribute::Native::MethodProvider::Bool;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub set : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], 1 ) };
+}
+
+sub unset : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], 0 ) };
+}
+
+sub toggle : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], !$reader->( $_[0] ) ) };
+}
+
+sub not : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { !$reader->( $_[0] ) };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::MethodProvider::Bool
+
+=head1 DESCRIPTION
+
+This is a role which provides the method generators for
+L<Moose::Meta::Attribute::Trait::Native::Bool>. 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
+
+Jason May E<lt>jason.a.may@gmail.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
--- /dev/null
+
+package Moose::Meta::Attribute::Native::MethodProvider::Counter;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub reset : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $attr->default( $_[0] ) ) };
+}
+
+sub set : method {
+ my ( $attr, $reader, $writer, $value ) = @_;
+ return sub { $writer->( $_[0], $_[1] ) };
+}
+
+sub inc {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ $writer->( $_[0],
+ $reader->( $_[0] ) + ( defined( $_[1] ) ? $_[1] : 1 ) );
+ };
+}
+
+sub dec {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ $writer->( $_[0],
+ $reader->( $_[0] ) - ( defined( $_[1] ) ? $_[1] : 1 ) );
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::MethodProvider::Counter
+
+=head1 DESCRIPTION
+
+This is a role which provides the method generators for
+L<Moose::Meta::Attribute::Trait::Native::Counter>. 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
--- /dev/null
+package Moose::Meta::Attribute::Native::MethodProvider::Hash;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub exists : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { CORE::exists $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
+}
+
+sub defined : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { CORE::defined $reader->( $_[0] )->{ $_[1] } ? 1 : 0 };
+}
+
+sub get : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ if ( @_ == 2 ) {
+ $reader->( $_[0] )->{ $_[1] };
+ }
+ else {
+ my ( $self, @keys ) = @_;
+ @{ $reader->($self) }{@keys};
+ }
+ };
+}
+
+sub keys : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { CORE::keys %{ $reader->( $_[0] ) } };
+}
+
+sub values : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { CORE::values %{ $reader->( $_[0] ) } };
+}
+
+sub kv : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my $h = $reader->( $_[0] );
+ map { [ $_, $h->{$_} ] } CORE::keys %{$h};
+ };
+}
+
+sub elements : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my $h = $reader->( $_[0] );
+ map { $_, $h->{$_} } CORE::keys %{$h};
+ };
+}
+
+sub count : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { scalar CORE::keys %{ $reader->( $_[0] ) } };
+}
+
+sub empty : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { scalar CORE::keys %{ $reader->( $_[0] ) } ? 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 {
+ my ( $self, @kvp ) = @_;
+
+ my ( @keys, @values );
+
+ while (@kvp) {
+ my ( $key, $value ) = ( shift(@kvp), shift(@kvp) );
+ ( $container_type_constraint->check($value) )
+ || confess "Value "
+ . ( $value || 'undef' )
+ . " did not pass container type constraint '$container_type_constraint'";
+ push @keys, $key;
+ push @values, $value;
+ }
+
+ if ( @values > 1 ) {
+ @{ $reader->($self) }{@keys} = @values;
+ }
+ else {
+ $reader->($self)->{ $keys[0] } = $values[0];
+ }
+ };
+ }
+ else {
+ return sub {
+ if ( @_ == 3 ) {
+ $reader->( $_[0] )->{ $_[1] } = $_[2];
+ }
+ else {
+ my ( $self, @kvp ) = @_;
+ my ( @keys, @values );
+
+ while (@kvp) {
+ push @keys, shift @kvp;
+ push @values, shift @kvp;
+ }
+
+ @{ $reader->( $_[0] ) }{@keys} = @values;
+ }
+ };
+ }
+}
+
+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 {
+ my $hashref = $reader->(shift);
+ CORE::delete @{$hashref}{@_};
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::MethodProvider::Hash
+
+=head1 DESCRIPTION
+
+This is a role which provides the method generators for
+L<Moose::Meta::Attribute::Trait::Native::Hash>. 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
+
--- /dev/null
+package Moose::Meta::Attribute::Native::MethodProvider::String;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub append : method {
+ my ( $attr, $reader, $writer ) = @_;
+
+ return sub { $writer->( $_[0], $reader->( $_[0] ) . $_[1] ) };
+}
+
+sub prepend : method {
+ my ( $attr, $reader, $writer ) = @_;
+
+ return sub { $writer->( $_[0], $_[1] . $reader->( $_[0] ) ) };
+}
+
+sub replace : method {
+ my ( $attr, $reader, $writer ) = @_;
+
+ return sub {
+ my ( $self, $regex, $replacement ) = @_;
+ my $v = $reader->( $_[0] );
+
+ if ( ( ref($replacement) || '' ) eq 'CODE' ) {
+ $v =~ s/$regex/$replacement->()/e;
+ }
+ else {
+ $v =~ s/$regex/$replacement/;
+ }
+
+ $writer->( $_[0], $v );
+ };
+}
+
+sub match : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $reader->( $_[0] ) =~ $_[1] };
+}
+
+sub chop : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my $v = $reader->( $_[0] );
+ CORE::chop($v);
+ $writer->( $_[0], $v );
+ };
+}
+
+sub chomp : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my $v = $reader->( $_[0] );
+ chomp($v);
+ $writer->( $_[0], $v );
+ };
+}
+
+sub inc : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my $v = $reader->( $_[0] );
+ $v++;
+ $writer->( $_[0], $v );
+ };
+}
+
+sub clear : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], '' ) }
+}
+
+sub length : method {
+ my ($attr, $reader, $writer) = @_;
+ return sub {
+ my $v = $reader->($_[0]);
+ return CORE::length($v);
+ };
+}
+
+sub substr : method {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub {
+ my $self = shift;
+ my $v = $reader->($self);
+
+ my $offset = defined $_[0] ? shift : 0;
+ my $length = defined $_[0] ? shift : CORE::length($v);
+ my $replacement = defined $_[0] ? shift : undef;
+
+ my $ret;
+ if ( defined $replacement ) {
+ $ret = CORE::substr( $v, $offset, $length, $replacement );
+ $writer->( $self, $v );
+ }
+ else {
+ $ret = CORE::substr( $v, $offset, $length );
+ }
+
+ return $ret;
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::MethodProvider::String
+
+=head1 DESCRIPTION
+
+This is a role which provides the method generators for
+L<Moose::Meta::Attribute::Trait::Native::String>. 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
--- /dev/null
+
+package Moose::Meta::Attribute::Native::Trait;
+use Moose::Role;
+use Moose::Util::TypeConstraints;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+requires '_helper_type';
+
+# these next two are the possible methods you can use in the 'handles'
+# map.
+
+# provide a Class or Role which we can collect the method providers
+# from
+
+# or you can provide a HASH ref of anon subs yourself. This will also
+# collect and store the methods from a method_provider as well
+has 'method_constructors' => (
+ is => 'ro',
+ isa => 'HashRef',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ return +{} unless $self->has_method_provider;
+ # or grab them from the role/class
+ my $method_provider = $self->method_provider->meta;
+ return +{
+ map {
+ $_ => $method_provider->get_method($_)
+ } $method_provider->get_method_list
+ };
+ },
+);
+
+has '+default' => ( required => 1 );
+has '+type_constraint' => ( required => 1 );
+
+# methods called prior to instantiation
+
+before '_process_options' => sub {
+ my ( $self, $name, $options ) = @_;
+
+ $self->_check_helper_type( $options, $name );
+
+ $options->{is} = $self->_default_is
+ if ! exists $options->{is} && $self->can('_default_is');
+
+ $options->{default} = $self->_default_default
+ if ! exists $options->{default} && $self->can('_default_default');
+};
+
+sub _check_helper_type {
+ my ( $self, $options, $name ) = @_;
+
+ my $type = $self->_helper_type;
+
+ $options->{isa} = $type
+ unless exists $options->{isa};
+
+ my $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint(
+ $options->{isa} );
+
+ ( $isa->is_a_type_of($type) )
+ || confess
+ "The type constraint for $name must be a subtype of $type but it's a $isa";
+}
+
+around '_canonicalize_handles' => sub {
+ my $next = shift;
+ my $self = shift;
+ my $handles = $self->handles;
+
+ return unless $handles;
+
+ unless ( 'HASH' eq ref $handles ) {
+ $self->throw_error(
+ "The 'handles' option must be a HASH reference, not $handles" );
+ }
+
+ return map {
+ my $to = $handles->{$_};
+ $to = [$to] unless ref $to;
+ $_ => $to
+ } keys %$handles;
+};
+
+# methods called after instantiation
+
+before 'install_accessors' => sub { (shift)->_check_handles_values };
+
+sub _check_handles_values {
+ my $self = shift;
+
+ my $method_constructors = $self->method_constructors;
+
+ my %handles = $self->_canonicalize_handles;
+
+ for my $original_method ( values %handles ) {
+ my $name = $original_method->[0];
+ ( exists $method_constructors->{$name} )
+ || confess "$name is an unsupported method type";
+ }
+
+}
+
+around '_make_delegation_method' => sub {
+ my $next = shift;
+ my ( $self, $handle_name, $method_to_call ) = @_;
+
+ my ( $name, @curried_args ) = @$method_to_call;
+
+ my $method_constructors = $self->method_constructors;
+
+ my $code = $method_constructors->{$name}->(
+ $self,
+ $self->get_read_method_ref,
+ $self->get_write_method_ref,
+ );
+
+ return $next->(
+ $self,
+ $handle_name,
+ sub {
+ my $instance = shift;
+ return $code->( $instance, @curried_args, @_ );
+ },
+ );
+};
+
+no Moose::Role;
+no Moose::Util::TypeConstraints;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait - base role for helpers
+
+=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 AUTHORS
+
+Yuval Kogman
+
+Shawn M Moore
+
+Jesse Luehrs
+
+=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
--- /dev/null
+
+package Moose::Meta::Attribute::Native::Trait::Array;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Moose::Meta::Attribute::Native::MethodProvider::Array;
+
+with 'Moose::Meta::Attribute::Native::Trait';
+
+has 'method_provider' => (
+ is => 'ro',
+ isa => 'ClassName',
+ predicate => 'has_method_provider',
+ default => 'Moose::Meta::Attribute::Native::MethodProvider::Array'
+);
+
+sub _helper_type { 'ArrayRef' }
+
+no Moose::Role;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait::Array
+
+=head1 SYNOPSIS
+
+ package Stuff;
+ use Moose;
+
+ has 'options' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Str]',
+ default => sub { [] },
+ handles => {
+ all_options => 'elements',
+ map_options => 'map',
+ filter_options => 'grep',
+ find_option => 'first',
+ get_option => 'get',
+ join_options => 'join',
+ count_options => 'count',
+ has_no_options => 'is_empty',
+ sorted_options => 'sort',
+ },
+ );
+
+ no Moose;
+ 1;
+
+=head1 DESCRIPTION
+
+This module provides an Array attribute which provides a number of
+array operations.
+
+=head1 PROVIDED METHODS
+
+These methods are implemented in
+L<Moose::Meta::Attribute::Native::MethodProvider::Array>.
+
+=over 4
+
+=item B<count>
+
+Returns the number of elements in the array.
+
+ $stuff = Stuff->new;
+ $stuff->options(["foo", "bar", "baz", "boo"]);
+
+ my $count = $stuff->count_options;
+ print "$count\n"; # prints 4
+
+=item B<is_empty>
+
+Returns a boolean value indicating whether or not the array has any elements.
+
+ $stuff->has_no_options ? die "No options!\n" : print "Good boy.\n";
+
+=item B<elements>
+
+Returns all of the elements of the array.
+
+ my @option = $stuff->all_options;
+ print "@options\n"; # prints "foo bar baz boo"
+
+=item B<get($index)>
+
+Returns an element of the array by its index. You can also use negative index
+numbers, just as with Perl's core array handling.
+
+ my $option = $stuff->get_option(1);
+ print "$option\n"; # prints "bar"
+
+=item B<pop>
+
+=item B<push($value)>
+
+=item B<shift>
+
+=item B<unshift($value)>
+
+=item B<splice($offset, $length, @values)>
+
+These methods are all equivalent to the Perl core functions of the same name.
+
+=item B<first( sub { ... } )>
+
+This method returns the first item matching item in the array. The matching is
+done with a subroutine reference you pass to this method. The reference will
+be called against each element in the array until one matches or all elements
+have been checked.
+
+ my $found = $stuff->find_option( sub { /^b/ } );
+ print "$found\n"; # prints "bar"
+
+=item B<grep( sub { ... } )>
+
+This method returns every element matching a given criteria, just like Perl's
+core C<grep> function. This method requires a subroutine which implements the
+matching logic.
+
+ my @found = $stuff->filter_options( sub { /^b/ } );
+ print "@found\n"; # prints "bar baz boo"
+
+=item B<map( sub { ... } )>
+
+This method transforms every element in the array and returns a new array,
+just like Perl's core C<map> function. This method requires a subroutine which
+implements the transformation.
+
+ my @mod_options = $stuff->map_options( sub { $_ . "-tag" } );
+ print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag"
+
+=item B<sort( sub { ... } )>
+
+Returns a the array in sorted order.
+
+You can provide an optional subroutine reference to sort with (as you can with
+Perl's core C<sort> function). However, instead of using C<$a> and C<$b>, you
+will need to use C<$_[0]> and C<$_[1]> instead.
+
+ # ascending ASCIIbetical
+ my @sorted = $stuff->sort_options();
+
+ # Descending alphabetical order
+ my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } );
+ print "@sorted_options\n"; # prints "foo boo baz bar"
+
+=item B<sort_in_place>
+
+Sorts the array I<in place>, modifying the value of the attribute.
+
+You can provide an optional subroutine reference to sort with (as you can with
+Perl's core C<sort> function). However, instead of using C<$a> and C<$b>, you
+will need to use C<$_[0]> and C<$_[1]> instead.
+
+=item B<join($str)>
+
+Joins every element of the array using the separator given as argument, just
+like Perl's core C<join> function.
+
+ my $joined = $stuff->join_options( ':' );
+ print "$joined\n"; # prints "foo:bar:baz:boo"
+
+=item B<set($index, $value)>
+
+Given an index and a value, sets the specified array element's value.
+
+=item B<delete($index)>
+
+Removes the element at the given index from the array.
+
+=item B<insert($index, $value)>
+
+Inserts a new element into the array at the given index.
+
+=item B<clear>
+
+Empties the entire array, like C<@array = ()>.
+
+=item B<accessor>
+
+This method provides a get/set accessor for the array, based on array indexes.
+If passed one argument, it returns the value at the specified index. If
+passed two arguments, it sets the value of the specified index.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_provider>
+
+=item B<has_method_provider>
+
+=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
--- /dev/null
+package Moose::Meta::Attribute::Native::Trait::Bool;
+use Moose::Role;
+use Moose::Meta::Attribute::Native::MethodProvider::Bool;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+with 'Moose::Meta::Attribute::Native::Trait';
+
+sub _default_is { 'rw' }
+sub _helper_type { 'Bool' }
+
+# NOTE: we don't use the method provider for this module since many of
+# the names of the provided methods would conflict with keywords - SL
+
+has 'method_provider' => (
+ is => 'ro',
+ isa => 'ClassName',
+ predicate => 'has_method_provider',
+ default => 'Moose::Meta::Attribute::Native::MethodProvider::Bool'
+);
+
+no Moose::Role;
+
+1;
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait::Bool
+
+=head1 SYNOPSIS
+
+ package Room;
+ use Moose;
+
+ has 'is_lit' => (
+ traits => ['Bool'],
+ is => 'rw',
+ isa => 'Bool',
+ default => 0,
+ handles => {
+ illuminate => 'set',
+ darken => 'unset',
+ flip_switch => 'toggle',
+ is_dark => 'not',
+ },
+ );
+
+ my $room = Room->new();
+ $room->illuminate; # same as $room->is_lit(1);
+ $room->darken; # same as $room->is_lit(0);
+ $room->flip_switch; # same as $room->is_lit(not $room->is_lit);
+ return $room->is_dark; # same as !$room->is_lit
+
+=head1 DESCRIPTION
+
+This provides a simple boolean attribute, which supports most of the
+basic math operations.
+
+=head1 PROVIDED METHODS
+
+These methods are implemented in
+L<Moose::Meta::Attribute::Native::MethodProvider::Bool>. It is important to
+note that all those methods do in place modification of the value stored in
+the attribute.
+
+=over 4
+
+=item B<set>
+
+Sets the value to C<1>.
+
+=item B<unset>
+
+Set the value to C<0>.
+
+=item B<toggle>
+
+Toggles the value. If it's true, set to false, and vice versa.
+
+=item B<not>
+
+Equivalent of 'not C<$value>'.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_constructors>
+
+=item B<has_method_provider>
+
+=item B<method_provider>
+
+=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
+
+Jason May
+
+=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
--- /dev/null
+
+package Moose::Meta::Attribute::Native::Trait::Counter;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Moose::Meta::Attribute::Native::MethodProvider::Counter;
+
+with 'Moose::Meta::Attribute::Native::Trait';
+
+has 'method_provider' => (
+ is => 'ro',
+ isa => 'ClassName',
+ predicate => 'has_method_provider',
+ default => 'Moose::Meta::Attribute::Native::MethodProvider::Counter',
+);
+
+sub _default_default { 0 }
+sub _default_is { 'ro' }
+sub _helper_type { 'Num' }
+
+after '_check_handles_values' => sub {
+ my $self = shift;
+ my $handles = $self->handles;
+
+ unless ( scalar keys %$handles ) {
+ my $method_constructors = $self->method_constructors;
+ my $attr_name = $self->name;
+
+ foreach my $method ( keys %$method_constructors ) {
+ $handles->{ $method . '_' . $attr_name } = $method;
+ }
+
+ $self->_set_handles($handles);
+ }
+};
+
+no Moose::Role;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait::Counter
+
+=head1 SYNOPSIS
+
+ package MyHomePage;
+ use Moose;
+
+ has 'counter' => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Num',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ reset_counter => 'reset',
+ },
+ );
+
+ my $page = MyHomePage->new();
+ $page->inc_counter; # same as $page->counter( $page->counter + 1 );
+ $page->dec_counter; # same as $page->counter( $page->counter - 1 );
+
+=head1 DESCRIPTION
+
+This module provides a simple counter attribute, which can be
+incremented and decremented.
+
+If your attribute definition does not include any of I<is>, I<isa>,
+I<default> or I<handles> but does use the C<Counter> trait,
+then this module applies defaults as in the L</SYNOPSIS>
+above. This allows for a very basic counter definition:
+
+ has 'foo' => (traits => ['Counter']);
+ $obj->inc_foo;
+
+=head1 PROVIDED METHODS
+
+These methods are implemented in
+L<Moose::Meta::Attribute::Native::MethodProvider::Counter>. It is important to
+note that all those methods do in place modification of the value stored in
+the attribute.
+
+=over 4
+
+=item B<set($value)>
+
+Set the counter to the specified value.
+
+=item B<inc>
+
+Increments the value stored in this slot by 1. Providing an argument will
+cause the counter to be increased by specified amount.
+
+=item B<dec>
+
+Decrements the value stored in this slot by 1. Providing an argument will
+cause the counter to be increased by specified amount.
+
+=item B<reset>
+
+Resets the value stored in this slot to it's default value.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_provider>
+
+=item B<has_method_provider>
+
+=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
--- /dev/null
+
+package Moose::Meta::Attribute::Native::Trait::Hash;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Moose::Meta::Attribute::Native::MethodProvider::Hash;
+
+with 'Moose::Meta::Attribute::Native::Trait';
+
+has 'method_provider' => (
+ is => 'ro',
+ isa => 'ClassName',
+ predicate => 'has_method_provider',
+ default => 'Moose::Meta::Attribute::Native::MethodProvider::Hash'
+);
+
+sub _helper_type { 'HashRef' }
+
+no Moose::Role;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait::Hash
+
+=head1 SYNOPSIS
+
+ package Stuff;
+ use Moose;
+
+ has 'options' => (
+ traits => ['Hash'],
+ is => 'ro',
+ isa => 'HashRef[Str]',
+ default => sub { {} },
+ handles => {
+ set_option => 'set',
+ get_option => 'get',
+ has_no_options => 'empty',
+ num_options => 'count',
+ delete_option => 'delete',
+ pairs => 'kv',
+ },
+ );
+
+=head1 DESCRIPTION
+
+This module provides a Hash attribute which provides a number of
+hash-like operations.
+
+=head1 PROVIDED METHODS
+
+These methods are implemented in
+L<Moose::Meta::Attribute::Native::MethodProvider::Hash>.
+
+=over 4
+
+=item B<get($key)>
+
+Returns an element of the hash by its key.
+
+=item B<set($key)>
+
+Sets the element in the hash at the given key to the given value.
+
+=item B<delete($key)>
+
+Removes the element with the given key.
+
+=item B<keys>
+
+Returns the list of keys in the hash.
+
+=item B<exists($key)>
+
+Returns true if the given key is present in the hash.
+
+=item B<defined($key)>
+
+Returns true if the value of a given key is defined.
+
+=item B<values>
+
+Returns the list of values in the hash.
+
+=item B<kv>
+
+Returns the key/value pairs in the hash as an array of array references.
+
+ for my $pair ( $object->options->pairs ) {
+ print "$pair->[0] = $pair->[1]\n";
+ }
+
+=item B<elements>
+
+Returns the key/value pairs in the hash as a flattened list..
+
+=item B<clear>
+
+Resets the hash to an empty value, like C<%hash = ()>.
+
+=item B<count>
+
+Returns the number of elements in the hash.
+
+=item B<empty>
+
+If the hash is populated, returns false. Otherwise, returns true.
+
+=item B<accessor>
+
+If passed one argument, returns the value of the specified key. If passed two
+arguments, sets the value of the specified key.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_provider>
+
+=item B<has_method_provider>
+
+=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
--- /dev/null
+package Moose::Meta::Attribute::Native::Trait::Number;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+with 'Moose::Meta::Attribute::Native::Trait';
+
+sub _helper_type { 'Num' }
+
+# NOTE: we don't use the method provider for this module since many of
+# the names of the provided methods would conflict with keywords - SL
+
+has 'method_constructors' => (
+ is => 'ro',
+ isa => 'HashRef',
+ lazy => 1,
+ default => sub {
+ return +{
+ set => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $_[1] ) };
+ },
+ add => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) + $_[1] ) };
+ },
+ sub => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) - $_[1] ) };
+ },
+ mul => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) * $_[1] ) };
+ },
+ div => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) / $_[1] ) };
+ },
+ mod => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], $reader->( $_[0] ) % $_[1] ) };
+ },
+ abs => sub {
+ my ( $attr, $reader, $writer ) = @_;
+ return sub { $writer->( $_[0], abs( $reader->( $_[0] ) ) ) };
+ },
+ };
+ }
+);
+
+no Moose::Role;
+
+1;
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait::Number
+
+=head1 SYNOPSIS
+
+ package Real;
+ use Moose;
+
+ has 'integer' => (
+ metaclass => 'Number',
+ is => 'ro',
+ isa => 'Int',
+ default => 5,
+ handles => {
+ set => 'set',
+ add => 'add',
+ sub => 'sub',
+ mul => 'mul',
+ div => 'div',
+ mod => 'mod',
+ abs => 'abs',
+ },
+ );
+
+ my $real = Real->new();
+ $real->add(5); # same as $real->integer($real->integer + 5);
+ $real->sub(2); # same as $real->integer($real->integer - 2);
+
+=head1 DESCRIPTION
+
+This provides a simple numeric attribute, which supports most of the
+basic math operations.
+
+=head1 PROVIDED METHODS
+
+It is important to note that all those methods do in place modification of the
+value stored in the attribute. These methods are implemented within this
+package.
+
+=over 4
+
+=item B<set($value)>
+
+Alternate way to set the value.
+
+=item B<add($value)>
+
+Adds the current value of the attribute to C<$value>.
+
+=item B<sub($value)>
+
+Subtracts the current value of the attribute to C<$value>.
+
+=item B<mul($value)>
+
+Multiplies the current value of the attribute to C<$value>.
+
+=item B<div($value)>
+
+Divides the current value of the attribute to C<$value>.
+
+=item B<mod($value)>
+
+Modulus the current value of the attribute to C<$value>.
+
+=item B<abs>
+
+Sets the current value of the attribute to its absolute value.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_constructors>
+
+=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
+
+Robert Boone
+
+=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
--- /dev/null
+package Moose::Meta::Attribute::Native::Trait::String;
+use Moose::Role;
+
+our $VERSION = '0.89';
+$VERSION = eval $VERSION;
+our $AUTHORITY = 'cpan:STEVAN';
+
+use Moose::Meta::Attribute::Native::MethodProvider::String;
+
+with 'Moose::Meta::Attribute::Native::Trait';
+
+has 'method_provider' => (
+ is => 'ro',
+ isa => 'ClassName',
+ predicate => 'has_method_provider',
+ default => 'Moose::Meta::Attribute::Native::MethodProvider::String',
+);
+
+sub _default_default { q{} }
+sub _default_is { 'rw' }
+sub _helper_type { 'Str' }
+
+after '_check_handles_values' => sub {
+ my $self = shift;
+ my $handles = $self->handles;
+
+ unless ( scalar keys %$handles ) {
+ my $method_constructors = $self->method_constructors;
+ my $attr_name = $self->name;
+
+ foreach my $method ( keys %$method_constructors ) {
+ $handles->{$method} = ( $method . '_' . $attr_name );
+ }
+ }
+};
+
+no Moose::Role;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Moose::Meta::Attribute::Native::Trait::String
+
+=head1 SYNOPSIS
+
+ package MyHomePage;
+ use Moose;
+
+ has 'text' => (
+ traits => ['String'],
+ is => 'rw',
+ isa => 'Str',
+ default => q{},
+ handles => {
+ add_text => 'append',
+ replace_text => 'replace',
+ },
+ );
+
+ my $page = MyHomePage->new();
+ $page->add_text("foo"); # same as $page->text($page->text . "foo");
+
+=head1 DESCRIPTION
+
+This module provides a simple string attribute, to which mutating string
+operations can be applied more easily (no need to make an lvalue attribute
+metaclass or use temporary variables). Additional methods are provided for
+completion.
+
+If your attribute definition does not include any of I<is>, I<isa>,
+I<default> or I<handles> but does use the C<String> metaclass,
+then this module applies defaults as in the L</SYNOPSIS>
+above. This allows for a very basic counter definition:
+
+ has 'foo' => (metaclass => 'String');
+ $obj->append_foo;
+
+=head1 PROVIDED METHODS
+
+These methods are implemented in
+L<Moose::Meta::Attribute::Native::MethodProvider::STring>. It is important to
+note that all those methods do in place modification of the value stored in
+the attribute.
+
+=over 4
+
+=item B<inc>
+
+Increments the value stored in this slot using the magical string autoincrement
+operator. Note that Perl doesn't provide analogous behavior in C<-->, so
+C<dec> is not available.
+
+=item B<append($string)>
+
+Append a string, like C<.=>.
+
+=item B<prepend($string)>
+
+Prepend a string.
+
+=item B<replace($pattern, $replacement)>
+
+Performs a regexp substitution (L<perlop/s>). There is no way to provide the
+C<g> flag, but code references will be accepted for the replacement, causing
+the regex to be modified with a single C<e>. C</smxi> can be applied using the
+C<qr> operator.
+
+=item B<match($pattern)>
+
+Like C<replace> but without the replacement. Provided mostly for completeness.
+
+=item B<chop>
+
+L<perlfunc/chop>
+
+=item B<chomp>
+
+L<perlfunc/chomp>
+
+=item B<clear>
+
+Sets the string to the empty string (not the value passed to C<default>).
+
+=item B<length>
+
+L<perlfunc/length>
+
+=item B<substr>
+
+L<perlfunc/substr>. We go to some lengths to match the different functionality
+based on C<substr>'s arity.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_provider>
+
+=item B<has_method_provider>
+
+=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
|| confess
'You must supply a delegate_to_method which is a method name or a CODE reference';
+ exists $options{curried_arguments}
+ || ( $options{curried_arguments} = [] );
+
+ ( $options{curried_arguments} &&
+ ( 'ARRAY' eq ref $options{curried_arguments} ) )
+ || confess 'You must supply a curried_arguments which is an ARRAY reference';
+
my $self = $class->_new( \%options );
weaken( $self->{'attribute'} );
return bless $options, $class;
}
+sub curried_arguments { (shift)->{'curried_arguments'} }
+
sub associated_attribute { (shift)->{'attribute'} }
sub delegate_to_method { (shift)->{'delegate_to_method'} }
object => $instance
);
}
-
- $proxy->$method_to_call(@_);
+ my @args = (@{ $self->curried_arguments }, @_);
+ $proxy->$method_to_call(@args);
};
}
The method in the associated attribute's value to which we
delegate. This can be either a method name or a code reference.
+=item I<curried_arguments>
+
+An array reference of arguments that will be prepended to the argument list for
+any call to the delegating method.
+
=back
=item B<< $metamethod->associated_attribute >>
Returns the attribute associated with this method.
+=item B<< $metamethod->curried_arguments >>
+
+Return any curried arguments that will be passed to the delegated method.
+
=item B<< $metamethod->delegate_to_method >>
Returns the method to which this method delegates, as passed to the
#####################################################################
#
# has 'roles' => (
-# metaclass => 'Collection::Array',
+# metaclass => 'Array',
# reader => 'get_roles',
# isa => 'ArrayRef[Moose::Meta::Role]',
# default => sub { [] },
# );
#
# has 'excluded_roles_map' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader => 'get_excluded_roles_map',
# isa => 'HashRef[Str]',
# provides => {
# );
#
# has 'attribute_map' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader => 'get_attribute_map',
# isa => 'HashRef[Str]',
# provides => {
# );
#
# has 'required_methods' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader => 'get_required_methods_map',
# isa => 'HashRef[Moose::Meta::Role::Method::Required]',
# provides => {
# # CODE refs to apply in that order
#
# has 'before_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader => 'get_before_method_modifiers_map',
# isa => 'HashRef[ArrayRef[CodeRef]]',
# provides => {
# );
#
# has 'after_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader =>'get_after_method_modifiers_map',
# isa => 'HashRef[ArrayRef[CodeRef]]',
# provides => {
# );
#
# has 'around_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader =>'get_around_method_modifiers_map',
# isa => 'HashRef[ArrayRef[CodeRef]]',
# provides => {
# # but instead just a single name->code mapping
#
# has 'override_method_modifiers' => (
-# metaclass => 'Collection::Hash',
+# metaclass => 'Hash',
# reader =>'get_override_method_modifiers_map',
# isa => 'HashRef[CodeRef]',
# provides => {
use strict;
use warnings;
-use Test::More tests => 91;
+use Test::More tests => 92;
use Test::Exception;
has 'foo' => (
is => 'rw',
default => sub { Foo->new },
- handles => { 'foo_bar' => 'bar', foo_baz => 'baz' }
+ handles => {
+ 'foo_bar' => 'bar',
+ foo_baz => 'baz',
+ 'foo_bar_to_20' => [ bar => 20 ],
+ },
);
}
is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+# curried handles
+$bar->foo_bar_to_20;
+is($bar->foo_bar, 20, '... correctly curried a single argument');
+
# -------------------------------------------------------------------
# ARRAY handles
# -------------------------------------------------------------------
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+use Moose ();
+BEGIN {
+ use_ok('Moose::Meta::Attribute::Native');
+ use_ok('Moose::Meta::Attribute::Native::Trait::Bool');
+ use_ok('Moose::Meta::Attribute::Native::Trait::Hash');
+ use_ok('Moose::Meta::Attribute::Native::Trait::Array');
+ use_ok('Moose::Meta::Attribute::Native::Trait::Counter');
+ use_ok('Moose::Meta::Attribute::Native::Trait::Number');
+ use_ok('Moose::Meta::Attribute::Native::Trait::String');
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+{
+ package Foo;
+ use Moose;
+
+ has 'bar' => ( is => 'rw' );
+
+ package Stuffed::Role;
+ use Moose::Role;
+
+ has 'options' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Foo]',
+ );
+
+ package Bulkie::Role;
+ use Moose::Role;
+
+ has 'stuff' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef',
+ handles => {
+ get_stuff => 'get',
+ }
+ );
+
+ package Stuff;
+ use Moose;
+
+ ::lives_ok{ with 'Stuffed::Role';
+ } '... this should work correctly';
+
+ ::lives_ok{ with 'Bulkie::Role';
+ } '... this should work correctly';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Moose;
+
+{
+ package MyHomePage;
+ use Moose;
+
+ has 'counter' => ( traits => ['Counter'] );
+}
+
+my $page = MyHomePage->new();
+isa_ok( $page, 'MyHomePage' );
+
+can_ok( $page, $_ ) for qw[
+ dec_counter
+ inc_counter
+ reset_counter
+];
+
+is( $page->counter, 0, '... got the default value' );
+
+$page->inc_counter;
+is( $page->counter, 1, '... got the incremented value' );
+
+$page->inc_counter;
+is( $page->counter, 2, '... got the incremented value (again)' );
+
+$page->dec_counter;
+is( $page->counter, 1, '... got the decremented value' );
+
+$page->reset_counter;
+is( $page->counter, 0, '... got the original value' );
+
+# check the meta ..
+
+my $counter = $page->meta->get_attribute('counter');
+does_ok( $counter, 'Moose::Meta::Attribute::Native::Trait::Counter' );
+
+is( $counter->type_constraint->name, 'Num',
+ '... got the expected default type constraint' );
+
+is_deeply(
+ $counter->handles,
+ {
+ 'inc_counter' => 'inc',
+ 'dec_counter' => 'dec',
+ 'reset_counter' => 'reset',
+ 'set_counter' => 'set',
+ },
+ '... got the right default handles methods'
+);
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+
+{
+ package MyHomePage;
+ use Moose;
+
+ has 'counter' => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Int',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ reset_counter => 'reset',
+ }
+ );
+}
+
+my $page = MyHomePage->new();
+isa_ok( $page, 'MyHomePage' );
+
+can_ok( $page, $_ ) for qw[
+ counter
+ dec_counter
+ inc_counter
+ reset_counter
+];
+
+lives_ok {
+ $page->meta->remove_attribute('counter');
+}
+'... removed the counter attribute okay';
+
+ok( !$page->meta->has_attribute('counter'),
+ '... no longer has the attribute' );
+
+ok( !$page->can($_), "... our class no longer has the $_ method" ) for qw[
+ counter
+ dec_counter
+ inc_counter
+ reset_counter
+];
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+
+{
+ package Subject;
+
+ use Moose::Role;
+
+ has observers => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Observer]',
+ auto_deref => 1,
+ default => sub { [] },
+ handles => {
+ 'add_observer' => 'push',
+ 'count_observers' => 'count',
+ },
+ );
+
+ sub notify {
+ my ($self) = @_;
+ foreach my $observer ( $self->observers() ) {
+ $observer->update($self);
+ }
+ }
+}
+
+{
+ package Observer;
+
+ use Moose::Role;
+
+ requires 'update';
+}
+
+{
+ package Counter;
+
+ use Moose;
+
+ with 'Subject';
+
+ has count => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Int',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ },
+ );
+
+ after qw(inc_counter dec_counter) => sub {
+ my ($self) = @_;
+ $self->notify();
+ };
+}
+
+{
+
+ package Display;
+
+ use Test::More;
+
+ use Moose;
+
+ with 'Observer';
+
+ sub update {
+ my ( $self, $subject ) = @_;
+ like $subject->count, qr{^-?\d+$},
+ 'Observed number ' . $subject->count;
+ }
+}
+
+package main;
+
+my $count = Counter->new();
+
+ok( $count->can('add_observer'), 'add_observer method added' );
+
+ok( $count->can('count_observers'), 'count_observers method added' );
+
+ok( $count->can('inc_counter'), 'inc_counter method added' );
+
+ok( $count->can('dec_counter'), 'dec_counter method added' );
+
+$count->add_observer( Display->new() );
+
+is( $count->count_observers, 1, 'Only one observer' );
+
+is( $count->count, 0, 'Default to zero' );
+
+$count->inc_counter;
+
+is( $count->count, 1, 'Increment to one ' );
+
+$count->inc_counter for ( 1 .. 6 );
+
+is( $count->count, 7, 'Increment up to seven' );
+
+$count->dec_counter;
+
+is( $count->count, 6, 'Decrement to 6' );
+
+$count->dec_counter for ( 1 .. 5 );
+
+is( $count->count, 1, 'Decrement to 1' );
+
+$count->dec_counter for ( 1 .. 2 );
+
+is( $count->count, -1, 'Negative numbers' );
+
+$count->inc_counter;
+
+is( $count->count, 0, 'Back to zero' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Moose 'does_ok';
+
+{
+ package MyHomePage;
+ use Moose;
+
+ has 'counter' => (
+ traits => ['Counter'],
+ is => 'ro',
+ isa => 'Int',
+ default => 0,
+ handles => {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ reset_counter => 'reset',
+ set_counter => 'set'
+ }
+ );
+}
+
+my $page = MyHomePage->new();
+isa_ok( $page, 'MyHomePage' );
+
+can_ok( $page, $_ ) for qw[
+ dec_counter
+ inc_counter
+ reset_counter
+ set_counter
+];
+
+is( $page->counter, 0, '... got the default value' );
+
+$page->inc_counter;
+is( $page->counter, 1, '... got the incremented value' );
+
+$page->inc_counter;
+is( $page->counter, 2, '... got the incremented value (again)' );
+
+$page->dec_counter;
+is( $page->counter, 1, '... got the decremented value' );
+
+$page->reset_counter;
+is( $page->counter, 0, '... got the original value' );
+
+$page->set_counter(5);
+is( $page->counter, 5, '... set the value' );
+
+$page->inc_counter(2);
+is( $page->counter, 7, '... increment by arg' );
+
+$page->dec_counter(5);
+is( $page->counter, 2, '... decrement by arg' );
+
+# check the meta ..
+
+my $counter = $page->meta->get_attribute('counter');
+does_ok( $counter, 'Moose::Meta::Attribute::Native::Trait::Counter' );
+
+is( $counter->type_constraint->name, 'Int',
+ '... got the expected type constraint' );
+
+is_deeply(
+ $counter->handles,
+ {
+ inc_counter => 'inc',
+ dec_counter => 'dec',
+ reset_counter => 'reset',
+ set_counter => 'set'
+ },
+ '... got the right handles methods'
+);
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 68;
+use Test::Exception;
+use Test::Moose 'does_ok';
+
+my $sort;
+
+{
+
+ package Stuff;
+ use Moose;
+
+ has 'options' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Str]',
+ default => sub { [] },
+ handles => {
+ 'add_options' => 'push',
+ 'remove_last_option' => 'pop',
+ 'remove_first_option' => 'shift',
+ 'insert_options' => 'unshift',
+ 'get_option_at' => 'get',
+ 'set_option_at' => 'set',
+ 'num_options' => 'count',
+ 'has_no_options' => 'is_empty',
+ 'clear_options' => 'clear',
+ 'splice_options' => 'splice',
+ 'sort_options_in_place' => 'sort_in_place',
+ 'option_accessor' => 'accessor',
+ 'add_options_with_speed' =>
+ [ 'push' => 'funrolls', 'funbuns' ],
+ 'prepend_prerequisites_along_with' =>
+ [ 'unshift' => 'first', 'second' ],
+ 'descending_options' =>
+ [ 'sort_in_place' => ($sort = sub { $_[1] <=> $_[0] }) ],
+ }
+ );
+}
+
+my $stuff = Stuff->new( options => [ 10, 12 ] );
+isa_ok( $stuff, 'Stuff' );
+
+can_ok( $stuff, $_ ) for qw[
+ add_options
+ remove_last_option
+ remove_first_option
+ insert_options
+ get_option_at
+ set_option_at
+ num_options
+ clear_options
+ has_no_options
+ sort_options_in_place
+ option_accessor
+];
+
+is_deeply( $stuff->options, [ 10, 12 ], '... got options' );
+
+ok( !$stuff->has_no_options, '... we have options' );
+is( $stuff->num_options, 2, '... got 2 options' );
+
+is( $stuff->remove_last_option, 12, '... removed the last option' );
+is( $stuff->remove_first_option, 10, '... removed the last option' );
+
+is_deeply( $stuff->options, [], '... no options anymore' );
+
+ok( $stuff->has_no_options, '... no options' );
+is( $stuff->num_options, 0, '... got no options' );
+
+lives_ok {
+ $stuff->add_options( 1, 2, 3 );
+}
+'... set the option okay';
+
+is_deeply( $stuff->options, [ 1, 2, 3 ], '... got options now' );
+
+ok( !$stuff->has_no_options, '... has options' );
+is( $stuff->num_options, 3, '... got 3 options' );
+
+is( $stuff->get_option_at(0), 1, '... get option at index 0' );
+is( $stuff->get_option_at(1), 2, '... get option at index 1' );
+is( $stuff->get_option_at(2), 3, '... get option at index 2' );
+
+lives_ok {
+ $stuff->set_option_at( 1, 100 );
+}
+'... set the option okay';
+
+is( $stuff->get_option_at(1), 100, '... get option at index 1' );
+
+lives_ok {
+ $stuff->add_options( 10, 15 );
+}
+'... set the option okay';
+
+is_deeply( $stuff->options, [ 1, 100, 3, 10, 15 ],
+ '... got more options now' );
+
+is( $stuff->num_options, 5, '... got 5 options' );
+
+is( $stuff->remove_last_option, 15, '... removed the last option' );
+
+is( $stuff->num_options, 4, '... got 4 options' );
+is_deeply( $stuff->options, [ 1, 100, 3, 10 ], '... got diff options now' );
+
+lives_ok {
+ $stuff->insert_options( 10, 20 );
+}
+'... set the option okay';
+
+is( $stuff->num_options, 6, '... got 6 options' );
+is_deeply( $stuff->options, [ 10, 20, 1, 100, 3, 10 ],
+ '... got diff options now' );
+
+is( $stuff->get_option_at(0), 10, '... get option at index 0' );
+is( $stuff->get_option_at(1), 20, '... get option at index 1' );
+is( $stuff->get_option_at(3), 100, '... get option at index 3' );
+
+is( $stuff->remove_first_option, 10, '... getting the first option' );
+
+is( $stuff->num_options, 5, '... got 5 options' );
+is( $stuff->get_option_at(0), 20, '... get option at index 0' );
+
+$stuff->clear_options;
+is_deeply( $stuff->options, [], "... clear options" );
+
+$stuff->add_options( 5, 1, 2, 3 );
+$stuff->sort_options_in_place;
+is_deeply( $stuff->options, [ 1, 2, 3, 5 ],
+ "... sort options in place (default sort order)" );
+
+$stuff->sort_options_in_place( sub { $_[1] <=> $_[0] } );
+is_deeply( $stuff->options, [ 5, 3, 2, 1 ],
+ "... sort options in place (descending order)" );
+
+$stuff->clear_options();
+$stuff->add_options( 5, 1, 2, 3 );
+lives_ok {
+ $stuff->descending_options();
+}
+'... curried sort in place lives ok';
+
+is_deeply( $stuff->options, [ 5, 3, 2, 1 ], "... sort currying" );
+
+throws_ok { $stuff->sort_options_in_place('foo') }
+qr/Argument must be a code reference/,
+ 'error when sort_in_place receives a non-coderef argument';
+
+$stuff->clear_options;
+
+lives_ok {
+ $stuff->add_options('tree');
+}
+'... set the options okay';
+
+lives_ok {
+ $stuff->add_options_with_speed( 'compatible', 'safe' );
+}
+'... add options with speed okay';
+
+is_deeply(
+ $stuff->options, [qw/tree funrolls funbuns compatible safe/],
+ 'check options after add_options_with_speed'
+);
+
+lives_ok {
+ $stuff->prepend_prerequisites_along_with();
+}
+'... add prerequisite options okay';
+
+$stuff->clear_options;
+$stuff->add_options( 1, 2 );
+
+lives_ok {
+ $stuff->splice_options( 1, 0, 'foo' );
+}
+'... splice_options works';
+
+is_deeply(
+ $stuff->options, [ 1, 'foo', 2 ],
+ 'splice added expected option'
+);
+
+is( $stuff->option_accessor( 1 => 'foo++' ), 'foo++' );
+is( $stuff->option_accessor(1), 'foo++' );
+
+## check some errors
+
+#dies_ok {
+# $stuff->insert_options(undef);
+#} '... could not add an undef where a string is expected';
+#
+#dies_ok {
+# $stuff->set_option(5, {});
+#} '... could not add a hash ref where a string is expected';
+
+dies_ok {
+ Stuff->new( options => [ undef, 10, undef, 20 ] );
+}
+'... bad constructor params';
+
+dies_ok {
+ my $stuff = Stuff->new();
+ $stuff->add_options(undef);
+}
+'... rejects push of an invalid type';
+
+dies_ok {
+ my $stuff = Stuff->new();
+ $stuff->insert_options(undef);
+}
+'... rejects unshift of an invalid type';
+
+dies_ok {
+ my $stuff = Stuff->new();
+ $stuff->set_option_at( 0, undef );
+}
+'... rejects set of an invalid type';
+
+dies_ok {
+ my $stuff = Stuff->new();
+ $stuff->sort_in_place_options(undef);
+}
+'... sort rejects arg of invalid type';
+
+dies_ok {
+ my $stuff = Stuff->new();
+ $stuff->option_accessor();
+}
+'... accessor rejects 0 args';
+
+dies_ok {
+ my $stuff = Stuff->new();
+ $stuff->option_accessor( 1, 2, 3 );
+}
+'... accessor rejects 3 args';
+
+## test the meta
+
+my $options = $stuff->meta->get_attribute('options');
+does_ok( $options, 'Moose::Meta::Attribute::Native::Trait::Array' );
+
+is_deeply(
+ $options->handles,
+ {
+ 'add_options' => 'push',
+ 'remove_last_option' => 'pop',
+ 'remove_first_option' => 'shift',
+ 'insert_options' => 'unshift',
+ 'get_option_at' => 'get',
+ 'set_option_at' => 'set',
+ 'num_options' => 'count',
+ 'has_no_options' => 'is_empty',
+ 'clear_options' => 'clear',
+ 'splice_options' => 'splice',
+ 'sort_options_in_place' => 'sort_in_place',
+ 'option_accessor' => 'accessor',
+ 'add_options_with_speed' => [ 'push' => 'funrolls', 'funbuns' ],
+ 'prepend_prerequisites_along_with' =>
+ [ 'unshift' => 'first', 'second' ],
+ 'descending_options' => [ 'sort_in_place' => $sort ],
+ },
+ '... got the right handles mapping'
+);
+
+is( $options->type_constraint->type_parameter, 'Str',
+ '... got the right container type' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 46;
+use Test::Exception;
+use Test::Moose 'does_ok';
+
+{
+ package Stuff;
+ use Moose;
+
+ has 'options' => (
+ traits => ['Hash'],
+ is => 'ro',
+ isa => 'HashRef[Str]',
+ default => sub { {} },
+ handles => {
+ 'set_option' => 'set',
+ 'get_option' => 'get',
+ 'has_no_options' => 'empty',
+ 'num_options' => 'count',
+ 'clear_options' => 'clear',
+ 'delete_option' => 'delete',
+ 'has_option' => 'exists',
+ 'is_defined' => 'defined',
+ 'option_accessor' => 'accessor',
+ 'key_value' => 'kv',
+ 'options_elements' => 'elements',
+ 'quantity' => [ accessor => 'quantity' ],
+ },
+ );
+}
+
+my $stuff = Stuff->new();
+isa_ok( $stuff, 'Stuff' );
+
+can_ok( $stuff, $_ ) for qw[
+ set_option
+ get_option
+ has_no_options
+ num_options
+ delete_option
+ clear_options
+ is_defined
+ has_option
+ quantity
+ option_accessor
+];
+
+ok( $stuff->has_no_options, '... we have no options' );
+is( $stuff->num_options, 0, '... we have no options' );
+
+is_deeply( $stuff->options, {}, '... no options yet' );
+ok( !$stuff->has_option('foo'), '... we have no foo option' );
+
+lives_ok {
+ $stuff->set_option( foo => 'bar' );
+}
+'... set the option okay';
+
+ok( $stuff->is_defined('foo'), '... foo is defined' );
+
+ok( !$stuff->has_no_options, '... we have options' );
+is( $stuff->num_options, 1, '... we have 1 option(s)' );
+ok( $stuff->has_option('foo'), '... we have a foo option' );
+is_deeply( $stuff->options, { foo => 'bar' }, '... got options now' );
+
+lives_ok {
+ $stuff->set_option( bar => 'baz' );
+}
+'... set the option okay';
+
+is( $stuff->num_options, 2, '... we have 2 option(s)' );
+is_deeply( $stuff->options, { foo => 'bar', bar => 'baz' },
+ '... got more options now' );
+
+is( $stuff->get_option('foo'), 'bar', '... got the right option' );
+
+is_deeply( [ $stuff->get_option(qw(foo bar)) ], [qw(bar baz)],
+ "get multiple options at once" );
+
+lives_ok {
+ $stuff->set_option( oink => "blah", xxy => "flop" );
+}
+'... set the option okay';
+
+is( $stuff->num_options, 4, "4 options" );
+is_deeply( [ $stuff->get_option(qw(foo bar oink xxy)) ],
+ [qw(bar baz blah flop)], "get multiple options at once" );
+
+lives_ok {
+ $stuff->delete_option('bar');
+}
+'... deleted the option okay';
+
+lives_ok {
+ $stuff->delete_option('oink');
+}
+'... deleted the option okay';
+
+lives_ok {
+ $stuff->delete_option('xxy');
+}
+'... deleted the option okay';
+
+is( $stuff->num_options, 1, '... we have 1 option(s)' );
+is_deeply( $stuff->options, { foo => 'bar' }, '... got more options now' );
+
+$stuff->clear_options;
+
+is_deeply( $stuff->options, {}, "... cleared options" );
+
+lives_ok {
+ $stuff->quantity(4);
+}
+'... options added okay with defaults';
+
+is( $stuff->quantity, 4, 'reader part of curried accessor works' );
+
+is_deeply( $stuff->options, { quantity => 4 }, '... returns what we expect' );
+
+lives_ok {
+ Stuff->new( options => { foo => 'BAR' } );
+}
+'... good constructor params';
+
+## check some errors
+
+dies_ok {
+ $stuff->set_option( bar => {} );
+}
+'... could not add a hash ref where an string is expected';
+
+dies_ok {
+ Stuff->new( options => { foo => [] } );
+}
+'... bad constructor params';
+
+## test the meta
+
+my $options = $stuff->meta->get_attribute('options');
+does_ok( $options, 'Moose::Meta::Attribute::Native::Trait::Hash' );
+
+is_deeply(
+ $options->handles,
+ {
+ 'set_option' => 'set',
+ 'get_option' => 'get',
+ 'has_no_options' => 'empty',
+ 'num_options' => 'count',
+ 'clear_options' => 'clear',
+ 'delete_option' => 'delete',
+ 'has_option' => 'exists',
+ 'is_defined' => 'defined',
+ 'option_accessor' => 'accessor',
+ 'key_value' => 'kv',
+ 'options_elements' => 'elements',
+ 'quantity' => [ accessor => 'quantity' ],
+ },
+ '... got the right handles mapping'
+);
+
+is( $options->type_constraint->type_parameter, 'Str',
+ '... got the right container type' );
+
+$stuff->set_option( oink => "blah", xxy => "flop" );
+my @key_value = $stuff->key_value;
+is_deeply(
+ \@key_value,
+ [ [ 'xxy', 'flop' ], [ 'quantity', 4 ], [ 'oink', 'blah' ] ],
+ '... got the right key value pairs'
+);
+
+my %options_elements = $stuff->options_elements;
+is_deeply(
+ \%options_elements,
+ {
+ 'oink' => 'blah',
+ 'quantity' => 4,
+ 'xxy' => 'flop'
+ },
+ '... got the right hash elements'
+);
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 25;
+use Test::Moose;
+
+{
+ package Real;
+ use Moose;
+
+ has 'integer' => (
+ traits => ['Number'],
+ is => 'ro',
+ isa => 'Int',
+ default => 5,
+ handles => {
+ set => 'set',
+ add => 'add',
+ sub => 'sub',
+ mul => 'mul',
+ div => 'div',
+ mod => 'mod',
+ abs => 'abs',
+ inc => [ add => 1 ],
+ dec => [ sub => 1 ],
+ odd => [ mod => 2 ],
+ cut_in_half => [ div => 2 ],
+
+ },
+ );
+}
+
+my $real = Real->new;
+isa_ok( $real, 'Real' );
+
+can_ok( $real, $_ ) for qw[
+ set add sub mul div mod abs inc dec odd cut_in_half
+];
+
+is $real->integer, 5, 'Default to five';
+
+$real->add(10);
+
+is $real->integer, 15, 'Add ten for fithteen';
+
+$real->sub(3);
+
+is $real->integer, 12, 'Subtract three for 12';
+
+$real->set(10);
+
+is $real->integer, 10, 'Set to ten';
+
+$real->div(2);
+
+is $real->integer, 5, 'divide by 2';
+
+$real->mul(2);
+
+is $real->integer, 10, 'multiplied by 2';
+
+$real->mod(2);
+
+is $real->integer, 0, 'Mod by 2';
+
+$real->set(7);
+
+$real->mod(5);
+
+is $real->integer, 2, 'Mod by 5';
+
+$real->set(-1);
+
+$real->abs;
+
+is $real->integer, 1, 'abs 1';
+
+$real->set(12);
+
+$real->inc;
+
+is $real->integer, 13, 'inc 12';
+
+$real->dec;
+
+is $real->integer, 12, 'dec 13';
+
+## test the meta
+
+my $attr = $real->meta->get_attribute('integer');
+does_ok( $attr, 'Moose::Meta::Attribute::Native::Trait::Number' );
+
+is_deeply(
+ $attr->handles,
+ {
+ set => 'set',
+ add => 'add',
+ sub => 'sub',
+ mul => 'mul',
+ div => 'div',
+ mod => 'mod',
+ abs => 'abs',
+ inc => [ add => 1 ],
+ dec => [ sub => 1 ],
+ odd => [ mod => 2 ],
+ cut_in_half => [ div => 2 ],
+ },
+ '... got the right handles mapping'
+);
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 31;
+use Test::Exception;
+use Test::Moose 'does_ok';
+
+my $sort;
+my $less;
+my $up;
+{
+ package Stuff;
+ use Moose;
+
+ has '_options' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Int]',
+ init_arg => 'options',
+ default => sub { [] },
+ handles => {
+ 'num_options' => 'count',
+ 'has_no_options' => 'is_empty',
+ 'map_options', => 'map',
+ 'filter_options' => 'grep',
+ 'find_option' => 'first',
+ 'options' => 'elements',
+ 'join_options' => 'join',
+ 'get_option_at' => 'get',
+ 'sorted_options' => 'sort',
+ 'less_than_five' => [ grep => ($less = sub { $_ < 5 }) ],
+ 'up_by_one' => [ map => ($up = sub { $_ + 1 }) ],
+ 'dashify' => [ join => '-' ],
+ 'descending' => [ sort => ($sort = sub { $_[1] <=> $_[0] }) ],
+ },
+ );
+
+}
+
+my $stuff = Stuff->new( options => [ 1 .. 10 ] );
+isa_ok( $stuff, 'Stuff' );
+
+can_ok( $stuff, $_ ) for qw[
+ _options
+ num_options
+ has_no_options
+ map_options
+ filter_options
+ find_option
+ options
+ join_options
+ get_option_at
+ sorted_options
+];
+
+is_deeply( $stuff->_options, [ 1 .. 10 ], '... got options' );
+
+ok( !$stuff->has_no_options, '... we have options' );
+is( $stuff->num_options, 10, '... got 2 options' );
+cmp_ok( $stuff->get_option_at(0), '==', 1, '... get option 0' );
+
+is_deeply(
+ [ $stuff->filter_options( sub { $_ % 2 == 0 } ) ],
+ [ 2, 4, 6, 8, 10 ],
+ '... got the right filtered values'
+);
+
+is_deeply(
+ [ $stuff->map_options( sub { $_ * 2 } ) ],
+ [ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ],
+ '... got the right mapped values'
+);
+
+is( $stuff->find_option( sub { $_ % 2 == 0 } ), 2,
+ '.. found the right option' );
+
+is_deeply( [ $stuff->options ], [ 1 .. 10 ], '... got the list of options' );
+
+is( $stuff->join_options(':'), '1:2:3:4:5:6:7:8:9:10',
+ '... joined the list of options by :' );
+
+is_deeply(
+ [ $stuff->sorted_options ], [ sort ( 1 .. 10 ) ],
+ '... got sorted options (default sort order)'
+);
+is_deeply(
+ [ $stuff->sorted_options( sub { $_[1] <=> $_[0] } ) ],
+ [ sort { $b <=> $a } ( 1 .. 10 ) ],
+ '... got sorted options (descending sort order) '
+);
+
+throws_ok { $stuff->sorted_options('foo') }
+qr/Argument must be a code reference/,
+ 'error when sort receives a non-coderef argument';
+
+# test the currying
+is_deeply( [ $stuff->less_than_five() ], [ 1 .. 4 ] );
+
+is_deeply( [ $stuff->up_by_one() ], [ 2 .. 11 ] );
+
+is( $stuff->dashify, '1-2-3-4-5-6-7-8-9-10' );
+
+is_deeply( [ $stuff->descending ], [ reverse 1 .. 10 ] );
+
+## test the meta
+
+my $options = $stuff->meta->get_attribute('_options');
+does_ok( $options, 'Moose::Meta::Attribute::Native::Trait::Array' );
+
+is_deeply(
+ $options->handles,
+ {
+ 'num_options' => 'count',
+ 'has_no_options' => 'is_empty',
+ 'map_options', => 'map',
+ 'filter_options' => 'grep',
+ 'find_option' => 'first',
+ 'options' => 'elements',
+ 'join_options' => 'join',
+ 'get_option_at' => 'get',
+ 'sorted_options' => 'sort',
+ 'less_than_five' => [ grep => $less ],
+ 'up_by_one' => [ map => $up ],
+ 'dashify' => [ join => '-' ],
+ 'descending' => [ sort => $sort ],
+ },
+ '... got the right handles mapping'
+);
+
+is( $options->type_constraint->type_parameter, 'Int',
+ '... got the right container type' );
+
+dies_ok {
+ $stuff->sort_in_place_options(undef);
+}
+'... sort rejects arg of invalid type';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 22;
+use Test::Moose 'does_ok';
+
+my $uc;
+{
+ package MyHomePage;
+ use Moose;
+
+ has 'string' => (
+ traits => ['String'],
+ is => 'rw',
+ isa => 'Str',
+ default => sub {''},
+ handles => {
+ inc_string => 'inc',
+ append_string => 'append',
+ prepend_string => 'prepend',
+ match_string => 'match',
+ replace_string => 'replace',
+ chop_string => 'chop',
+ chomp_string => 'chomp',
+ clear_string => 'clear',
+ length_string => 'length',
+ exclaim => [ append => '!' ],
+ capitalize_last => [ replace => qr/(.)$/, ($uc = sub { uc $1 }) ],
+ invalid_number => [ match => qr/\D/ ],
+ },
+ );
+}
+
+my $page = MyHomePage->new();
+isa_ok( $page, 'MyHomePage' );
+
+is( $page->string, '', '... got the default value' );
+is( $page->length_string, 0,'... length is zero' );
+
+$page->string('a');
+is( $page->length_string, 1,'... new string has length of one' );
+
+$page->inc_string;
+is( $page->string, 'b', '... got the incremented value' );
+
+$page->inc_string;
+is( $page->string, 'c', '... got the incremented value (again)' );
+
+$page->append_string("foo$/");
+is( $page->string, "cfoo$/", 'appended to string' );
+
+$page->chomp_string;
+is( $page->string, "cfoo", 'chomped string' );
+
+$page->chomp_string;
+is( $page->string, "cfoo", 'chomped is noop' );
+
+$page->chop_string;
+is( $page->string, "cfo", 'chopped string' );
+
+$page->prepend_string("bar");
+is( $page->string, 'barcfo', 'prepended to string' );
+
+is_deeply( [ $page->match_string(qr/([ao])/) ], ["a"], "match" );
+
+$page->replace_string( qr/([ao])/, sub { uc($1) } );
+is( $page->string, 'bArcfo', "substitution" );
+is( $page->length_string, 6, 'right length' );
+
+$page->exclaim;
+is( $page->string, 'bArcfo!', 'exclaim!' );
+
+$page->string('Moosex');
+$page->capitalize_last;
+is( $page->string, 'MooseX', 'capitalize last' );
+
+$page->string('1234');
+ok( !$page->invalid_number, 'string "isn\'t an invalid number' );
+
+$page->string('one two three four');
+ok( $page->invalid_number, 'string an invalid number' );
+
+$page->clear_string;
+is( $page->string, '', "clear" );
+
+# check the meta ..
+
+my $string = $page->meta->get_attribute('string');
+does_ok( $string, 'Moose::Meta::Attribute::Native::Trait::String' );
+
+is(
+ $string->type_constraint->name, 'Str',
+ '... got the expected type constraint'
+);
+
+is_deeply(
+ $string->handles,
+ {
+ inc_string => 'inc',
+ append_string => 'append',
+ prepend_string => 'prepend',
+ match_string => 'match',
+ replace_string => 'replace',
+ chop_string => 'chop',
+ chomp_string => 'chomp',
+ clear_string => 'clear',
+ length_string => 'length',
+ exclaim => [ append => '!' ],
+ capitalize_last => [ replace => qr/(.)$/, $uc ],
+ invalid_number => [ match => qr/\D/ ],
+ },
+ '... got the right handles methods'
+);
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+{
+ package Room;
+ use Moose;
+
+ has 'is_lit' => (
+ traits => ['Bool'],
+ is => 'rw',
+ isa => 'Bool',
+ default => 0,
+ handles => {
+ illuminate => 'set',
+ darken => 'unset',
+ flip_switch => 'toggle',
+ is_dark => 'not',
+ },
+ )
+}
+
+my $room = Room->new;
+$room->illuminate;
+ok( $room->is_lit, 'set is_lit to 1 using ->illuminate' );
+ok( !$room->is_dark, 'check if is_dark does the right thing' );
+
+$room->darken;
+ok( !$room->is_lit, 'set is_lit to 0 using ->darken' );
+ok( $room->is_dark, 'check if is_dark does the right thing' );
+
+$room->flip_switch;
+ok( $room->is_lit, 'toggle is_lit back to 1 using ->flip_switch' );
+ok( !$room->is_dark, 'check if is_dark does the right thing' );
+
+$room->flip_switch;
+ok( !$room->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' );
+ok( $room->is_dark, 'check if is_dark does the right thing' );
+
attach_to_class
)
],
+ 'Moose::Meta::Attribute::Native::MethodProvider::Array' => ['.+'],
+ 'Moose::Meta::Attribute::Native::MethodProvider::Bool' => ['.+'],
+ 'Moose::Meta::Attribute::Native::MethodProvider::Counter' => ['.+'],
+ 'Moose::Meta::Attribute::Native::MethodProvider::Hash' => ['.+'],
+ 'Moose::Meta::Attribute::Native::MethodProvider::String' => ['.+'],
'Moose::Meta::Class' => [
qw( check_metaclass_compatibility
construct_instance
Debolaz
Deltac
dexter
+doy
ewilhelm
+frodwith
Goulah
gphat
groditi
Kogman
kolibrie
konobi
+Lanyon
lbr
+Luehrs
McWhirter
merlyn
mst
Prather
Ragwitz
Reis
+rafl
rindolf
rlb
Rockway
SVN
## Moose
+AttributeHelpers
BankAccount
BankAccount's
BinaryTree
committers
compat
datetimes
+dec
definedness
destructor
destructors
irc
IRC
isa
+kv
login
+mul
namespace
namespaced
namespaces
projects / gitmo/Moose.git / commitdiff