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
|
package MooseX::NonMoose::Meta::Role::Class;
use Moose::Role;
has has_nonmoose_constructor => (
is => 'rw',
isa => 'Bool',
default => 0,
);
around _immutable_options => sub {
my $orig = shift;
my $self = shift;
# do nothing if extends was never called
return $self->$orig(@_) if !$self->has_nonmoose_constructor;
# if we're using just the metaclass trait, but not the constructor trait,
# then suppress the warning about not inlining a constructor
return $self->$orig(inline_constructor => 0, @_)
unless Class::MOP::class_of($self->constructor_class)->does_role('MooseX::NonMoose::Meta::Role::Constructor');
# do nothing if extends was called, but we then added a method modifier to
# the constructor (this will warn, but that's okay)
return $self->$orig(@_)
if $self->get_method('new')->isa('Class::MOP::Method::Wrapped');
# do nothing if we explicitly ask for the constructor to not be inlined
my %args = @_;
return $self->$orig(@_) if !$args{inline_constructor};
# otherwise, explicitly ask for the constructor to be replaced (to suppress
# the warning message), since this is the expected usage, and shouldn't
# cause a warning
return $self->$orig(replace_constructor => 1, @_);
};
around superclasses => sub {
my $orig = shift;
my $self = shift;
return $self->$orig unless @_;
my @superclasses = @_;
push @superclasses, 'Moose::Object'
unless grep { $_->isa('Moose::Object') } @superclasses;
my @ret = $self->$orig(@superclasses);
# we need to get the non-moose constructor from the superclass
# of the class where this method actually exists, regardless of what class
# we're calling it on
# XXX: get constructor name from the constructor metaclass?
my $super_new = $self->find_next_method_by_name('new');
# if we're trying to extend a (non-immutable) moose class, just do nothing
return @ret if $super_new->package_name eq 'Moose::Object';
if ($super_new->associated_metaclass->can('constructor_class')) {
my $constructor_class_meta = Class::MOP::Class->initialize(
$super_new->associated_metaclass->constructor_class
);
# if the constructor we're inheriting is already one of ours, there's
# no reason to install a new one
return @ret if $constructor_class_meta->can('does_role')
&& $constructor_class_meta->does_role('MooseX::NonMoose::Meta::Role::Constructor');
# if the constructor we're inheriting is an inlined version of the
# default moose constructor, don't do anything either
# XXX: wrong if the class overrode new manually?
return @ret if $constructor_class_meta->name eq 'Moose::Meta::Method::Constructor';
}
$self->add_method(new => sub {
my $class = shift;
my $params = $class->BUILDARGS(@_);
my $instance = $super_new->execute($class, @_);
my $self = Class::MOP::Class->initialize($class)->new_object(
__INSTANCE__ => $instance,
%$params,
);
$self->BUILDALL($params);
return $self;
});
$self->has_nonmoose_constructor(1);
return @ret;
};
no Moose::Role;
1;
|
