(exists $options->{isa})
|| confess "You must define a type with the $type metaclass";
- my $isa = $options->{isa};
+ my $isa = $options->{isa};
unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) {
$isa = find_type_constraint($isa);
($isa->is_a_type_of($type))
|| confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
}
-
- # this can be augmented by subclasses ..
- inner();
}
before '_process_options' => sub {
--- /dev/null
+
+package MooseX::AttributeHelpers::Collection;
+use Moose;
+use Moose::Util::TypeConstraints;
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+extends 'MooseX::AttributeHelpers::Base';
+
+has 'container_type' => (
+ is => 'ro',
+ isa => 'Str',
+ predicate => 'has_container_type',
+);
+
+has 'container_type_constraint' => (
+ is => 'rw',
+ isa => 'Moose::Meta::TypeConstraint',
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ ($self->has_container_type)
+ || confess "You cannot create a container_type_constraint if you dont have a container type";
+
+ my $container_type = $self->container_type;
+ my $constraint = find_type_constraint($container_type);
+
+ $constraint = subtype('Object', where { $_->isa($container_type) })
+ unless $constraint;
+
+ return $constraint;
+ }
+);
+
+before 'process_options_for_provides' => sub {
+ my ($self, $options) = @_;
+
+ if (exists $options->{isa}) {
+ my $type = $options->{isa};
+ if ($type =~ /^(.*)\[(.*)\]$/) {
+ my $core_type = $1;
+ my $container_type = $2;
+ $options->{isa} = $core_type;
+ $options->{container_type} = $container_type;
+ }
+ }
+};
+
+no Moose;
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=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::Collection::Array;
use Moose;
+use Moose::Util::TypeConstraints;
our $VERSION = '0.01';
our $AUTHORITY = 'cpan:STEVAN';
-extends 'MooseX::AttributeHelpers::Base';
+extends 'MooseX::AttributeHelpers::Collection';
sub helper_type { 'ArrayRef' }
return +{
'push' => sub {
my $attr = shift;
- return sub {
- my $instance = shift;
- push @{$attr->get_value($instance)} => @_;
- };
+ if ($attr->has_container_type) {
+ my $container_type_constraint = $attr->container_type_constraint;
+ return sub {
+ my $instance = shift;
+ $container_type_constraint->check($_)
+ || confess "Value $_ did not pass container type constraint"
+ foreach @_;
+ push @{$attr->get_value($instance)} => @_;
+ };
+ }
+ else {
+ return sub {
+ my $instance = shift;
+ push @{$attr->get_value($instance)} => @_;
+ };
+ }
},
'pop' => sub {
my $attr = shift;
},
'unshift' => sub {
my $attr = shift;
- return sub {
- my $instance = shift;
- unshift @{$attr->get_value($instance)} => @_;
- };
+ if ($attr->has_container_type) {
+ my $container_type_constraint = $attr->container_type_constraint;
+ return sub {
+ my $instance = shift;
+ $container_type_constraint->check($_)
+ || confess "Value $_ did not pass container type constraint"
+ foreach @_;
+ unshift @{$attr->get_value($instance)} => @_;
+ };
+ }
+ else {
+ return sub {
+ my $instance = shift;
+ unshift @{$attr->get_value($instance)} => @_;
+ };
+ }
},
'shift' => sub {
my $attr = shift;
},
'set' => sub {
my $attr = shift;
- return sub { $attr->get_value($_[0])->[$_[1]] = $_[2] };
+ if ($attr->has_container_type) {
+ my $container_type_constraint = $attr->container_type_constraint;
+ return sub {
+ ($container_type_constraint->check($_[2]))
+ || confess "Value $_[2] did not pass container type constraint";
+ $attr->get_value($_[0])->[$_[1]] = $_[2]
+ };
+ }
+ else {
+ return sub { $attr->get_value($_[0])->[$_[1]] = $_[2] };
+ }
},
'count' => sub {
my $attr = shift;
has 'options' => (
metaclass => 'Collection',
is => 'ro',
- isa => 'ArrayRef',
+ isa => 'ArrayRef[Int]',
default => sub { [] },
provides => {
'push' => 'add_options',
our $VERSION = '0.01';
our $AUTHORITY = 'cpan:STEVAN';
-extends 'MooseX::AttributeHelpers::Base';
+extends 'MooseX::AttributeHelpers::Collection';
sub helper_type { 'HashRef' }
},
'set' => sub {
my $attr = shift;
- return sub { $attr->get_value($_[0])->{$_[1]} = $_[2] };
+ if ($attr->has_container_type) {
+ my $container_type_constraint = $attr->container_type_constraint;
+ return sub {
+ ($container_type_constraint->check($_[2]))
+ || confess "Value $_[2] did not pass container type constraint";
+ $attr->get_value($_[0])->{$_[1]} = $_[2]
+ };
+ }
+ else {
+ return sub { $attr->get_value($_[0])->{$_[1]} = $_[2] };
+ }
},
+ 'keys' => sub {
+ my $attr = shift;
+ return sub { keys %{$attr->get_value($_[0])} };
+ },
+ 'values' => sub {
+ my $attr = shift;
+ return sub { values %{$attr->get_value($_[0])} };
+ },
'count' => sub {
my $attr = shift;
return sub { scalar keys %{$attr->get_value($_[0])} };
package MooseX::AttributeHelpers::Counter;
use Moose;
-use Moose::Util::TypeConstraints;
our $VERSION = '0.01';
our $AUTHORITY = 'cpan:STEVAN';
);
no Moose;
-no Moose::Util::TypeConstraints;
# register the alias ...
package Moose::Meta::Attribute::Custom::Counter;
package MooseX::AttributeHelpers::Number;
use Moose;
-use Moose::Util::TypeConstraints;
our $VERSION = '0.01';
our $AUTHORITY = 'cpan:STEVAN';
);
no Moose;
-no Moose::Util::TypeConstraints;
# register the alias ...
package Moose::Meta::Attribute::Custom::Number;
=head1 AUTHOR
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
+Robert Boone
=head1 COPYRIGHT AND LICENSE
my $page = MyHomePage->new();
isa_ok($page, 'MyHomePage');
+can_ok($page, 'inc_counter');
+can_ok($page, 'dec_counter');
+
is($page->counter, 0, '... got the default value');
$page->inc_counter;
$page->dec_counter;
is($page->counter, 1, '... got the decremented value');
+# check the meta ..
+
+my $counter = $page->meta->get_attribute('counter');
+isa_ok($counter, 'MooseX::AttributeHelpers::Counter');
+
+is($counter->helper_type, 'Num', '... got the expected helper type');
+
+is($counter->type_constraint->name, 'Int', '... got the expected type constraint');
+is_deeply($counter->provides, {
+ inc => 'inc_counter',
+ dec => 'dec_counter',
+}, '... got the right provides methods');
has 'options' => (
metaclass => 'Collection::Array',
is => 'ro',
- isa => 'ArrayRef',
+ isa => 'ArrayRef[Int]',
default => sub { [] },
provides => {
- 'push' => 'add_options',
- 'pop' => 'remove_last_option',
+ 'push' => 'add_options',
+ 'pop' => 'remove_last_option',
+ 'shift' => 'remove_first_option',
+ 'unshift' => 'insert_options',
+ 'get' => 'get_option_at',
+ 'set' => 'set_option_at',
+ 'count' => 'num_options',
+ 'empty' => 'has_options',
}
);
}
my $stuff = Stuff->new();
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
+ has_options
+];
+
is_deeply($stuff->options, [], '... no options yet');
+ok(!$stuff->has_options, '... no options');
+is($stuff->num_options, 0, '... got no options');
+
$stuff->add_options(1, 2, 3);
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');
+
+$stuff->set_option_at(1, 100);
+
+is($stuff->get_option_at(1), 100, '... get option at index 1');
+
$stuff->add_options(10, 15);
-is_deeply($stuff->options, [1, 2, 3, 10, 15], '... got more options now');
+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_deeply($stuff->options, [1, 2, 3, 10], '... got diff options now');
+is($stuff->num_options, 4, '... got 4 options');
+is_deeply($stuff->options, [1, 100, 3, 10], '... got diff options now');
+
+$stuff->insert_options(10, 20);
+
+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');
+
+## test the meta
+
+my $options = $stuff->meta->get_attribute('options');
+isa_ok($options, 'MooseX::AttributeHelpers::Collection::Array');
+is_deeply($options->provides, {
+ 'push' => 'add_options',
+ 'pop' => 'remove_last_option',
+ 'shift' => 'remove_first_option',
+ 'unshift' => 'insert_options',
+ 'get' => 'get_option_at',
+ 'set' => 'set_option_at',
+ 'count' => 'num_options',
+ 'empty' => 'has_options',
+}, '... got the right provies mapping');
projects / gitmo/MooseX-AttributeHelpers.git / commitdiff