#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More tests => 5;
use lib 't/lib';
do {
- local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ };
+ # copied from MouseX::AttributeHelpers;
+ package MouseX::AttributeHelpers::Trait::Base;
+ use Mouse::Role;
+ use Mouse::Util::TypeConstraints;
- package MouseX::AttributeHelpers::Number;
- use Mouse;
- extends 'Mouse::Meta::Attribute';
+ requires 'helper_type';
+
+ # this is the method map you define ...
+ has 'provides' => (
+ is => 'ro',
+ isa => 'HashRef',
+ default => sub {{}}
+ );
+
+ has 'curries' => (
+ is => 'ro',
+ isa => 'HashRef',
+ default => sub {{}}
+ );
+
+ # these next two are the possible methods
+ # you can use in the 'provides' map.
+
+ # provide a Class or Role which we can
+ # collect the method providers from
+
+ # requires_attr 'method_provider'
+
+ # 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($_)
+ }
+ grep { $_ ne 'meta' } $method_provider->get_method_list
+ };
+ },
+ );
+
+ # extend the parents stuff to make sure
+ # certain bits are now required ...
+ #has '+default' => (required => 1);
+ #has '+type_constraint' => (required => 1);
+
+ ## Methods called prior to instantiation
+
+ sub process_options_for_provides {
+ my ($self, $options) = @_;
+
+ if (my $type = $self->helper_type) {
+ (exists $options->{isa})
+ || confess "You must define a type with the $type metaclass";
+
+ my $isa = $options->{isa};
- sub create {
- my ($self, @args) = @_;
- my $attr = $self->SUPER::create(@args);
- my %provides = %{$attr->{provides}};
- my $method_constructors = {
- add => sub {
- my ($attr, $name) = @_;
- return sub {
- $_[0]->$name( $_[0]->$name() + $_[1])
- };
- },
+ unless (blessed($isa) && $isa->isa('Mouse::Meta::TypeConstraint')) {
+ $isa = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($isa);
+ }
+
+ #($isa->is_a_type_of($type))
+ # || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
+ }
+ }
+
+ before '_process_options' => sub {
+ my ($self, $name, $options) = @_;
+ $self->process_options_for_provides($options, $name);
+ };
+
+ ## methods called after instantiation
+
+ sub check_provides_values {
+ my $self = shift;
+
+ my $method_constructors = $self->method_constructors;
+
+ foreach my $key (keys %{$self->provides}) {
+ (exists $method_constructors->{$key})
+ || confess "$key is an unsupported method type";
+ }
+
+ foreach my $key (keys %{$self->curries}) {
+ (exists $method_constructors->{$key})
+ || confess "$key is an unsupported method type";
+ }
+ }
+
+ sub _curry {
+ my $self = shift;
+ my $code = shift;
+
+ my @args = @_;
+ return sub {
+ my $self = shift;
+ $code->($self, @args, @_)
};
- while (my ($name, $aliased) = each %provides) {
- $attr->associated_class->add_method(
- $aliased => $method_constructors->{$name}->($attr, $attr->name)
+ }
+
+ sub _curry_sub {
+ my $self = shift;
+ my $body = shift;
+ my $code = shift;
+
+ return sub {
+ my $self = shift;
+ $code->($self, $body, @_)
+ };
+ }
+
+ 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->get_read_method;
+ my $attr_writer = $attr->get_write_method;
+
+
+ # before we install them, lets
+ # make sure they are valid
+ $attr->check_provides_values;
+
+ my $method_constructors = $attr->method_constructors;
+
+ my $class_name = $class->name;
+
+ while (my ($constructor, $constructed) = each %{$attr->curries}) {
+ my $method_code;
+ while (my ($curried_name, $curried_arg) = each(%$constructed)) {
+ if ($class->has_method($curried_name)) {
+ confess
+ "The method ($curried_name) already ".
+ "exists in class (" . $class->name . ")";
+ }
+ my $body = $method_constructors->{$constructor}->(
+ $attr,
+ $attr_reader,
+ $attr_writer,
+ );
+
+ if (ref $curried_arg eq 'ARRAY') {
+ $method_code = $attr->_curry($body, @$curried_arg);
+ }
+ elsif (ref $curried_arg eq 'CODE') {
+ $method_code = $attr->_curry_sub($body, $curried_arg);
+ }
+ else {
+ confess "curries parameter must be ref type ARRAY or CODE";
+ }
+
+ my $method = MouseX::AttributeHelpers::Meta::Method::Curried->wrap(
+ $method_code,
+ package_name => $class_name,
+ name => $curried_name,
+ );
+
+ $attr->associate_method($method);
+ $class->add_method($curried_name => $method);
+ }
+ }
+
+ foreach my $key (keys %{$attr->provides}) {
+
+ my $method_name = $attr->provides->{$key};
+
+ if ($class->has_method($method_name)) {
+ confess "The method ($method_name) already exists in class (" . $class->name . ")";
+ }
+
+ my $method = $method_constructors->{$key}->(
+ $attr,
+ $attr_reader,
+ $attr_writer,
);
+
+ $class->add_method($method_name => $method);
}
- return $attr;
};
- package # hide me from search.cpan.org
- Mouse::Meta::Attribute::Custom::Number;
+ package MouseX::AttributeHelpers::Trait::Number;
+ use Mouse::Role;
+
+ with 'MouseX::AttributeHelpers::Trait::Base';
+
+ sub helper_type { 'Num' }
+
+ has 'method_constructors' => (
+ is => 'ro',
+ isa => 'HashRef',
+ lazy => 1,
+ default => sub {
+ return +{
+ set => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer($_[1]) };
+ },
+ add => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer($_[0]->$reader() + $_[1]) };
+ },
+ sub => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer($_[0]->$reader() - $_[1]) };
+ },
+ mul => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer($_[0]->$reader() * $_[1]) };
+ },
+ div => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer($_[0]->$reader() / $_[1]) };
+ },
+ mod => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer($_[0]->$reader() % $_[1]) };
+ },
+ abs => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$writer(abs($_[0]->$reader()) ) };
+ },
+ }
+ }
+ );
+
+ package MouseX::AttributeHelpers::Number;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+ with 'MouseX::AttributeHelpers::Trait::Number';
+
+ no Mouse;
+
+ # register an alias for 'metaclass'
+ package Mouse::Meta::Attribute::Custom::MyNumber;
sub register_implementation { 'MouseX::AttributeHelpers::Number' }
- 1;
+ # register an alias for 'traits'
+ package Mouse::Meta::Attribute::Custom::Trait::MyNumber;
+ sub register_implementation { 'MouseX::AttributeHelpers::Trait::Number' }
- package Klass;
+ package MyClass;
use Mouse;
has 'i' => (
- metaclass => 'Number',
+ metaclass => 'MyNumber',
is => 'rw',
isa => 'Int',
provides => {
- 'add' => 'add_number'
+ 'add' => 'i_add',
},
);
+
+ package MyClassWithTraits;
+ use Mouse;
+
+ has 'ii' => (
+ is => 'rw',
+ isa => 'Num',
+ provides => {
+ sub => 'ii_minus',
+ abs => 'ii_abs',
+ },
+
+ traits => [qw(MyNumber)],
+ );
};
-can_ok 'Klass', 'add_number';
-my $k = Klass->new(i=>3);
-$k->add_number(4);
+can_ok 'MyClass', 'i_add';
+my $k = MyClass->new(i=>3);
+$k->i_add(4);
is $k->i, 7;
+can_ok 'MyClassWithTraits', qw(ii_minus ii_abs);
+
+$k = MyClassWithTraits->new(ii => 10);
+$k->ii_minus(100);
+is $k->ii, -90;
+is $k->ii_abs, 90;
+
projects / gitmo/Mouse.git / blobdiff