blob: 272bc95f231caaa031b75960841792d18026ba2d (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
package MooseX::NonMoose::Meta::Role::Constructor;
use Moose::Role;
# ABSTRACT: constructor method trait for L<MooseX::NonMoose>
=head1 SYNOPSIS
package My::Moose;
use Moose ();
use Moose::Exporter;
Moose::Exporter->setup_import_methods;
sub init_meta {
shift;
my %options = @_;
Moose->init_meta(%options);
Moose::Util::MetaRole::apply_metaclass_roles(
for_class => $options{for_class},
metaclass_roles => ['MooseX::NonMoose::Meta::Role::Class'],
constructor_class_roles =>
['MooseX::NonMoose::Meta::Role::Constructor'],
);
return Class::MOP::class_of($options{for_class});
}
=head1 DESCRIPTION
This trait implements inlining of the constructor for classes using the
L<MooseX::NonMoose::Meta::Role::Class> metaclass trait; it has no effect unless
that trait is also used. See those docs and the docs for L<MooseX::NonMoose>
for more information.
=cut
around can_be_inlined => sub {
my $orig = shift;
my $self = shift;
my $meta = $self->associated_metaclass;
my $super_new = $meta->find_method_by_name($self->name);
my $super_meta = $super_new->associated_metaclass;
if (Class::MOP::class_of($super_meta)->can('does_role')
&& Class::MOP::class_of($super_meta)->does_role('MooseX::NonMoose::Meta::Role::Class')) {
return 1;
}
return $self->$orig(@_);
};
# for Moose 1.21 compatibility
sub _generate_fallback_constructor {
my $self = shift;
my ($class_var) = @_;
my $new = $self->name;
my $meta = $self->associated_metaclass;
my $super_new_class = $meta->_find_next_nonmoose_constructor_package;
my $arglist = $meta->find_method_by_name('FOREIGNBUILDARGS')
? "${class_var}->FOREIGNBUILDARGS(\@_)"
: '@_';
my $instance = "${class_var}->${super_new_class}::$new($arglist)";
# XXX: the "my $__DUMMY = " part is because "return do" triggers a weird
# bug in pre-5.12 perls (it ends up returning undef)
"my \$__DUMMY = do {\n"
. " if (ref(\$_[0]) eq 'HASH') {\n"
. " \$_[0]->{__INSTANCE__} = $instance\n"
. " unless exists \$_[0]->{__INSTANCE__};\n"
. " }\n"
. " else {\n"
. " unshift \@_, __INSTANCE__ => $instance;\n"
. " }\n"
. " ${class_var}->Moose::Object::new(\@_);\n"
. "}";
}
# for Moose 1.21 compatibility
sub _generate_instance {
my $self = shift;
my ($var, $class_var) = @_;
my $new = $self->name;
my $meta = $self->associated_metaclass;
my $super_new_class = $meta->_find_next_nonmoose_constructor_package;
my $arglist = $meta->find_method_by_name('FOREIGNBUILDARGS')
? "${class_var}->FOREIGNBUILDARGS(\@_)"
: '@_';
my $instance = "${class_var}->${super_new_class}::$new($arglist)";
return "my $var = $instance;\n"
. "if (!Scalar::Util::blessed($var)) {\n"
. " " . $self->_inline_throw_error(
"'The constructor for $super_new_class did not return a blessed instance'"
) . ";\n"
. "}\n"
. "elsif (!$var->isa($class_var)) {\n"
. " if (!$class_var->isa(Scalar::Util::blessed($var))) {\n"
. " " . $self->_inline_throw_error(
"\"The constructor for $super_new_class returned an object whose class is not a parent of $class_var\""
) . ";\n"
. " }\n"
. " else {\n"
. " " . $self->associated_metaclass->inline_rebless_instance($var, $class_var) . ";\n"
. " }\n"
. "}\n";
}
no Moose::Role;
1;
|
