sub _process_options{
my($class, $name, $args) = @_;
- # XXX: for backward compatibility (with method modifiers)
- if($class->can('canonicalize_args') != \&canonicalize_args){
- %{$args} = $class->canonicalize_args($name, %{$args});
- }
-
# taken from Class::MOP::Attribute::new
defined($name)
sub has_read_method { $_[0]->has_reader || $_[0]->has_accessor }
sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
-sub _create_args { # DEPRECATED
- $_[0]->{_create_args} = $_[1] if @_ > 1;
- $_[0]->{_create_args}
-}
-
sub interpolate_class{
my($class, $args) = @_;
return( $class, @traits );
}
-sub canonicalize_args{ # DEPRECATED
- my ($self, $name, %args) = @_;
-
- Carp::cluck("$self->canonicalize_args has been deprecated."
- . "Use \$self->_process_options instead.");
-
- return %args;
-}
-
-sub create { # DEPRECATED
- my ($self, $class, $name, %args) = @_;
-
- Carp::cluck("$self->create has been deprecated."
- . "Use \$meta->add_attribute and \$attr->install_accessors instead.");
-
- # noop
- return $self;
-}
-
sub _coerce_and_verify {
my($self, $value, $instance) = @_;
);
}
-sub coerce_constraint { # DEPRECATED
- my $type = $_[0]->{type_constraint}
- or return $_[1];
-
- Carp::cluck("coerce_constraint() has been deprecated, which was an internal utility anyway");
-
- return Mouse::Util::TypeConstraints->typecast_constraints($_[0]->associated_class->name, $type, $_[1]);
-}
-
sub clone_and_inherit_options{
my($self, %args) = @_;
return $attribute_class->new($self->name, %args);
}
-sub clone_parent { # DEPRECATED
- my $self = shift;
- my $class = shift;
- my $name = shift;
- my %args = ($self->get_parent_args($class, $name), @_);
-
- Carp::cluck("$self->clone_parent has been deprecated."
- . "Use \$meta->add_attribute and \$attr->install_accessors instead.");
-
- $self->clone_and_inherited_args($class, $name, %args);
-}
-
-sub get_parent_args { # DEPRECATED
- my $self = shift;
- my $class = shift;
- my $name = shift;
-
- for my $super ($class->linearized_isa) {
- my $super_attr = $super->can("meta") && $super->meta->get_attribute($name)
- or next;
- return %{ $super_attr->_create_args };
- }
-
- $self->throw_error("Could not find an attribute by the name of '$name' to inherit from");
-}
-
-
sub get_read_method {
return $_[0]->reader || $_[0]->accessor
}
}
}
- if($attribute->can('create') != \&create){
- # backword compatibility
- $attribute->create($metaclass, $attribute->name, %{$attribute});
- }
-
return;
}
*CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
}
-sub _metaclass_cache { # DEPRECATED
- my($class, $name) = @_;
- return $METAS{$name};
-}
-
sub initialize {
my($class, $package_name, @args) = @_;
sub namespace;
-# The followings are Class::MOP specific methods
-
-#sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
-#sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
-#sub identifier {
-# my $self = shift;
-# return join '-' => (
-# $self->name,
-# ($self->version || ()),
-# ($self->authority || ()),
-# );
-#}
-
# add_attribute is an abstract method
-sub get_attribute_map { # DEPRECATED
- Carp::cluck('get_attribute_map() has been deprecated');
- return $_[0]->{attributes};
-}
-
sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
sub get_attribute { $_[0]->{attributes}->{$_[1]} }
sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} }
);
}
- sub optimized_constraints { # DEPRECATED
- Carp::cluck('optimized_constraints() has been deprecated');
- return \%TYPE;
- }
-
my @builtins = keys %TYPE;
sub list_all_builtin_type_constraints { @builtins }
);
}
-sub typecast_constraints { # DEPRECATED
- my($class, $pkg, $type, $value) = @_;
- Carp::croak("wrong arguments count") unless @_ == 4;
-
- Carp::cluck("typecast_constraints() has been deprecated, which was an internal utility anyway");
-
- return $type->coerce($value);
-}
-
sub enum {
my($name, %valid);
+++ /dev/null
-#!/usr/bin/env perl
-use strict;
-use warnings;
-use Test::More tests => 2;
-use lib 't/lib';
-
-do {
- local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ };
-
- package MouseX::AttributeHelpers::Number;
- use Mouse;
- extends 'Mouse::Meta::Attribute';
-
- 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])
- };
- },
- };
- while (my ($name, $aliased) = each %provides) {
- $attr->associated_class->add_method(
- $aliased => $method_constructors->{$name}->($attr, $attr->name)
- );
- }
- return $attr;
- };
-
- around 'canonicalize_args' => sub {\r
- my ($next, $self, $name, %args) = @_;\r
-\r
- %args = $next->($self, $name, %args);\r
- $args{is} = 'rw' unless exists $args{is};\r
-\r
- return %args;\r
- };\r
-
- package # hide me from search.cpan.org
- Mouse::Meta::Attribute::Custom::Number;
- sub register_implementation { 'MouseX::AttributeHelpers::Number' }
-
- 1;
-
- package Klass;
- use Mouse;
-
- has 'number' => (
- metaclass => 'Number',
- isa => 'Int',
- provides => {
- 'add' => 'add_number'
- },
- );
-};
-
-can_ok 'Klass', 'add_number', 'number';
-my $k = Klass->new(number => 3);
-$k->add_number(4);
-is $k->number, 7;
-
+++ /dev/null
-#!/usr/bin/env perl
-use strict;
-use warnings;
-use Test::More tests => 7;
-use lib 't/lib';
-
-do {
- local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ };
-
- package MouseX::AttributeHelpers::Number;
- use Mouse;
- extends 'Mouse::Meta::Attribute';
-
- 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])
- };
- },
- };
- while (my ($name, $aliased) = each %provides) {
- $attr->associated_class->add_method(
- $aliased => $method_constructors->{$name}->($attr, $attr->name)
- );
- }
- return $attr;
- };
-
- package # hide me from search.cpan.org
- Mouse::Meta::Attribute::Custom::Number;
- sub register_implementation { 'MouseX::AttributeHelpers::Number' }
-
- 1;
-
- package Foo;
- use Mouse::Role;
-
- has 'i' => (
- metaclass => 'Number',
- is => 'rw',
- isa => 'Int',
- provides => {
- 'add' => 'add_number'
- },
- );
- sub f_m {}
-
- package Bar;
- use Mouse::Role;
-
- has 'j' => (
- metaclass => 'Number',
- is => 'rw',
- isa => 'Int',
- provides => {
- 'add' => 'add_number_j'
- },
- );
- sub b_m {}
-
- package Klass1;
- use Mouse;
- with 'Foo';
-
- package Klass2;
- use Mouse;
- with 'Foo', 'Bar';
-
-};
-
-{
- # normal
- can_ok 'Klass1', 'add_number';
- my $k = Klass1->new(i=>3);
- $k->add_number(4);
- is $k->i, 7;
-}
-
-{
- # combine
- can_ok 'Klass2', 'f_m';
- can_ok 'Klass2', 'b_m';
- can_ok 'Klass2', 'add_number';
- can_ok 'Klass2', 'add_number_j';
- my $k = Klass2->new(i=>3);
- $k->add_number(4);
- is $k->i, 7;
-}
-
-
projects / gitmo/Mouse.git / commitdiff