Revision history for Perl extension MooseX-AttributeHelpers
+0.02
+ * MooseX::AttributeHelpers::Base
+ - now providing subrefs for the reader and writer
+ methods to all the method provider constructors
+ (this should speed things up quite a bit).
+ - all method providers now use this internally
+
+ * MooseX::AttributeHelpers::Counter
+ - added the 'reset' method
+
+ * MooseX::AttributeHelpers::Collection::Array
+ - Extracted the List method provider role from
+ Array and made Array consume List.
+
+ + MooseX::AttributeHelpers::Collection::List
+ - created the Collection::List metaclass
+ derived from parts of the old Collection::Array
+
0.01 Mon. Aug. 13, 2007
- module released to CPAN
\ No newline at end of file
package MooseX::AttributeHelpers;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
our $AUTHORITY = 'cpan:STEVAN';
use MooseX::AttributeHelpers::Meta::Method::Provided;
use MooseX::AttributeHelpers::Counter;
use MooseX::AttributeHelpers::Number;
+use MooseX::AttributeHelpers::Collection::List;
use MooseX::AttributeHelpers::Collection::Array;
use MooseX::AttributeHelpers::Collection::Hash;
Common methods for array references.
+=item L<Collection::Array|MooseX::AttributeHelpers::Collection::List>
+
+Common list methods for array references.
+
=back
=head1 CAVEAT
use Moose;
use Moose::Util::TypeConstraints;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
our $AUTHORITY = 'cpan:STEVAN';
extends 'Moose::Meta::Attribute';
after 'install_accessors' => sub {
my $attr = shift;
my $class = $attr->associated_class;
+
+ # grab the reader and writer methods
+ # as well, this will be useful for
+ # our method provider constructors
+ my ($attr_reader, $attr_writer);
+ if (my $reader = $attr->get_read_method) {
+ $attr_reader = $class->get_method($reader);
+ }
+ else {
+ $attr_reader = sub { $attr->get_value(@_) };
+ }
+
+ if (my $writer = $attr->get_write_method) {
+ $attr_writer = $class->get_method($writer);
+ }
+ else {
+ $attr_writer = sub { $attr->set_value(@_) };
+ }
# before we install them, lets
# make sure they are valid
foreach my $key (keys %{$attr->provides}) {
- my $method_name = $attr->provides->{$key};
- my $method_body = $method_constructors->{$key}->($attr);
+ my $method_name = $attr->provides->{$key};
+ my $method_body = $method_constructors->{$key}->(
+ $attr,
+ $attr_reader,
+ $attr_writer,
+ );
if ($class->has_method($method_name)) {
confess "The method ($method_name) already exists in class (" . $class->name . ")";
use MooseX::AttributeHelpers;
has 'options' => (
- metaclass => 'Collection',
+ metaclass => 'Collection::Array',
is => 'ro',
isa => 'ArrayRef[Int]',
default => sub { [] },
--- /dev/null
+
+package MooseX::AttributeHelpers::Collection::List;
+use Moose;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use MooseX::AttributeHelpers::MethodProvider::List;
+
+extends 'MooseX::AttributeHelpers::Collection';
+
+has '+method_provider' => (
+ default => 'MooseX::AttributeHelpers::MethodProvider::List'
+);
+
+sub helper_type { 'ArrayRef' }
+
+no Moose;
+
+# register the alias ...
+package Moose::Meta::Attribute::Custom::Collection::List;
+sub register_implementation { 'MooseX::AttributeHelpers::Collection::List' }
+
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::AttributeHelpers::Collection::List
+
+=head1 SYNOPSIS
+
+ package Stuff;
+ use Moose;
+ use MooseX::AttributeHelpers;
+
+ has 'options' => (
+ metaclass => 'Collection::List',
+ is => 'ro',
+ isa => 'ArrayRef[Int]',
+ default => sub { [] },
+ provides => {
+ map => 'map_options',
+ grep => 'fitler_options',
+ }
+ );
+
+=head1 DESCRIPTION
+
+This module provides an List attribute which provides a number of
+list operations. See L<MooseX::AttributeHelpers::MethodProvider::List>
+for more details.
+
+=head1 METHODS
+
+=over 4
+
+=item B<method_provider>
+
+=item B<has_method_provider>
+
+=item B<helper_type>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
package MooseX::AttributeHelpers::MethodProvider::Array;
use Moose::Role;
+our $VERSION = '0.03';
+our $AUTHORITY = 'cpan:STEVAN';
+
+with 'MooseX::AttributeHelpers::MethodProvider::List';
+
sub push : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
+
if ($attr->has_container_type) {
my $container_type_constraint = $attr->container_type_constraint;
return sub {
$container_type_constraint->check($_)
|| confess "Value " . ($_||'undef') . " did not pass container type constraint"
foreach @_;
- CORE::push @{$attr->get_value($instance)} => @_;
+ CORE::push @{$reader->($instance)} => @_;
};
}
else {
return sub {
my $instance = CORE::shift;
- CORE::push @{$attr->get_value($instance)} => @_;
+ CORE::push @{$reader->($instance)} => @_;
};
}
}
sub pop : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
return sub {
- CORE::pop @{$attr->get_value($_[0])}
+ CORE::pop @{$reader->($_[0])}
};
}
sub unshift : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
if ($attr->has_container_type) {
my $container_type_constraint = $attr->container_type_constraint;
return sub {
$container_type_constraint->check($_)
|| confess "Value " . ($_||'undef') . " did not pass container type constraint"
foreach @_;
- CORE::unshift @{$attr->get_value($instance)} => @_;
+ CORE::unshift @{$reader->($instance)} => @_;
};
}
else {
return sub {
my $instance = CORE::shift;
- CORE::unshift @{$attr->get_value($instance)} => @_;
+ CORE::unshift @{$reader->($instance)} => @_;
};
}
}
sub shift : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
return sub {
- CORE::shift @{$attr->get_value($_[0])}
+ CORE::shift @{$reader->($_[0])}
};
}
sub get : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
return sub {
- $attr->get_value($_[0])->[$_[1]]
+ $reader->($_[0])->[$_[1]]
};
}
sub set : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
if ($attr->has_container_type) {
my $container_type_constraint = $attr->container_type_constraint;
return sub {
($container_type_constraint->check($_[2]))
|| confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
- $attr->get_value($_[0])->[$_[1]] = $_[2]
+ $reader->($_[0])->[$_[1]] = $_[2]
};
}
else {
return sub {
- $attr->get_value($_[0])->[$_[1]] = $_[2]
+ $reader->($_[0])->[$_[1]] = $_[2]
};
}
}
-sub count : method {
- my ($attr) = @_;
- return sub {
- scalar @{$attr->get_value($_[0])}
- };
-}
-
-sub empty : method {
- my ($attr) = @_;
- return sub {
- scalar @{$attr->get_value($_[0])} ? 1 : 0
- };
-}
-
-sub find : method {
- my ($attr) = @_;
- return sub {
- my ($instance, $predicate) = @_;
- foreach my $val (@{$attr->get_value($instance)}) {
- return $val if $predicate->($val);
- }
- return;
- };
-}
-
-sub map : method {
- my ($attr) = @_;
- return sub {
- my ($instance, $f) = @_;
- CORE::map { $f->($_) } @{$attr->get_value($instance)}
- };
-}
-
-sub grep : method {
- my ($attr) = @_;
- return sub {
- my ($instance, $predicate) = @_;
- CORE::grep { $predicate->($_) } @{$attr->get_value($instance)}
- };
-}
-
1;
__END__
=head1 PROVIDED METHODS
-=over 4
+This module also consumes the B<List> method providers, to
+see those provied methods, refer to that documentation.
-=item B<count>
-
-=item B<empty>
-
-=item B<find>
+=over 4
=item B<get>
-=item B<grep>
-
-=item B<map>
-
=item B<pop>
=item B<push>
package MooseX::AttributeHelpers::MethodProvider::Counter;
use Moose::Role;
+our $VERSION = '0.03';
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub reset : method {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $attr->default($_[0])) };
+}
+
sub inc {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) + 1) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) + 1) };
}
sub dec {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) - 1) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) - 1) };
}
1;
=item B<dec>
+=item B<reset>
+
=back
=head1 BUGS
package MooseX::AttributeHelpers::MethodProvider::Hash;
use Moose::Role;
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
sub exists : method {
- my ($attr) = @_;
- return sub { exists $attr->get_value($_[0])->{$_[1]} ? 1 : 0 };
+ my ($attr, $reader, $writer) = @_;
+ return sub { exists $reader->($_[0])->{$_[1]} ? 1 : 0 };
}
sub get : method {
- my ($attr) = @_;
- return sub { $attr->get_value($_[0])->{$_[1]} };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $reader->($_[0])->{$_[1]} };
}
sub set : method {
- my ($attr) = @_;
+ my ($attr, $reader, $writer) = @_;
if ($attr->has_container_type) {
my $container_type_constraint = $attr->container_type_constraint;
return sub {
($container_type_constraint->check($_[2]))
|| confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
- $attr->get_value($_[0])->{$_[1]} = $_[2]
+ $reader->($_[0])->{$_[1]} = $_[2]
};
}
else {
- return sub { $attr->get_value($_[0])->{$_[1]} = $_[2] };
+ return sub { $reader->($_[0])->{$_[1]} = $_[2] };
}
}
sub keys : method {
- my ($attr) = @_;
- return sub { keys %{$attr->get_value($_[0])} };
+ my ($attr, $reader, $writer) = @_;
+ return sub { keys %{$reader->($_[0])} };
}
sub values : method {
- my ($attr) = @_;
- return sub { values %{$attr->get_value($_[0])} };
+ my ($attr, $reader, $writer) = @_;
+ return sub { values %{$reader->($_[0])} };
}
sub count : method {
- my ($attr) = @_;
- return sub { scalar keys %{$attr->get_value($_[0])} };
+ my ($attr, $reader, $writer) = @_;
+ return sub { scalar keys %{$reader->($_[0])} };
}
sub empty : method {
- my ($attr) = @_;
- return sub { scalar keys %{$attr->get_value($_[0])} ? 1 : 0 };
+ my ($attr, $reader, $writer) = @_;
+ return sub { scalar keys %{$reader->($_[0])} ? 1 : 0 };
}
sub delete : method {
- my ($attr) = @_;
- return sub { delete $attr->get_value($_[0])->{$_[1]} };
+ my ($attr, $reader, $writer) = @_;
+ return sub { delete $reader->($_[0])->{$_[1]} };
}
1;
--- /dev/null
+package MooseX::AttributeHelpers::MethodProvider::List;
+use Moose::Role;
+
+our $VERSION = '0.02';
+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 grep : method {
+ my ($attr, $reader, $writer) = @_;
+ return sub {
+ my ($instance, $predicate) = @_;
+ CORE::grep { $predicate->($_) } @{$reader->($instance)}
+ };
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::AttributeHelpers::MethodProvider::List
+
+=head1 DESCRIPTION
+
+This is a role which provides the method generators for
+L<MooseX::AttributeHelpers::Collection::List>.
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=back
+
+=head1 PROVIDED METHODS
+
+=over 4
+
+=item B<count>
+
+=item B<empty>
+
+=item B<find>
+
+=item B<grep>
+
+=item B<map>
+
+=back
+
+=head1 BUGS
+
+All complex software has bugs lurking in it, and this module is no
+exception. If you find a bug please either email me, or add the bug
+to cpan-RT.
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
sub helper_type { 'Num' }
+# NOTE:
+# we don't use the method provider for this
+# module since many of the names of the provied
+# methods would conflict with keywords
+# - SL
+
has '+method_constructors' => (
default => sub {
return +{
set => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $_[1]) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $_[1]) };
},
add => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) + $_[1]) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) + $_[1]) };
},
sub => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) - $_[1]) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) - $_[1]) };
},
mul => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) * $_[1]) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) * $_[1]) };
},
div => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) / $_[1]) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) / $_[1]) };
},
mod => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], $attr->get_value($_[0]) % $_[1]) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], $reader->($_[0]) % $_[1]) };
},
abs => sub {
- my $attr = shift;
- return sub { $attr->set_value($_[0], abs($attr->get_value($_[0])) ) };
+ my ($attr, $reader, $writer) = @_;
+ return sub { $writer->($_[0], abs($reader->($_[0])) ) };
},
}
}
isa => 'Int',
default => sub { 0 },
provides => {
- inc => 'inc_counter',
- dec => 'dec_counter',
+ inc => 'inc_counter',
+ dec => 'dec_counter',
+ reset => 'reset_counter',
}
);
}
can_ok($page, $_) for qw[
dec_counter
inc_counter
+ reset_counter
];
is($page->counter, 0, '... got the default value');
$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');
is($counter->type_constraint->name, 'Int', '... got the expected type constraint');
is_deeply($counter->provides, {
- inc => 'inc_counter',
- dec => 'dec_counter',
+ inc => 'inc_counter',
+ dec => 'dec_counter',
+ reset => 'reset_counter',
}, '... got the right provides methods');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('MooseX::AttributeHelpers');
+}
+
+{
+ package Stuff;
+ use Moose;
+
+ has 'options' => (
+ metaclass => 'Collection::List',
+ is => 'ro',
+ isa => 'ArrayRef[Int]',
+ default => sub { [] },
+ provides => {
+ 'count' => 'num_options',
+ 'empty' => 'has_options',
+ 'map' => 'map_options',
+ 'grep' => 'filter_options',
+ 'find' => 'find_option',
+ }
+ );
+}
+
+my $stuff = Stuff->new(options => [ 1 .. 10 ]);
+isa_ok($stuff, 'Stuff');
+
+can_ok($stuff, $_) for qw[
+ num_options
+ has_options
+ map_options
+ filter_options
+ find_option
+];
+
+is_deeply($stuff->options, [1 .. 10], '... got options');
+
+ok($stuff->has_options, '... we have options');
+is($stuff->num_options, 10, '... got 2 options');
+
+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');
+
+## test the meta
+
+my $options = $stuff->meta->get_attribute('options');
+isa_ok($options, 'MooseX::AttributeHelpers::Collection::List');
+
+is_deeply($options->provides, {
+ 'map' => 'map_options',
+ 'grep' => 'filter_options',
+ 'find' => 'find_option',
+ 'count' => 'num_options',
+ 'empty' => 'has_options',
+}, '... got the right provies mapping');
+
+is($options->container_type, 'Int', '... got the right container type');
projects / gitmo/MooseX-AttributeHelpers.git / commitdiff