From: Hans Dieter Pearcey Date: Wed, 8 Jul 2009 15:11:19 +0000 (-0400) Subject: Merge branch 'master' into attribute_helpers X-Git-Tag: 0.89_02~96 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6f94c802188d44415bafdd64422cecd24585a289;hp=ee78c083685c0d187fe5e05544d19026825d6df2;p=gitmo%2FMoose.git Merge branch 'master' into attribute_helpers Conflicts: Changes lib/Moose/Meta/Method/Delegation.pm t/020_attributes/010_attribute_delegation.t --- diff --git a/Changes b/Changes index e11a9e2..7a5fb8f 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,15 @@ Also see Moose::Manual::Delta for more details of, and workarounds for, noteworthy changes. +0.88 + * Moose::Meta::Attribute + - Added the currying syntax for delegation from AttributeHelpers + to the existing delegation API. (hdp) + + * Moose::AttributeHelpers + - Moved in from MooseX with API tweaks. See Moose::Manual::Delta for + details. (hdp, jhannah, rbuels) + 0.87 Tue Jul 7, 2009 * Moose::Meta::Method::Delegation - Once again allow class names as well as objects for diff --git a/lib/Moose.pm b/lib/Moose.pm index fd1ed02..f98cdea 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -538,6 +538,18 @@ In this example, the Tree package gets C and C methods, which delegate to the C and C methods (respectively) of the Tree instance stored in the C 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 +second is an array reference of curried arguments. + =item C The regexp option works very similar to the ARRAY option, except that it builds diff --git a/lib/Moose/AttributeHelpers.pm b/lib/Moose/AttributeHelpers.pm new file mode 100644 index 0000000..da66cb9 --- /dev/null +++ b/lib/Moose/AttributeHelpers.pm @@ -0,0 +1,172 @@ + +package Moose::AttributeHelpers; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose; + +use Moose::AttributeHelpers::Trait::Bool; +use Moose::AttributeHelpers::Trait::Counter; +use Moose::AttributeHelpers::Trait::Number; +use Moose::AttributeHelpers::Trait::String; +use Moose::AttributeHelpers::Trait::Collection::List; +use Moose::AttributeHelpers::Trait::Collection::Array; +use Moose::AttributeHelpers::Trait::Collection::Hash; +use Moose::AttributeHelpers::Trait::Collection::ImmutableHash; +use Moose::AttributeHelpers::Trait::Collection::Bag; + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers - Extend your attribute interfaces + +=head1 SYNOPSIS + + package MyClass; + use Moose; + use Moose::AttributeHelpers; + + has 'mapping' => ( + traits => [ 'Collection::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 attributes provide you with 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, you specify the extension via the +C parameter. Available meta classes are below; see L. + +This module used to exist as the L 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 extension. + +=head1 PARAMETERS + +=head2 handles + +This is like C<< handles >> in L, 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 + +Common numerical operations. + +=item L + +Common methods for string operations. + +=item L + +Methods for incrementing and decrementing a counter attribute. + +=item L + +Common methods for boolean values. + +=item L + +Common methods for hash references. + +=item L + +Common methods for inspecting hash references. + +=item L + +Common methods for array references. + +=item L + +Common list methods for array references. + +=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 Estevan@iinteractive.comE + +B + +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 + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/MethodProvider/Array.pm b/lib/Moose/AttributeHelpers/MethodProvider/Array.pm new file mode 100644 index 0000000..bae6f73 --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/Array.pm @@ -0,0 +1,325 @@ +package Moose::AttributeHelpers::MethodProvider::Array; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'Moose::AttributeHelpers::MethodProvider::List'; + +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::AttributeHelpers::MethodProvider::Array + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +This module also consumes the B method providers, to +see those provided methods, refer to that documentation. + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +Sorts the array I, modifying the value of the attribute. + +You can provide an optional subroutine reference to sort with (as you +can with the core C function). However, instead of using C<$a> +and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. + +=item B + +If passed one argument, returns the value of the requested element. +If passed two arguments, sets the value of the requested element. + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/MethodProvider/Bag.pm b/lib/Moose/AttributeHelpers/MethodProvider/Bag.pm new file mode 100644 index 0000000..37e10ff --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/Bag.pm @@ -0,0 +1,97 @@ +package Moose::AttributeHelpers::MethodProvider::Bag; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'Moose::AttributeHelpers::MethodProvider::ImmutableHash'; + +sub add : method { + my ( $attr, $reader, $writer ) = @_; + return sub { $reader->( $_[0] )->{ $_[1] }++ }; +} + +sub delete : method { + my ( $attr, $reader, $writer ) = @_; + return sub { CORE::delete $reader->( $_[0] )->{ $_[1] } }; +} + +sub reset : method { + my ( $attr, $reader, $writer ) = @_; + return sub { $reader->( $_[0] )->{ $_[1] } = 0 }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::MethodProvider::Bag + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +This role is composed from the +L role. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Moose/AttributeHelpers/MethodProvider/Bool.pm b/lib/Moose/AttributeHelpers/MethodProvider/Bool.pm new file mode 100644 index 0000000..fde5f3b --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/Bool.pm @@ -0,0 +1,85 @@ + +package Moose::AttributeHelpers::MethodProvider::Bool; +use Moose::Role; + +our $VERSION = '0.85'; +$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::AttributeHelpers::MethodProvider::Bool + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=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 Ejason.a.may@gmail.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/MethodProvider/Counter.pm b/lib/Moose/AttributeHelpers/MethodProvider/Counter.pm new file mode 100644 index 0000000..957c039 --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/Counter.pm @@ -0,0 +1,91 @@ + +package Moose::AttributeHelpers::MethodProvider::Counter; +use Moose::Role; + +our $VERSION = '0.85'; +$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::AttributeHelpers::MethodProvider::Counter + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/MethodProvider/Hash.pm b/lib/Moose/AttributeHelpers/MethodProvider/Hash.pm new file mode 100644 index 0000000..927871a --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/Hash.pm @@ -0,0 +1,221 @@ +package Moose::AttributeHelpers::MethodProvider::Hash; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'Moose::AttributeHelpers::MethodProvider::ImmutableHash'; + +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::AttributeHelpers::MethodProvider::Hash + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +This role is composed from the +L role. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +Returns the number of elements in the hash. + +=item B + +Removes the element with the given key + +=item B + +Returns true if the value of a given key is defined + +=item B + +If the list is populated, returns true. Otherwise, returns false. + +=item B + +Unsets the hash entirely. + +=item B + +Returns true if the given key is present in the hash + +=item B + +Returns an element of the hash by its key. + +=item B + +Returns the list of keys in the hash. + +=item B + +Sets the element in the hash at the given key to the given value. + +=item B + +Returns the list of values in the hash. + +=item B + +Returns the key, value pairs in the hash + +=item B + +If passed one argument, returns the value of the requested key. If passed two +arguments, sets the value of the requested key. + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Moose/AttributeHelpers/MethodProvider/ImmutableHash.pm b/lib/Moose/AttributeHelpers/MethodProvider/ImmutableHash.pm new file mode 100644 index 0000000..cb9caec --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/ImmutableHash.pm @@ -0,0 +1,152 @@ +package Moose::AttributeHelpers::MethodProvider::ImmutableHash; +use Moose::Role; + +our $VERSION = '0.85'; +$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] ) } ? 1 : 0 }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::MethodProvider::ImmutableHash + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +Returns the number of elements in the list. + +=item B + +If the list is populated, returns true. Otherwise, returns false. + +=item B + +Returns true if the given key is present in the hash + +=item B + +Returns true if the value of a given key is defined + +=item B + +Returns an element of the hash by its key. + +=item B + +Returns the list of keys in the hash. + +=item B + +Returns the list of values in the hash. + +=item B + +Returns the key, value pairs in the hash as array references + +=item B + +Returns the key, value pairs in the hash as a flattened list + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Moose/AttributeHelpers/MethodProvider/List.pm b/lib/Moose/AttributeHelpers/MethodProvider/List.pm new file mode 100644 index 0000000..dc0b0fd --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/List.pm @@ -0,0 +1,274 @@ +package Moose::AttributeHelpers::MethodProvider::List; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +sub count : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + scalar @{ $reader->( $_[0] ) }; + }; +} + +sub empty : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + scalar @{ $reader->( $_[0] ) } ? 1 : 0; + }; +} + +sub find : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + my ( $instance, $predicate ) = @_; + foreach my $val ( @{ $reader->($instance) } ) { + return $val if $predicate->($val); + } + return; + }; +} + +sub map : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + my ( $instance, $f ) = @_; + CORE::map { $f->($_) } @{ $reader->($instance) }; + }; +} + +sub sort : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + my ( $instance, $predicate ) = @_; + die "Argument must be a code reference" + if $predicate && ref $predicate ne 'CODE'; + + if ($predicate) { + CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) }; + } + else { + CORE::sort @{ $reader->($instance) }; + } + }; +} + +sub grep : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + my ( $instance, $predicate ) = @_; + CORE::grep { $predicate->($_) } @{ $reader->($instance) }; + }; +} + +sub elements : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + my ($instance) = @_; + @{ $reader->($instance) }; + }; +} + +sub join : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + my ( $instance, $separator ) = @_; + join $separator, @{ $reader->($instance) }; + }; +} + +sub get : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + $reader->( $_[0] )->[ $_[1] ]; + }; +} + +sub first : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + $reader->( $_[0] )->[0]; + }; +} + +sub last : method { + my ( $attr, $reader, $writer ) = @_; + return sub { + $reader->( $_[0] )->[-1]; + }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::MethodProvider::List + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'options' => ( + metaclass => 'Collection::List', + is => 'rw', + isa => 'ArrayRef[Str]', + default => sub { [] }, + auto_deref => 1, + handles => { + all_options => 'elements', + map_options => 'map', + filter_options => 'grep', + find_option => 'find', + first_option => 'first', + last_option => 'last', + get_option => 'get', + join_options => 'join', + count_options => 'count', + do_i_have_options => 'empty', + sorted_options => 'sort', + } + ); + + no Moose; + 1; + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +Returns the number of elements in the list. + + $stuff = Stuff->new; + $stuff->options(["foo", "bar", "baz", "boo"]); + + my $count = $stuff->count_options; + print "$count\n"; # prints 4 + +=item B + +If the list is populated, returns true. Otherwise, returns false. + + $stuff->do_i_have_options ? print "Good boy.\n" : die "No options!\n" ; + +=item B + +This method accepts a subroutine reference as its argument. That sub +will receive each element of the list in turn. If it returns true for +an element, that element will be returned by the C method. + + my $found = $stuff->find_option( sub { $_[0] =~ /^b/ } ); + print "$found\n"; # prints "bar" + +=item B + +This method accepts a subroutine reference as its argument. This +method returns every element for which that subroutine reference +returns a true value. + + my @found = $stuff->filter_options( sub { $_[0] =~ /^b/ } ); + print "@found\n"; # prints "bar baz boo" + +=item B + +This method accepts a subroutine reference as its argument. The +subroutine will be executed for each element of the list. It is +expected to return a modified version of that element. The return +value of the method is a list of the modified options. + + my @mod_options = $stuff->map_options( sub { $_[0] . "-tag" } ); + print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" + +=item B + +Sorts and returns the elements of the list. + +You can provide an optional subroutine reference to sort with (as you +can with the core C 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 + +Returns all of the elements of the list + + my @option = $stuff->all_options; + print "@options\n"; # prints "foo bar baz boo" + +=item B + +Joins every element of the list using the separator given as argument. + + my $joined = $stuff->join_options( ':' ); + print "$joined\n"; # prints "foo:bar:baz:boo" + +=item B + +Returns an element of the list by its index. + + my $option = $stuff->get_option(1); + print "$option\n"; # prints "bar" + +=item B + +Returns the first element of the list. + + my $first = $stuff->first_option; + print "$first\n"; # prints "foo" + +=item B + +Returns the last element of the list. + + my $last = $stuff->last_option; + print "$last\n"; # prints "boo" + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/MethodProvider/String.pm b/lib/Moose/AttributeHelpers/MethodProvider/String.pm new file mode 100644 index 0000000..655ad65 --- /dev/null +++ b/lib/Moose/AttributeHelpers/MethodProvider/String.pm @@ -0,0 +1,165 @@ + +package Moose::AttributeHelpers::MethodProvider::String; +use Moose::Role; + +our $VERSION = '0.85'; +$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 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::AttributeHelpers::MethodProvider::String + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Base.pm b/lib/Moose/AttributeHelpers/Trait/Base.pm new file mode 100644 index 0000000..07f19c1 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Base.pm @@ -0,0 +1,168 @@ + +package Moose::AttributeHelpers::Trait::Base; +use Moose::Role; +use Moose::Util::TypeConstraints; + +our $VERSION = '0.85'; +$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; + + $curried_args ||= []; + + 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::AttributeHelpers::Trait::Base - 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 + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Bool.pm b/lib/Moose/AttributeHelpers/Trait/Bool.pm new file mode 100644 index 0000000..05bbc81 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Bool.pm @@ -0,0 +1,126 @@ +package Moose::AttributeHelpers::Trait::Bool; +use Moose::Role; +use Moose::AttributeHelpers::MethodProvider::Bool; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'Moose::AttributeHelpers::Trait::Base'; + +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::AttributeHelpers::MethodProvider::Bool' +); + +no Moose::Role; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Bool; +sub register_implementation { 'Moose::AttributeHelpers::Trait::Bool' } + +1; + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Bool + +=head1 SYNOPSIS + + package Room; + use Moose; + use Moose::AttributeHelpers; + + has 'is_lit' => ( + metaclass => '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 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 PROVIDED METHODS + +It is important to note that all those methods do in place +modification of the value stored in the attribute. + +=over 4 + +=item I + +Sets the value to C<1>. + +=item I + +Set the value to C<0>. + +=item I + +Toggle the value. If it's true, set to false, and vice versa. + +=item I + +Equivalent of 'not C<$value>'. + +=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 + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Collection.pm b/lib/Moose/AttributeHelpers/Trait/Collection.pm new file mode 100644 index 0000000..0d4de4b --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Collection.pm @@ -0,0 +1,62 @@ + +package Moose::AttributeHelpers::Trait::Collection; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'Moose::AttributeHelpers::Trait::Base'; + +no Moose::Role; + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Collection - Base class for all collection type helpers + +=head1 DESCRIPTION + +Documentation to come. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Collection/Array.pm b/lib/Moose/AttributeHelpers/Trait/Collection/Array.pm new file mode 100644 index 0000000..5642ba4 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Collection/Array.pm @@ -0,0 +1,95 @@ + +package Moose::AttributeHelpers::Trait::Collection::Array; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::Array; + +with 'Moose::AttributeHelpers::Trait::Collection'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::MethodProvider::Array' +); + +sub _helper_type { 'ArrayRef' } + +no Moose::Role; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Collection::Array; +sub register_implementation { + 'Moose::AttributeHelpers::Trait::Collection::Array' +} + + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Collection::Array + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'options' => ( + metaclass => 'Collection::Array', + is => 'ro', + isa => 'ArrayRef[Int]', + default => sub { [] }, + handles => { + add_options => 'push', + remove_last_option => 'pop', + } + ); + +=head1 DESCRIPTION + +This module provides an Array attribute which provides a number of +array operations. See L +for more details. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Collection/Bag.pm b/lib/Moose/AttributeHelpers/Trait/Collection/Bag.pm new file mode 100644 index 0000000..9c697e3 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Collection/Bag.pm @@ -0,0 +1,102 @@ + +package Moose::AttributeHelpers::Trait::Collection::Bag; +use Moose::Role; +use Moose::Util::TypeConstraints; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::Bag; + +with 'Moose::AttributeHelpers::Trait::Collection'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::MethodProvider::Bag' +); + +subtype 'Bag' => as 'HashRef[Int]'; + +sub _helper_type { 'Bag' } + +sub _default_default { sub { {} } } + +no Moose::Role; +no Moose::Util::TypeConstraints; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Collection::Bag; +sub register_implementation { + 'Moose::AttributeHelpers::Trait::Collection::Bag' +} + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Collection::Bag + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'word_histogram' => ( + metaclass => 'Collection::Bag', + is => 'ro', + isa => 'Bag', # optional ... as is defalt + handles => { + add_word => 'add', + get_count_for => 'get', + has_any_words => 'empty', + num_words => 'count', + delete_word => 'delete', + } + ); + +=head1 DESCRIPTION + +This module provides a Bag attribute which provides a number of +bag-like operations. See L +for more details. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Collection/Hash.pm b/lib/Moose/AttributeHelpers/Trait/Collection/Hash.pm new file mode 100644 index 0000000..215169e --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Collection/Hash.pm @@ -0,0 +1,98 @@ + +package Moose::AttributeHelpers::Trait::Collection::Hash; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::Hash; + +with 'Moose::AttributeHelpers::Trait::Collection'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::MethodProvider::Hash' +); + +sub _helper_type { 'HashRef' } + +no Moose::Role; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Collection::Hash; +sub register_implementation { + 'Moose::AttributeHelpers::Trait::Collection::Hash' +} + + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Collection::Hash + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'options' => ( + metaclass => 'Collection::Hash', + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + set_option => 'set', + get_option => 'get', + has_options => 'empty', + num_options => 'count', + delete_option => 'delete', + } + ); + +=head1 DESCRIPTION + +This module provides a Hash attribute which provides a number of +hash-like operations. See L +for more details. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Collection/ImmutableHash.pm b/lib/Moose/AttributeHelpers/Trait/Collection/ImmutableHash.pm new file mode 100644 index 0000000..bc5daf2 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Collection/ImmutableHash.pm @@ -0,0 +1,96 @@ + +package Moose::AttributeHelpers::Trait::Collection::ImmutableHash; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::ImmutableHash; + +with 'Moose::AttributeHelpers::Trait::Collection'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::MethodProvider::ImmutableHash' +); + +sub _helper_type { 'HashRef' } + +no Moose::Role; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Collection::ImmutableHash; +sub register_implementation { + 'Moose::AttributeHelpers::Trait::Collection::ImmutableHash' +} + + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Collection::ImmutableHash + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'options' => ( + metaclass => 'Collection::ImmutableHash', + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + get_option => 'get', + has_options => 'empty', + get_option_list => 'keys', + } + ); + +=head1 DESCRIPTION + +This module provides a immutable HashRef attribute which provides a number of +hash-line operations. See L +for more details. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Collection/List.pm b/lib/Moose/AttributeHelpers/Trait/Collection/List.pm new file mode 100644 index 0000000..a3e1713 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Collection/List.pm @@ -0,0 +1,95 @@ + +package Moose::AttributeHelpers::Trait::Collection::List; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::List; + +with 'Moose::AttributeHelpers::Trait::Collection'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::MethodProvider::List' +); + +sub _helper_type { 'ArrayRef' } + +no Moose::Role; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Collection::List; +sub register_implementation { + 'Moose::AttributeHelpers::Trait::Collection::List' +} + + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Collection::List + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'options' => ( + metaclass => 'Collection::List', + is => 'ro', + isa => 'ArrayRef[Int]', + default => sub { [] }, + handles => { + map_options => 'map', + filter_options => 'grep', + } + ); + +=head1 DESCRIPTION + +This module provides an List attribute which provides a number of +list operations. See L +for more details. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Counter.pm b/lib/Moose/AttributeHelpers/Trait/Counter.pm new file mode 100644 index 0000000..118cd9f --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Counter.pm @@ -0,0 +1,149 @@ + +package Moose::AttributeHelpers::Trait::Counter; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::Counter; + +with 'Moose::AttributeHelpers::Trait::Base'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::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; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Counter; +sub register_implementation { 'Moose::AttributeHelpers::Trait::Counter' } + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Counter + +=head1 SYNOPSIS + + package MyHomePage; + use Moose; + use Moose::AttributeHelpers; + + has 'counter' => ( + metaclass => '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, I, +I or I but does use the C metaclass, +then this module applies defaults as in the L +above. This allows for a very basic counter definition: + + has 'foo' => (metaclass => 'Counter'); + $obj->inc_foo; + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 PROVIDED METHODS + +It is important to note that all those methods do in place +modification of the value stored in the attribute. + +=over 4 + +=item I + +Set the counter to the specified value. + +=item I + +Increments the value stored in this slot by 1. Providing an argument will +cause the counter to be increased by specified amount. + +=item I + +Decrements the value stored in this slot by 1. Providing an argument will +cause the counter to be increased by specified amount. + +=item I + +Resets the value stored in this slot to it's default value. + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/Number.pm b/lib/Moose/AttributeHelpers/Trait/Number.pm new file mode 100644 index 0000000..7225b94 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/Number.pm @@ -0,0 +1,164 @@ +package Moose::AttributeHelpers::Trait::Number; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'Moose::AttributeHelpers::Trait::Base'; + +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; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::Number; +sub register_implementation { 'Moose::AttributeHelpers::Trait::Number' } + +1; + +=pod + +=head1 NAME + +Moose::AttributeHelpers::Number + +=head1 SYNOPSIS + + package Real; + use Moose; + use Moose::AttributeHelpers; + + 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 METHODS + +=over 4 + +=item B + +=item B + +=back + +=head1 PROVIDED METHODS + +It is important to note that all those methods do in place +modification of the value stored in the attribute. + +=over 4 + +=item I + +Alternate way to set the value. + +=item I + +Adds the current value of the attribute to C<$value>. + +=item I + +Subtracts the current value of the attribute to C<$value>. + +=item I + +Multiplies the current value of the attribute to C<$value>. + +=item I
+ +Divides the current value of the attribute to C<$value>. + +=item I + +Modulus the current value of the attribute to C<$value>. + +=item I + +Sets the current value of the attribute to its absolute value. + +=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 + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/AttributeHelpers/Trait/String.pm b/lib/Moose/AttributeHelpers/Trait/String.pm new file mode 100644 index 0000000..fc9e0b0 --- /dev/null +++ b/lib/Moose/AttributeHelpers/Trait/String.pm @@ -0,0 +1,166 @@ + +package Moose::AttributeHelpers::Trait::String; +use Moose::Role; + +our $VERSION = '0.85'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +use Moose::AttributeHelpers::MethodProvider::String; + +with 'Moose::AttributeHelpers::Trait::Base'; + +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', + default => 'Moose::AttributeHelpers::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; + +package # hide me from search.cpan.org + Moose::Meta::Attribute::Custom::Trait::String; +sub register_implementation { 'Moose::AttributeHelpers::Trait::String' } + +1; + +__END__ + +=pod + +=head1 NAME + +Moose::AttributeHelpers::String + +=head1 SYNOPSIS + + package MyHomePage; + use Moose; + use Moose::AttributeHelpers; + + has 'text' => ( + metaclass => '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, I, +I or I but does use the C metaclass, +then this module applies defaults as in the L +above. This allows for a very basic counter definition: + + has 'foo' => (metaclass => 'String'); + $obj->append_foo; + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 PROVIDED METHODS + +It is important to note that all those methods do in place +modification of the value stored in the attribute. + +=over 4 + +=item I + +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 is not available. + +=item I C<$string> + +Append a string, like C<.=>. + +=item I C<$string> + +Prepend a string. + +=item I C<$pattern> C<$replacement> + +Performs a regexp substitution (L). There is no way to provide the +C flag, but code references will be accepted for the replacement, causing +the regex to be modified with a single C. C can be applied using the +C operator. + +=item I C<$pattern> + +Like I but without the replacement. Provided mostly for completeness. + +=item C + +L + +=item C + +L + +=item C + +Sets the string to the empty string (not the value passed to C). + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007-2009 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Moose/Manual/Delta.pod b/lib/Moose/Manual/Delta.pod index 470bf50..4cfe14a 100644 --- a/lib/Moose/Manual/Delta.pod +++ b/lib/Moose/Manual/Delta.pod @@ -16,6 +16,34 @@ feature. If you encounter a problem and have a solution but don't see it documented here, or think we missed an important feature, please send us a patch. +=head1 Version 0.85 + +L has been moved into the Moose core from +L. Major changes include: + +=over + +=item C, not C + +Method providers are only available via traits. + +=item C, not C or C + +The C 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 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). + +=back + +See L for the new documentation. + =head1 Version 0.84 The C type has been deprecated. On its own, it was useless, diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index e6d9990..f7a0e34 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -40,6 +40,7 @@ __PACKAGE__->meta->add_attribute('trigger' => ( )); __PACKAGE__->meta->add_attribute('handles' => ( reader => 'handles', + writer => '_set_handles', predicate => 'has_handles', )); __PACKAGE__->meta->add_attribute('documentation' => ( @@ -730,11 +731,17 @@ sub _make_delegation_method { $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 || [], ); } diff --git a/lib/Moose/Meta/Method/Delegation.pm b/lib/Moose/Meta/Method/Delegation.pm index 870d362..f353161 100644 --- a/lib/Moose/Meta/Method/Delegation.pm +++ b/lib/Moose/Meta/Method/Delegation.pm @@ -36,6 +36,13 @@ sub new { || 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'} ); @@ -52,6 +59,8 @@ sub _new { return bless $options, $class; } +sub curried_arguments { (shift)->{'curried_arguments'} } + sub associated_attribute { (shift)->{'attribute'} } sub delegate_to_method { (shift)->{'delegate_to_method'} } @@ -95,8 +104,8 @@ sub _initialize_body { object => $instance ); } - - $proxy->$method_to_call(@_); + my @args = (@{ $self->curried_arguments }, @_); + $proxy->$method_to_call(@args); }; } @@ -145,12 +154,21 @@ accessor is being generated for. This options is B. 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 + +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 diff --git a/t/020_attributes/010_attribute_delegation.t b/t/020_attributes/010_attribute_delegation.t index a47d7a7..e3a5f0a 100644 --- a/t/020_attributes/010_attribute_delegation.t +++ b/t/020_attributes/010_attribute_delegation.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 91; +use Test::More tests => 92; use Test::Exception; @@ -29,7 +29,11 @@ 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 ] ], + }, ); } @@ -83,6 +87,10 @@ is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); 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 # ------------------------------------------------------------------- diff --git a/t/070_attribute_helpers/000_load.t b/t/070_attribute_helpers/000_load.t new file mode 100644 index 0000000..d876957 --- /dev/null +++ b/t/070_attribute_helpers/000_load.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('Moose::AttributeHelpers'); +} \ No newline at end of file diff --git a/t/070_attribute_helpers/010_array_from_role.t b/t/070_attribute_helpers/010_array_from_role.t new file mode 100644 index 0000000..b647a98 --- /dev/null +++ b/t/070_attribute_helpers/010_array_from_role.t @@ -0,0 +1,46 @@ +#!/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; + use Moose::AttributeHelpers; + + has 'options' => ( + traits => ['Collection::Array'], + is => 'ro', + isa => 'ArrayRef[Foo]', + ); + + package Bulkie::Role; + use Moose::Role; + use Moose::AttributeHelpers; + + has 'stuff' => ( + traits => ['Collection::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'; +} diff --git a/t/070_attribute_helpers/011_counter_with_defaults.t b/t/070_attribute_helpers/011_counter_with_defaults.t new file mode 100644 index 0000000..e2299b2 --- /dev/null +++ b/t/070_attribute_helpers/011_counter_with_defaults.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 12; +use Test::Moose; + +{ + package MyHomePage; + use Moose; + use Moose::AttributeHelpers; + + 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::AttributeHelpers::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' +); + diff --git a/t/070_attribute_helpers/020_remove_attribute.t b/t/070_attribute_helpers/020_remove_attribute.t new file mode 100644 index 0000000..dcd3df8 --- /dev/null +++ b/t/070_attribute_helpers/020_remove_attribute.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; +use Test::Exception; + +{ + package MyHomePage; + use Moose; + use Moose::AttributeHelpers; + + 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 +]; diff --git a/t/070_attribute_helpers/100_collection_with_roles.t b/t/070_attribute_helpers/100_collection_with_roles.t new file mode 100644 index 0000000..806d0c0 --- /dev/null +++ b/t/070_attribute_helpers/100_collection_with_roles.t @@ -0,0 +1,124 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 28; + +{ + package Subject; + + use Moose::Role; + use Moose::AttributeHelpers; + + has observers => ( + traits => ['Collection::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; + use Moose::AttributeHelpers; + + 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' ); diff --git a/t/070_attribute_helpers/201_trait_counter.t b/t/070_attribute_helpers/201_trait_counter.t new file mode 100644 index 0000000..cdb0642 --- /dev/null +++ b/t/070_attribute_helpers/201_trait_counter.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Moose 'does_ok'; + +{ + package MyHomePage; + use Moose; + use Moose::AttributeHelpers; + + 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::AttributeHelpers::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' +); + diff --git a/t/070_attribute_helpers/202_trait_array.t b/t/070_attribute_helpers/202_trait_array.t new file mode 100644 index 0000000..cab89d0 --- /dev/null +++ b/t/070_attribute_helpers/202_trait_array.t @@ -0,0 +1,275 @@ +#!/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; + use Moose::AttributeHelpers; + + has 'options' => ( + traits => ['Collection::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_options' => '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_options + sort_options_in_place + option_accessor +]; + +is_deeply( $stuff->options, [ 10, 12 ], '... got options' ); + +ok( $stuff->has_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_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_options, '... no 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::AttributeHelpers::Trait::Collection::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_options' => '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' ); diff --git a/t/070_attribute_helpers/203_trait_hash.t b/t/070_attribute_helpers/203_trait_hash.t new file mode 100644 index 0000000..b809571 --- /dev/null +++ b/t/070_attribute_helpers/203_trait_hash.t @@ -0,0 +1,186 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 46; +use Test::Exception; +use Test::Moose 'does_ok'; + +{ + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'options' => ( + traits => ['Collection::Hash'], + is => 'ro', + isa => 'HashRef[Str]', + default => sub { {} }, + handles => { + 'set_option' => 'set', + 'get_option' => 'get', + 'has_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_options + num_options + delete_option + clear_options + is_defined + has_option + quantity + option_accessor +]; + +ok( !$stuff->has_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_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::AttributeHelpers::Trait::Collection::Hash' ); + +is_deeply( + $options->handles, + { + 'set_option' => 'set', + 'get_option' => 'get', + 'has_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' +); diff --git a/t/070_attribute_helpers/204_trait_number.t b/t/070_attribute_helpers/204_trait_number.t new file mode 100644 index 0000000..9b2c700 --- /dev/null +++ b/t/070_attribute_helpers/204_trait_number.t @@ -0,0 +1,113 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 25; +use Test::Moose; + +{ + package Real; + use Moose; + use Moose::AttributeHelpers; + + 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::AttributeHelpers::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' +); + diff --git a/t/070_attribute_helpers/205_trait_list.t b/t/070_attribute_helpers/205_trait_list.t new file mode 100644 index 0000000..1c342e6 --- /dev/null +++ b/t/070_attribute_helpers/205_trait_list.t @@ -0,0 +1,146 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 33; +use Test::Exception; +use Test::Moose 'does_ok'; + +my $sort; +my $less; +my $up; +{ + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has '_options' => ( + traits => ['Collection::List'], + is => 'ro', + isa => 'ArrayRef[Int]', + init_arg => 'options', + default => sub { [] }, + handles => { + 'num_options' => 'count', + 'has_options' => 'empty', + 'map_options', => 'map', + 'filter_options' => 'grep', + 'find_option' => 'find', + 'options' => 'elements', + 'join_options' => 'join', + 'get_option_at' => 'get', + 'get_first_option' => 'first', + 'get_last_option' => 'last', + '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_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_options, '... we have options' ); +is( $stuff->num_options, 10, '... got 2 options' ); +cmp_ok( $stuff->get_option_at(0), '==', 1, '... get option 0' ); +cmp_ok( $stuff->get_first_option, '==', 1, '... get first' ); +cmp_ok( $stuff->get_last_option, '==', 10, '... get last' ); + +is_deeply( + [ $stuff->filter_options( sub { $_[0] % 2 == 0 } ) ], + [ 2, 4, 6, 8, 10 ], + '... got the right filtered values' +); + +is_deeply( + [ $stuff->map_options( sub { $_[0] * 2 } ) ], + [ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ], + '... got the right mapped values' +); + +is( $stuff->find_option( sub { $_[0] % 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::AttributeHelpers::Trait::Collection::List' ); + +is_deeply( + $options->handles, + { + 'num_options' => 'count', + 'has_options' => 'empty', + 'map_options', => 'map', + 'filter_options' => 'grep', + 'find_option' => 'find', + 'options' => 'elements', + 'join_options' => 'join', + 'get_option_at' => 'get', + 'get_first_option' => 'first', + 'get_last_option' => 'last', + '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'; + diff --git a/t/070_attribute_helpers/206_trait_bag.t b/t/070_attribute_helpers/206_trait_bag.t new file mode 100644 index 0000000..5309f3d --- /dev/null +++ b/t/070_attribute_helpers/206_trait_bag.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 19; +use Test::Exception; +use Test::Moose 'does_ok'; + +{ + + package Stuff; + use Moose; + use Moose::AttributeHelpers; + + has 'word_histogram' => ( + traits => ['Collection::Bag'], + is => 'ro', + handles => { + 'add_word' => 'add', + 'get_count_for' => 'get', + 'has_any_words' => 'empty', + 'num_words' => 'count', + 'delete_word' => 'delete', + } + ); +} + +my $stuff = Stuff->new(); +isa_ok( $stuff, 'Stuff' ); + +can_ok( $stuff, $_ ) for qw[ + add_word + get_count_for + has_any_words + num_words + delete_word +]; + +ok( !$stuff->has_any_words, '... we have no words' ); +is( $stuff->num_words, 0, '... we have no words' ); + +lives_ok { + $stuff->add_word('bar'); +} +'... set the words okay'; + +ok( $stuff->has_any_words, '... we have words' ); +is( $stuff->num_words, 1, '... we have 1 word(s)' ); +is( $stuff->get_count_for('bar'), 1, '... got words now' ); + +lives_ok { + $stuff->add_word('foo'); + $stuff->add_word('bar') for 0 .. 3; + $stuff->add_word('baz') for 0 .. 10; +} +'... set the words okay'; + +is( $stuff->num_words, 3, '... we still have 1 word(s)' ); +is( $stuff->get_count_for('foo'), 1, '... got words now' ); +is( $stuff->get_count_for('bar'), 5, '... got words now' ); +is( $stuff->get_count_for('baz'), 11, '... got words now' ); + +## test the meta + +my $words = $stuff->meta->get_attribute('word_histogram'); +does_ok( $words, 'Moose::AttributeHelpers::Trait::Collection::Bag' ); + +is_deeply( + $words->handles, + { + 'add_word' => 'add', + 'get_count_for' => 'get', + 'has_any_words' => 'empty', + 'num_words' => 'count', + 'delete_word' => 'delete', + }, + '... got the right handles mapping' +); + diff --git a/t/070_attribute_helpers/207_trait_string.t b/t/070_attribute_helpers/207_trait_string.t new file mode 100644 index 0000000..a6af0ad --- /dev/null +++ b/t/070_attribute_helpers/207_trait_string.t @@ -0,0 +1,113 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 19; +use Test::Moose 'does_ok'; + +my $uc; +{ + package MyHomePage; + use Moose; + use Moose::AttributeHelpers; + + 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', + 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' ); + +$page->string('a'); + +$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" ); + +$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::AttributeHelpers::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', + exclaim => [ append => ['!'] ], + capitalize_last => [ replace => [ qr/(.)$/, $uc ] ], + invalid_number => [ match => [qr/\D/] ], + }, + '... got the right handles methods' +); + diff --git a/t/070_attribute_helpers/208_trait_bool.t b/t/070_attribute_helpers/208_trait_bool.t new file mode 100644 index 0000000..eb173d2 --- /dev/null +++ b/t/070_attribute_helpers/208_trait_bool.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; + +{ + package Room; + use Moose; + use Moose::AttributeHelpers; + + 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' ); + diff --git a/xt/author/pod_spell.t b/xt/author/pod_spell.t index 036638a..385d90a 100644 --- a/xt/author/pod_spell.t +++ b/xt/author/pod_spell.t @@ -24,7 +24,9 @@ chromatic's Debolaz Deltac dexter +doy ewilhelm +frodwith Goulah gphat groditi @@ -34,7 +36,9 @@ Kinyon's Kogman kolibrie konobi +Lanyon lbr +Luehrs McWhirter merlyn mst @@ -45,6 +49,7 @@ phaylon Prather Ragwitz Reis +rafl rindolf rlb Rockway @@ -72,6 +77,7 @@ ohloh SVN ## Moose +AttributeHelpers BankAccount BankAccount's BinaryTree @@ -113,6 +119,7 @@ Baz Changelog compat datetimes +dec definedness destructor destructors @@ -130,7 +137,9 @@ invocant's irc IRC isa +kv login +mul namespace namespaced namespaces