sub should_auto_deref { $_[0]->{auto_deref} }
sub should_coerce { $_[0]->{coerce} }
-sub get_read_method { $_[0]->{reader} || $_[0]->{accessor} }
-sub get_write_method { $_[0]->{writer} || $_[0]->{accessor} }
-
# predicates
sub has_accessor { exists $_[0]->{accessor} }
$self->throw_error("Could not find an attribute by the name of '$name' to inherit from");
}
+
+#sub get_read_method { $_[0]->{reader} || $_[0]->{accessor} }
+#sub get_write_method { $_[0]->{writer} || $_[0]->{accessor} }
+
+sub get_read_method_ref{
+ my($self) = @_;
+
+ $self->{_read_method_ref} ||= do{
+ my $metaclass = $self->associated_class
+ or $self->throw_error('No asocciated class for ' . $self->name);
+
+ my $reader = $self->{reader} || $self->{accessor};
+ if($reader){
+ $metaclass->name->can($reader);
+ }
+ else{
+ Mouse::Meta::Method::Accessor->_generate_reader($self, undef, $metaclass);
+ }
+ };
+}
+
+sub get_write_method_ref{
+ my($self) = @_;
+
+ $self->{_write_method_ref} ||= do{
+ my $metaclass = $self->associated_class
+ or $self->throw_error('No asocciated class for ' . $self->name);
+
+ my $reader = $self->{writer} || $self->{accessor};
+ if($reader){
+ $metaclass->name->can($reader);
+ }
+ else{
+ Mouse::Meta::Method::Accessor->_generate_writer($self, undef, $metaclass);
+ }
+ };
+}
+
sub associate_method{
my ($attribute, $method) = @_;
$attribute->{associated_methods}++;
foreach my $type(qw(accessor reader writer predicate clearer handles)){
if(exists $attribute->{$type}){
- my $installer = '_install_' . $type;
+ my $installer = '_generate_' . $type;
Mouse::Meta::Method::Accessor->$installer($attribute, $attribute->{$type}, $metaclass);
my($attribute_class, @traits) = Mouse::Meta::Attribute->interpolate_class($name, \%args);
$args{traits} = \@traits if @traits;
- $attr = $attribute_class->new($name, \%args);
+ $attr = $attribute_class->new($name, %args);
}
}
my %args = (
inline_constructor => 1,
inline_destructor => 1,
+ constructor_name => 'new',
@_,
);
$self->{is_immutable}++;
if ($args{inline_constructor}) {
- $self->add_method('new' => Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self ));
+ # generate and install
+ Mouse::Meta::Method::Constructor->_generate_constructor_method($self, \%args);
}
if ($args{inline_destructor}) {
- $self->add_method('DESTROY' => Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self ));
+ # generate and install
+ Mouse::Meta::Method::Destructor->_generate_destructor_method($self, \%args);
}
# Moose's make_immutable returns true allowing calling code to skip setting an explicit true value
use warnings;
use Scalar::Util qw(blessed);
-sub _install_accessor{
+sub _generate_accessor{
my (undef, $attribute, $method_name, $class, $type) = @_;
my $name = $attribute->name;
my $accessor =
'#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- "sub {\n";
+ sprintf("sub %s {\n", defined($method_name) ? $class->name . '::' . $method_name : '');
+
if ($type eq 'accessor' || $type eq 'writer') {
if($type eq 'accessor'){
$accessor .=
else{ # writer
$accessor .=
'#line ' . __LINE__ . ' "' . __FILE__ . "\"\n" .
- 'if(@_ < 2){ Carp::confess("Not enough arguments for writer '.$method_name.'") }'.
+ 'if(@_ < 2){ Carp::confess("Not enough arguments for the writer of '.$name.'") }'.
'{' . "\n";
}
$accessor .= 'return '.$self.'->{'.$key."};\n}";
#print $accessor, "\n";
- my $code = eval $accessor;
- $attribute->throw_error($@) if $@;
-
- $class->add_method($method_name => $code);
- return;
+ my $code;
+ my $e = do{
+ local $@;
+ $code = eval $accessor;
+ $@;
+ };
+ die $e if $e;
+
+ return $code; # returns a CODE ref unless $method_name is passed
}
-sub _install_reader{
+sub _generate_reader{
my $class = shift;
- $class->_install_accessor(@_, 'reader');
- return;
+ return $class->_generate_accessor(@_, 'reader');
}
-sub _install_writer{
+sub _generate_writer{
my $class = shift;
- $class->_install_accessor(@_, 'writer');
- return;
+ return $class->_generate_accessor(@_, 'writer');
}
-sub _install_predicate {
+sub _generate_predicate {
my (undef, $attribute, $method_name, $class) = @_;
my $slot = $attribute->name;
return;
}
-sub _install_clearer {
+sub _generate_clearer {
my (undef, $attribute, $method_name, $class) = @_;
my $slot = $attribute->name;
return;
}
-sub _install_handles {
+sub _generate_handles {
my (undef, $attribute, $handles, $class) = @_;
my $reader = $attribute->reader || $attribute->accessor
use strict;
use warnings;
-sub generate_constructor_method_inline {
- my ($class, $metaclass) = @_;
+sub _generate_constructor_method {
+ my ($class, $metaclass, $args) = @_;
my $associated_metaclass_name = $metaclass->name;
my @attrs = $metaclass->get_all_attributes;
my @compiled_constraints = map { $_ ? $_->_compiled_type_constraint : undef }
map { $_->type_constraint } @attrs;
+ my $constructor_name = defined($args->{constructor_name})
+ ? $associated_metaclass_name . '::' . $args->{constructor_name}
+ : '';
+
my $code = sprintf("#line %d %s\n", __LINE__, __FILE__).<<"...";
- sub {
- my \$class = shift;
- return \$class->Mouse::Object::new(\@_)
- if \$class ne q{$associated_metaclass_name};
- $buildargs;
- my \$instance = bless {}, \$class;
- $processattrs;
- $buildall;
- return \$instance;
- }
+ sub $constructor_name \{
+ my \$class = shift;
+ return \$class->Mouse::Object::new(\@_)
+ if \$class ne q{$associated_metaclass_name};
+ $buildargs;
+ my \$instance = bless {}, \$class;
+ $processattrs;
+ $buildall;
+ return \$instance;
+ }
...
local $@;
use strict;
use warnings;
-sub generate_destructor_method_inline {
- my ($class, $meta) = @_;
+sub _empty_destroy{ }
+
+sub _generate_destructor_method {
+ my ($class, $metaclass) = @_;
my $demolishall = do {
- if ($meta->name->can('DEMOLISH')) {
+ if ($metaclass->name->can('DEMOLISH')) {
my @code = ();
- for my $class ($meta->linearized_isa) {
+ for my $class ($metaclass->linearized_isa) {
no strict 'refs';
if (*{$class . '::DEMOLISH'}{CODE}) {
push @code, "${class}::DEMOLISH(\$self);";
}
join "\n", @code;
} else {
- return sub { }; # no demolish =)
+ $metaclass->add_method(DESTROY => \&_empty_destroy);
+ return;
}
};
- my $code = <<"...";
- sub {
+ my $destructor_name = $metaclass->name . '::DESTROY';
+ my $code = sprintf("#line %d %s\n", __LINE__, __FILE__) . <<"...";
+ sub $destructor_name \{
my \$self = shift;
$demolishall;
}
...
- local $@;
- my $res = eval $code;
+ my $e = do{
+ local $@;
+ eval $code;
+ $@;
+ };
die $@ if $@;
- return $res;
+ return;
}
1;
$dump .= $name;
}
- my $reader = $attribute->get_read_method;
+ my $reader = $attribute->get_read_method_ref;
$dump .= ": " . $self->$reader . "\n";
}
after 'install_accessors' => sub {
my $self = shift;
- my $reader = $self->get_read_method;
+ my $reader = $self->get_read_method_ref;
$self->associated_class->add_method(
$self->alias_to,
#!/usr/bin/env perl
use strict;
use warnings;
-use Test::More tests => 5;
+use Test::More tests => 7;
use lib 't/lib';
do {
# extend the parents stuff to make sure
# certain bits are now required ...
- #has '+default' => (required => 1);
- #has '+type_constraint' => (required => 1);
+ #has 'default' => (required => 1);
+ has 'type_constraint' => (required => 1);
## Methods called prior to instantiation
# 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;
+ my $attr_reader = $attr->get_read_method_ref;
+ my $attr_writer = $attr->get_write_method_ref;
# before we install them, lets
my ($attr, $reader, $writer) = @_;
return sub { $_[0]->$writer($_[1]) };
},
+ get => sub {
+ my ($attr, $reader, $writer) = @_;
+ return sub { $_[0]->$reader() };
+ },
add => sub {
my ($attr, $reader, $writer) = @_;
return sub { $_[0]->$writer($_[0]->$reader() + $_[1]) };
use Mouse;
has 'ii' => (
- is => 'rw',
isa => 'Num',
provides => {
sub => 'ii_minus',
abs => 'ii_abs',
+ get => 'get_ii',
+ set => 'set_ii',
},
traits => [qw(MyNumber)],
$k = MyClassWithTraits->new(ii => 10);
$k->ii_minus(100);
-is $k->ii, -90;
-is $k->ii_abs, 90;
+is $k->get_ii, -90;
+is $k->ii_abs, 90;
+
+$k->set_ii(10);
+is $k->get_ii, 10;
+is $k->ii_abs, 10;
projects / gitmo/Mouse.git / commitdiff