+++ /dev/null
-#!/usr/bin/env perl
-use strict;
-use warnings;
-use Test::More tests => 7;
-use lib 't/lib';
-
-do {
- # copied from MooseX::AttributeHelpers;
- package MouseX::AttributeHelpers::Trait::Base;
- use Mouse::Role;
- use Mouse::Util::TypeConstraints;
-
- 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' => (is => 'rw', 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};
-
- 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, @_)
- };
- }
-
- 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_ref;
- my $attr_writer = $attr->get_write_method_ref;
-
-
- # 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);
- }
- };
-
- package MouseX::AttributeHelpers::Trait::Number;
- use Mouse::Role;
-
- with 'MouseX::AttributeHelpers::Trait::Base';
-
- sub helper_type { 'Num' }
-
- has 'method_constructors' => (\r
- is => 'ro',\r
- isa => 'HashRef',\r
- lazy => 1,\r
- default => sub {\r
- return +{\r
- set => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $_[1] ) };\r
- },
- get => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $reader->( $_[0] ) };\r
- },
- add => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) + $_[1] ) };\r
- },\r
- sub => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) - $_[1] ) };\r
- },\r
- mul => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) * $_[1] ) };\r
- },\r
- div => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) / $_[1] ) };\r
- },\r
- mod => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], $reader->( $_[0] ) % $_[1] ) };\r
- },\r
- abs => sub {\r
- my ( $attr, $reader, $writer ) = @_;\r
- return sub { $writer->( $_[0], abs( $reader->( $_[0] ) ) ) };\r
- },\r
- };\r
- }\r
- );\r
-\r
-
- 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' }
-
- # register an alias for 'traits'
- package Mouse::Meta::Attribute::Custom::Trait::MyNumber;
- sub register_implementation { 'MouseX::AttributeHelpers::Trait::Number' }
-
- package MyClass;
- use Mouse;
-
- has 'i' => (
- metaclass => 'MyNumber',
- is => 'rw',
- isa => 'Int',
- provides => {
- 'add' => 'i_add',
- },
- );
-
- package MyClassWithTraits;
- use Mouse;
-
- has 'ii' => (
- isa => 'Num',
- predicate => 'has_ii',
-
- provides => {
- sub => 'ii_minus',
- abs => 'ii_abs',
- get => 'get_ii',
- set => 'set_ii',
- },
-
- traits => [qw(MyNumber)],
- );
-};
-
-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->get_ii, -90;
-$k->ii_abs;
-is $k->get_ii, 90;
-
-$k->set_ii(10);
-is $k->get_ii, 10;
-$k->ii_abs;
-is $k->get_ii, 10;
-
projects / gitmo/Mouse.git / blobdiff