our
$VERSION
=
'0.97'
;
$VERSION
=
eval
$VERSION
;
our
$AUTHORITY
=
'cpan:STEVAN'
;
sub
new {
my
$class
=
shift
;
my
%options
=
@_
;
(blessed
$options
{metaclass} &&
$options
{metaclass}->isa(
'Class::MOP::Class'
))
|| confess
"You must pass a metaclass instance if you want to inline"
if
$options
{is_inline};
(
$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
->{
'associated_metaclass'
});
$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},
package_name
=>
$params
->{package_name},
name
=>
$params
->{name},
original_method
=>
$params
->{original_method},
is_inline
=>
$params
->{is_inline} || 0,
definition_context
=>
$params
->{definition_context},
_expected_method_class
=>
$params
->{_expected_method_class},
options
=>
$params
->{options} || {},
associated_metaclass
=>
$params
->{metaclass},
},
$class
;
}
sub
options { (
shift
)->{
'options'
} }
sub
associated_metaclass { (
shift
)->{
'associated_metaclass'
} }
sub
_meta_instance {
my
$self
=
shift
;
$self
->{
'meta_instance'
} ||=
$self
->associated_metaclass->get_meta_instance;
}
sub
_attributes {
my
$self
=
shift
;
$self
->{
'attributes'
} ||= [
$self
->associated_metaclass->get_all_attributes ]
}
sub
_initialize_body {
my
$self
=
shift
;
my
$method_name
=
'_generate_constructor_method'
;
$method_name
.=
'_inline'
if
$self
->is_inline;
$self
->{
'body'
} =
$self
->
$method_name
;
}
sub
_generate_constructor_method {
return
sub
{ Class::MOP::Class->initialize(
shift
)->new_object(
@_
) }
}
sub
_generate_constructor_method_inline {
my
$self
=
shift
;
my
$close_over
= {};
my
$source
=
'sub {'
;
$source
.=
"\n"
.
'my $class = shift;'
;
$source
.=
"\n"
.
'return Class::MOP::Class->initialize($class)->new_object(@_)'
;
$source
.=
"\n"
.
' if $class ne \''
.
$self
->associated_metaclass->name .
'\';'
;
$source
.=
"\n"
.
'my $params = @_ == 1 ? $_[0] : {@_};'
;
$source
.=
"\n"
.
'my $instance = '
.
$self
->_meta_instance->inline_create_instance(
'$class'
);
$source
.=
";\n"
. (
join
";\n"
=>
map
{
$self
->_generate_slot_initializer(
$_
,
$close_over
)
} @{
$self
->_attributes });
$source
.=
";\n"
.
'return $instance'
;
$source
.=
";\n"
.
'}'
;
warn
$source
if
$self
->options->{debug};
my
(
$code
,
$e
) =
$self
->_eval_closure(
$close_over
,
$source
);
confess
"Could not eval the constructor :\n\n$source\n\nbecause :\n\n$e"
if
$e
;
return
$code
;
}
sub
_generate_slot_initializer {
my
$self
=
shift
;
my
$attr
=
shift
;
my
$close
=
shift
;
my
$default
;
if
(
$attr
->has_default) {
if
(
$attr
->is_default_a_coderef) {
my
$idx
= @{
$close
->{
'@defaults'
}||=[]};
push
(@{
$close
->{
'@defaults'
}},
$attr
->
default
);
$default
=
'$defaults['
.
$idx
.
']->($instance)'
;
}
else
{
$default
=
$attr
->
default
;
unless
(looks_like_number(
$default
)) {
$default
=
"'$default'"
;
}
}
}
elsif
(
$attr
->has_builder ) {
$default
=
'$instance->'
.
$attr
->builder;
}
if
(
defined
(
my
$init_arg
=
$attr
->init_arg) ) {
return
(
'if(exists $params->{\''
.
$init_arg
.
'\'}){'
.
"\n"
.
$self
->_meta_instance->inline_set_slot_value(
'$instance'
,
$attr
->name,
'$params->{\''
.
$init_arg
.
'\'}'
) .
"\n"
.
'} '
. (!
defined
$default
?
''
:
'else {'
.
"\n"
.
$self
->_meta_instance->inline_set_slot_value(
'$instance'
,
$attr
->name,
$default
) .
"\n"
.
'}'
)
);
}
elsif
(
defined
$default
) {
return
(
$self
->_meta_instance->inline_set_slot_value(
'$instance'
,
$attr
->name,
$default
) .
"\n"
);
}
else
{
return
''
}
}
1;