Commit | Line | Data |
acf10771 |
1 | |
2 | package Moose::Meta::Method::Destructor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
b288593e |
7 | use Devel::GlobalDestruction (); |
acf10771 |
8 | use Scalar::Util 'blessed', 'weaken'; |
55c361dc |
9 | use Try::Tiny; |
acf10771 |
10 | |
badb7e89 |
11 | use base 'Moose::Meta::Method', |
f4aef447 |
12 | 'Class::MOP::Method::Inlined'; |
acf10771 |
13 | |
14 | sub new { |
15 | my $class = shift; |
16 | my %options = @_; |
d03bd989 |
17 | |
46cb090f |
18 | (ref $options{options} eq 'HASH') |
19 | || $class->throw_error("You must pass a hash of options", data => $options{options}); |
20 | |
1b2aea39 |
21 | ($options{package_name} && $options{name}) |
46cb090f |
22 | || $class->throw_error("You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT"); |
23 | |
acf10771 |
24 | my $self = bless { |
25 | # from our superclass |
d03bd989 |
26 | 'body' => undef, |
e606ae5f |
27 | 'package_name' => $options{package_name}, |
d03bd989 |
28 | 'name' => $options{name}, |
acf10771 |
29 | # ... |
d03bd989 |
30 | 'options' => $options{options}, |
0f1a71fc |
31 | 'definition_context' => $options{definition_context}, |
e606ae5f |
32 | 'associated_metaclass' => $options{metaclass}, |
acf10771 |
33 | } => $class; |
34 | |
d03bd989 |
35 | # we don't want this creating |
36 | # a cycle in the code, if not |
acf10771 |
37 | # needed |
d03bd989 |
38 | weaken($self->{'associated_metaclass'}); |
acf10771 |
39 | |
bfaa304c |
40 | $self->_initialize_body; |
acf10771 |
41 | |
d03bd989 |
42 | return $self; |
acf10771 |
43 | } |
44 | |
d03bd989 |
45 | ## accessors |
acf10771 |
46 | |
e606ae5f |
47 | sub options { (shift)->{'options'} } |
acf10771 |
48 | |
49 | ## method |
50 | |
a7b097bb |
51 | sub is_needed { |
52 | my $self = shift; |
53 | my $metaclass = shift; |
54 | |
55 | ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') ) |
56 | || $self->throw_error( |
57 | "The is_needed method expected a metaclass object as its arugment"); |
58 | |
8c86556c |
59 | return $metaclass->find_method_by_name("DEMOLISHALL"); |
9d22affb |
60 | } |
acf10771 |
61 | |
415e6f85 |
62 | sub initialize_body { |
8b7cb9ab |
63 | Carp::cluck('The initialize_body method has been made private.' |
64 | . " The public version is deprecated and will be removed in a future release.\n"); |
bfaa304c |
65 | shift->_initialize_body; |
66 | } |
67 | |
68 | sub _initialize_body { |
acf10771 |
69 | my $self = shift; |
70 | # TODO: |
d03bd989 |
71 | # the %options should also include a both |
72 | # a call 'initializer' and call 'SUPER::' |
73 | # options, which should cover approx 90% |
74 | # of the possible use cases (even if it |
75 | # requires some adaption on the part of |
acf10771 |
76 | # the author, after all, nothing is free) |
d03bd989 |
77 | |
f0b2e567 |
78 | my $class = $self->associated_metaclass->name; |
79 | my @source = ( |
80 | 'sub {', |
81 | 'my $self = shift;', |
82 | 'return ' . $self->_generate_fallback_destructor('$self'), |
83 | 'if Scalar::Util::blessed($self) ne \'' . $class . '\';', |
ee96986a |
84 | 'local $?;', |
f0b2e567 |
85 | $self->_generate_DEMOLISHALL('$self'), |
ee96986a |
86 | 'return;', |
f0b2e567 |
87 | '}', |
88 | ); |
89 | warn join("\n", @source) if $self->options->{debug}; |
d03bd989 |
90 | |
55c361dc |
91 | my $code = try { |
f0b2e567 |
92 | $self->_compile_code(source => \@source); |
55c361dc |
93 | } |
94 | catch { |
f0b2e567 |
95 | my $source = join("\n", @source); |
55c361dc |
96 | $self->throw_error( |
97 | "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$_", |
98 | error => $_, |
99 | data => $source, |
100 | ); |
101 | }; |
497442e8 |
102 | |
e606ae5f |
103 | $self->{'body'} = $code; |
acf10771 |
104 | } |
105 | |
f0b2e567 |
106 | sub _generate_fallback_destructor { |
107 | my $self = shift; |
108 | my ($inv) = @_; |
109 | |
110 | return $inv . '->Moose::Object::DESTROY(@_)'; |
111 | } |
112 | |
113 | sub _generate_DEMOLISHALL { |
114 | my $self = shift; |
115 | my ($inv) = @_; |
116 | |
117 | my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH'); |
118 | return unless @methods; |
119 | |
120 | return ( |
f0b2e567 |
121 | 'my $igd = Devel::GlobalDestruction::in_global_destruction;', |
122 | 'Try::Tiny::try {', |
123 | (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods), |
124 | '}', |
125 | 'Try::Tiny::catch {', |
f0b2e567 |
126 | 'die $_;', |
127 | '};', |
f0b2e567 |
128 | ); |
129 | } |
130 | |
acf10771 |
131 | |
132 | 1; |
133 | |
ad46f524 |
134 | # ABSTRACT: Method Meta Object for destructors |
135 | |
acf10771 |
136 | __END__ |
137 | |
138 | =pod |
139 | |
587ae0d2 |
140 | =head1 DESCRIPTION |
141 | |
6f970df6 |
142 | This class is a subclass of L<Class::MOP::Method::Inlined> that |
bcb81995 |
143 | provides Moose-specific functionality for inlining destructors. |
144 | |
145 | To understand this class, you should read the the |
6f970df6 |
146 | L<Class::MOP::Method::Inlined> documentation as well. |
bcb81995 |
147 | |
148 | =head1 INHERITANCE |
149 | |
150 | C<Moose::Meta::Method::Destructor> is a subclass of |
6f970df6 |
151 | L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Inlined>. |
d44714be |
152 | |
587ae0d2 |
153 | =head1 METHODS |
154 | |
155 | =over 4 |
156 | |
bcac984a |
157 | =item B<< Moose::Meta::Method::Destructor->new(%options) >> |
bcb81995 |
158 | |
159 | This constructs a new object. It accepts the following options: |
160 | |
161 | =over 8 |
587ae0d2 |
162 | |
bcb81995 |
163 | =item * package_name |
587ae0d2 |
164 | |
bcb81995 |
165 | The package for the class in which the destructor is being |
166 | inlined. This option is required. |
587ae0d2 |
167 | |
bcb81995 |
168 | =item * name |
587ae0d2 |
169 | |
bcb81995 |
170 | The name of the destructor method. This option is required. |
171 | |
172 | =item * metaclass |
173 | |
174 | The metaclass for the class this destructor belongs to. This is |
175 | optional, as it can be set later by calling C<< |
176 | $metamethod->attach_to_class >>. |
177 | |
178 | =back |
587ae0d2 |
179 | |
bcb81995 |
180 | =item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >> |
587ae0d2 |
181 | |
bcb81995 |
182 | Given a L<Moose::Meta::Class> object, this method returns a boolean |
183 | indicating whether the class needs a destructor. If the class or any |
184 | of its parents defines a C<DEMOLISH> method, it needs a destructor. |
587ae0d2 |
185 | |
186 | =back |
187 | |
c5fc2c21 |
188 | =head1 BUGS |
189 | |
190 | See L<Moose/BUGS> for details on reporting bugs. |
191 | |
587ae0d2 |
192 | =cut |
193 | |