use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.65';
+our $VERSION = '0.76';
+$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base 'Class::MOP::Object';
# meta-objects.
# - Ain't meta-circularity grand? :)
sub new {
- my $class = shift;
- my $name = shift;
- my %options = @_;
+ my ( $class, @args ) = @_;
+
+ unshift @args, "name" if @args % 2 == 1;
+ my %options = @args;
+
+ my $name = $options{name};
(defined $name && $name)
|| confess "You must provide a name for the attribute";
confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
}
+ $class->_new(\%options);
+}
+
+sub _new {
+ my $class = shift;
+ my $options = @_ == 1 ? $_[0] : {@_};
+
bless {
- 'name' => $name,
- 'accessor' => $options{accessor},
- 'reader' => $options{reader},
- 'writer' => $options{writer},
- 'predicate' => $options{predicate},
- 'clearer' => $options{clearer},
- 'builder' => $options{builder},
- 'init_arg' => $options{init_arg},
- 'default' => $options{default},
- 'initializer' => $options{initializer},
+ 'name' => $options->{name},
+ 'accessor' => $options->{accessor},
+ 'reader' => $options->{reader},
+ 'writer' => $options->{writer},
+ 'predicate' => $options->{predicate},
+ 'clearer' => $options->{clearer},
+ 'builder' => $options->{builder},
+ 'init_arg' => $options->{init_arg},
+ 'default' => $options->{default},
+ 'initializer' => $options->{initializer},
+ 'definition_context' => $options->{definition_context},
# keep a weakened link to the
# class we are associated with
'associated_class' => undef,
# and a list of the methods
# associated with this attr
'associated_methods' => [],
- } => $class;
+ }, $class;
}
# NOTE:
my %options = @_;
(blessed($self))
|| confess "Can only clone an instance";
- return bless { %{$self}, %options } => blessed($self);
+ return bless { %{$self}, %options } => ref($self);
}
sub initialize_instance_slot {
);
}
else {
- confess(blessed($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
+ confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
}
}
}
sub associated_class { $_[0]->{'associated_class'} }
sub associated_methods { $_[0]->{'associated_methods'} }
-sub has_accessor { defined($_[0]->{'accessor'}) ? 1 : 0 }
-sub has_reader { defined($_[0]->{'reader'}) ? 1 : 0 }
-sub has_writer { defined($_[0]->{'writer'}) ? 1 : 0 }
-sub has_predicate { defined($_[0]->{'predicate'}) ? 1 : 0 }
-sub has_clearer { defined($_[0]->{'clearer'}) ? 1 : 0 }
-sub has_builder { defined($_[0]->{'builder'}) ? 1 : 0 }
-sub has_init_arg { defined($_[0]->{'init_arg'}) ? 1 : 0 }
-sub has_default { defined($_[0]->{'default'}) ? 1 : 0 }
-sub has_initializer { defined($_[0]->{'initializer'}) ? 1 : 0 }
-
-sub accessor { $_[0]->{'accessor'} }
-sub reader { $_[0]->{'reader'} }
-sub writer { $_[0]->{'writer'} }
-sub predicate { $_[0]->{'predicate'} }
-sub clearer { $_[0]->{'clearer'} }
-sub builder { $_[0]->{'builder'} }
-sub init_arg { $_[0]->{'init_arg'} }
-sub initializer { $_[0]->{'initializer'} }
+sub has_accessor { defined($_[0]->{'accessor'}) }
+sub has_reader { defined($_[0]->{'reader'}) }
+sub has_writer { defined($_[0]->{'writer'}) }
+sub has_predicate { defined($_[0]->{'predicate'}) }
+sub has_clearer { defined($_[0]->{'clearer'}) }
+sub has_builder { defined($_[0]->{'builder'}) }
+sub has_init_arg { defined($_[0]->{'init_arg'}) }
+sub has_default { defined($_[0]->{'default'}) }
+sub has_initializer { defined($_[0]->{'initializer'}) }
+
+sub accessor { $_[0]->{'accessor'} }
+sub reader { $_[0]->{'reader'} }
+sub writer { $_[0]->{'writer'} }
+sub predicate { $_[0]->{'predicate'} }
+sub clearer { $_[0]->{'clearer'} }
+sub builder { $_[0]->{'builder'} }
+sub init_arg { $_[0]->{'init_arg'} }
+sub initializer { $_[0]->{'initializer'} }
+sub definition_context { $_[0]->{'definition_context'} }
# end bootstrapped away method section.
# (all methods below here are kept intact)
}
sub is_default_a_coderef {
- ('CODE' eq ref($_[0]->{'default'} || $_[0]->{default}))
+ ('CODE' eq ref($_[0]->{'default'}))
}
sub default {
sub set_initial_value {
my ($self, $instance, $value) = @_;
$self->_set_initial_slot_value(
- Class::MOP::Class->initialize(blessed($instance))->get_meta_instance,
+ Class::MOP::Class->initialize(ref($instance))->get_meta_instance,
$instance,
$value
);
sub set_value {
my ($self, $instance, $value) = @_;
- Class::MOP::Class->initialize(blessed($instance))
+ Class::MOP::Class->initialize(ref($instance))
->get_meta_instance
->set_slot_value($instance, $self->name, $value);
}
sub get_value {
my ($self, $instance) = @_;
- Class::MOP::Class->initialize(blessed($instance))
+ Class::MOP::Class->initialize(ref($instance))
->get_meta_instance
->get_slot_value($instance, $self->name);
}
sub has_value {
my ($self, $instance) = @_;
- Class::MOP::Class->initialize(blessed($instance))
+ Class::MOP::Class->initialize(ref($instance))
->get_meta_instance
->is_slot_initialized($instance, $self->name);
}
sub clear_value {
my ($self, $instance) = @_;
- Class::MOP::Class->initialize(blessed($instance))
+ Class::MOP::Class->initialize(ref($instance))
->get_meta_instance
->deinitialize_slot($instance, $self->name);
}
sub process_accessors {
my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
+
+ my $method_ctx;
+
+ if ( my $ctx = $self->definition_context ) {
+ $method_ctx = { %$ctx };
+ }
+
if (ref($accessor)) {
(ref($accessor) eq 'HASH')
|| confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
$method,
package_name => $self->associated_class->name,
name => $name,
+ definition_context => $method_ctx,
);
$self->associate_method($method);
return ($name, $method);
my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
my $method;
eval {
+ if ( $method_ctx ) {
+ my $desc = "accessor $accessor";
+ if ( $accessor ne $self->name ) {
+ $desc .= " of attribute " . $self->name;
+ }
+
+ $method_ctx->{description} = $desc;
+ }
+
$method = $self->accessor_metaclass->new(
attribute => $self,
is_inline => $inline_me,
accessor_type => $type,
package_name => $self->associated_class->name,
name => $accessor,
+ definition_context => $method_ctx,
);
};
confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
}
my $method = $class->get_method($accessor);
$class->remove_method($accessor)
- if (blessed($method) && $method->isa('Class::MOP::Method::Accessor'));
+ if (ref($method) && $method->isa('Class::MOP::Method::Accessor'));
};
sub remove_accessors {
projects / gitmo/Class-MOP.git / blobdiff