our
$VERSION
=
'0.94'
;
$VERSION
=
eval
$VERSION
;
our
$AUTHORITY
=
'cpan:STEVAN'
;
sub
new {
my
$class
=
shift
;
my
%options
=
@_
;
(
exists
$options
{attribute})
|| confess
"You must supply an attribute to construct with"
;
(
exists
$options
{accessor_type})
|| confess
"You must supply an accessor_type to construct with"
;
(blessed(
$options
{attribute}) &&
$options
{attribute}->isa(
'Class::MOP::Attribute'
))
|| confess
"You must supply an attribute which is a 'Class::MOP::Attribute' instance"
;
(
$options
{package_name} &&
$options
{name})
|| confess
"You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"
;
my
$self
=
$class
->_new(\
%options
);
weaken(
$self
->{
'attribute'
});
$self
->_initialize_body;
return
$self
;
}
sub
_new {
my
$class
=
shift
;
return
Class::MOP::Class->initialize(
$class
)->new_object(
@_
)
if
$class
ne __PACKAGE__;
my
$params
=
@_
== 1 ?
$_
[0] : {
@_
};
return
bless
{
body
=>
$params
->{body},
associated_metaclass
=>
$params
->{associated_metaclass},
package_name
=>
$params
->{package_name},
name
=>
$params
->{name},
original_method
=>
$params
->{original_method},
is_inline
=>
$params
->{is_inline} || 0,
definition_context
=>
$params
->{definition_context},
attribute
=>
$params
->{attribute},
accessor_type
=>
$params
->{accessor_type},
} =>
$class
;
}
sub
associated_attribute { (
shift
)->{
'attribute'
} }
sub
accessor_type { (
shift
)->{
'accessor_type'
} }
sub
_initialize_body {
my
$self
=
shift
;
my
$method_name
=
join
"_"
=> (
'_generate'
,
$self
->accessor_type,
'method'
,
(
$self
->is_inline ?
'inline'
: ())
);
$self
->{
'body'
} =
$self
->
$method_name
();
}
sub
_generate_accessor_method {
my
$attr
= (
shift
)->associated_attribute;
return
sub
{
$attr
->set_value(
$_
[0],
$_
[1])
if
scalar
(
@_
) == 2;
$attr
->get_value(
$_
[0]);
};
}
sub
_generate_reader_method {
my
$attr
= (
shift
)->associated_attribute;
return
sub
{
confess
"Cannot assign a value to a read-only accessor"
if
@_
> 1;
$attr
->get_value(
$_
[0]);
};
}
sub
_generate_writer_method {
my
$attr
= (
shift
)->associated_attribute;
return
sub
{
$attr
->set_value(
$_
[0],
$_
[1]);
};
}
sub
_generate_predicate_method {
my
$attr
= (
shift
)->associated_attribute;
return
sub
{
$attr
->has_value(
$_
[0])
};
}
sub
_generate_clearer_method {
my
$attr
= (
shift
)->associated_attribute;
return
sub
{
$attr
->clear_value(
$_
[0])
};
}
sub
_generate_accessor_method_inline {
my
$self
=
shift
;
my
$attr
=
$self
->associated_attribute;
my
$attr_name
=
$attr
->name;
my
$meta_instance
=
$attr
->associated_class->instance_metaclass;
my
(
$code
,
$e
) =
$self
->_eval_closure(
{},
'sub {'
.
$meta_instance
->inline_set_slot_value(
'$_[0]'
,
$attr_name
,
'$_[1]'
)
.
' if scalar(@_) == 2; '
.
$meta_instance
->inline_get_slot_value(
'$_[0]'
,
$attr_name
)
.
'}'
);
confess
"Could not generate inline accessor because : $e"
if
$e
;
return
$code
;
}
sub
_generate_reader_method_inline {
my
$self
=
shift
;
my
$attr
=
$self
->associated_attribute;
my
$attr_name
=
$attr
->name;
my
$meta_instance
=
$attr
->associated_class->instance_metaclass;
my
(
$code
,
$e
) =
$self
->_eval_closure(
{},
'sub {'
.
'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
.
$meta_instance
->inline_get_slot_value(
'$_[0]'
,
$attr_name
)
.
'}'
);
confess
"Could not generate inline reader because : $e"
if
$e
;
return
$code
;
}
sub
_generate_writer_method_inline {
my
$self
=
shift
;
my
$attr
=
$self
->associated_attribute;
my
$attr_name
=
$attr
->name;
my
$meta_instance
=
$attr
->associated_class->instance_metaclass;
my
(
$code
,
$e
) =
$self
->_eval_closure(
{},
'sub {'
.
$meta_instance
->inline_set_slot_value(
'$_[0]'
,
$attr_name
,
'$_[1]'
)
.
'}'
);
confess
"Could not generate inline writer because : $e"
if
$e
;
return
$code
;
}
sub
_generate_predicate_method_inline {
my
$self
=
shift
;
my
$attr
=
$self
->associated_attribute;
my
$attr_name
=
$attr
->name;
my
$meta_instance
=
$attr
->associated_class->instance_metaclass;
my
(
$code
,
$e
) =
$self
->_eval_closure(
{},
'sub {'
.
$meta_instance
->inline_is_slot_initialized(
'$_[0]'
,
$attr_name
)
.
'}'
);
confess
"Could not generate inline predicate because : $e"
if
$e
;
return
$code
;
}
sub
_generate_clearer_method_inline {
my
$self
=
shift
;
my
$attr
=
$self
->associated_attribute;
my
$attr_name
=
$attr
->name;
my
$meta_instance
=
$attr
->associated_class->instance_metaclass;
my
(
$code
,
$e
) =
$self
->_eval_closure(
{},
'sub {'
.
$meta_instance
->inline_deinitialize_slot(
'$_[0]'
,
$attr_name
)
.
'}'
);
confess
"Could not generate inline clearer because : $e"
if
$e
;
return
$code
;
}
1;