File Coverage

blib/lib/Moose/Meta/Method/Destructor.pm
Criterion Covered Total %
statement 52 52 100.0
branch 9 10 90.0
condition 4 6 66.6
subroutine 15 15 100.0
pod 2 3 66.6
total 82 86 95.3


line stmt bran cond sub pod time code
1             package Moose::Meta::Method::Destructor;
2             our $VERSION = '2.2205';
3              
4 380     380   2764 use strict;
  380         927  
  380         12690  
5 380     380   4709 use warnings;
  380         854  
  380         11095  
6              
7 380     380   2307 use Devel::GlobalDestruction ();
  380         875  
  380         9107  
8 380     380   2180 use Scalar::Util 'blessed', 'weaken';
  380         919  
  380         20422  
9 380     380   3661 use Try::Tiny;
  380         2355  
  380         23799  
10              
11 380         2523 use parent 'Moose::Meta::Method',
12 380     380   2691 'Class::MOP::Method::Inlined';
  380         1055  
13              
14 380     380   33928 use Moose::Util 'throw_exception';
  380         1084  
  380         3909  
15              
16             sub new {
17 745     745 1 2490 my $class = shift;
18 745         3989 my %options = @_;
19              
20 745 100       3849 (ref $options{options} eq 'HASH')
21             || throw_exception( MustPassAHashOfOptions => params => \%options,
22             class => $class
23             );
24              
25             ($options{package_name} && $options{name})
26 744 100 66     4964 || throw_exception( MustSupplyPackageNameAndName => params => \%options,
27             class => $class
28             );
29              
30             my $self = bless {
31             # from our superclass
32             'body' => undef,
33             'package_name' => $options{package_name},
34             'name' => $options{name},
35             # ...
36             'options' => $options{options},
37             'definition_context' => $options{definition_context},
38             'associated_metaclass' => $options{metaclass},
39 743         5041 } => $class;
40              
41             # we don't want this creating
42             # a cycle in the code, if not
43             # needed
44 743         18931 weaken($self->{'associated_metaclass'});
45              
46 743         3331 $self->_initialize_body;
47              
48 742         3838 return $self;
49             }
50              
51             ## accessors
52              
53 743     743 0 4035 sub options { (shift)->{'options'} }
54              
55             ## method
56              
57             sub is_needed {
58 759     759 1 2153 my $self = shift;
59 759         2095 my $metaclass = shift;
60              
61 759 100 66     8546 ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') )
62             || throw_exception( MethodExpectedAMetaclassObject => metaclass => $metaclass,
63             class => $self
64             );
65              
66 758         3334 return $metaclass->find_method_by_name("DEMOLISHALL");
67             }
68              
69             sub _initialize_body {
70 743     743   1681 my $self = shift;
71             # TODO:
72             # the %options should also include a both
73             # a call 'initializer' and call 'SUPER::'
74             # options, which should cover approx 90%
75             # of the possible use cases (even if it
76             # requires some adaption on the part of
77             # the author, after all, nothing is free)
78              
79 743         3928 my $class = $self->associated_metaclass->name;
80 743         4029 my @source = (
81             'sub {',
82             'my $self = shift;',
83             'return ' . $self->_generate_fallback_destructor('$self'),
84             'if Scalar::Util::blessed($self) ne \'' . $class . '\';',
85             $self->_generate_DEMOLISHALL('$self'),
86             'return;',
87             '}',
88             );
89 743 50       4029 warn join("\n", @source) if $self->options->{debug};
90              
91             my $code = try {
92 743     743   37151 $self->_compile_code(source => \@source);
93             }
94             catch {
95 1     1   396 my $source = join("\n", @source);
96 1         5 throw_exception( CouldNotEvalDestructor => method_destructor_object => $self,
97             source => $source,
98             error => $_
99             );
100 743         7835 };
101              
102 742         44008 $self->{'body'} = $code;
103             }
104              
105             sub _generate_fallback_destructor {
106 743     743   1705 my $self = shift;
107 743         1953 my ($inv) = @_;
108              
109 743         4940 return $inv . '->Moose::Object::DESTROY(@_)';
110             }
111              
112             sub _generate_DEMOLISHALL {
113 742     742   1700 my $self = shift;
114 742         2677 my ($inv) = @_;
115              
116 742         2966 my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH');
117 742 100       5413 return unless @methods;
118              
119             return (
120             'local $?;',
121             'my $igd = Devel::GlobalDestruction::in_global_destruction;',
122             'Try::Tiny::try {',
123 9         39 (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods),
  10         88  
124             '}',
125             'Try::Tiny::catch {',
126             'die $_;',
127             '};',
128             );
129             }
130              
131              
132             1;
133              
134             # ABSTRACT: Method Meta Object for destructors
135              
136             __END__
137              
138             =pod
139              
140             =encoding UTF-8
141              
142             =head1 NAME
143              
144             Moose::Meta::Method::Destructor - Method Meta Object for destructors
145              
146             =head1 VERSION
147              
148             version 2.2205
149              
150             =head1 DESCRIPTION
151              
152             This class is a subclass of L<Class::MOP::Method::Inlined> that
153             provides Moose-specific functionality for inlining destructors.
154              
155             To understand this class, you should read the
156             L<Class::MOP::Method::Inlined> documentation as well.
157              
158             =head1 INHERITANCE
159              
160             C<Moose::Meta::Method::Destructor> is a subclass of
161             L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Inlined>.
162              
163             =head1 METHODS
164              
165             =head2 Moose::Meta::Method::Destructor->new(%options)
166              
167             This constructs a new object. It accepts the following options:
168              
169             =over 4
170              
171             =item * package_name
172              
173             The package for the class in which the destructor is being
174             inlined. This option is required.
175              
176             =item * name
177              
178             The name of the destructor method. This option is required.
179              
180             =item * metaclass
181              
182             The metaclass for the class this destructor belongs to. This is
183             optional, as it can be set later by calling C<<
184             $metamethod->attach_to_class >>.
185              
186             =back
187              
188             =head2 Moose::Meta;:Method::Destructor->is_needed($metaclass)
189              
190             Given a L<Moose::Meta::Class> object, this method returns a boolean
191             indicating whether the class needs a destructor. If the class or any
192             of its parents defines a C<DEMOLISH> method, it needs a destructor.
193              
194             =head1 BUGS
195              
196             See L<Moose/BUGS> for details on reporting bugs.
197              
198             =head1 AUTHORS
199              
200             =over 4
201              
202             =item *
203              
204             Stevan Little <stevan@cpan.org>
205              
206             =item *
207              
208             Dave Rolsky <autarch@urth.org>
209              
210             =item *
211              
212             Jesse Luehrs <doy@cpan.org>
213              
214             =item *
215              
216             Shawn M Moore <sartak@cpan.org>
217              
218             =item *
219              
220             יובל קוג'מן (Yuval Kogman) <nothingmuch@woobling.org>
221              
222             =item *
223              
224             Karen Etheridge <ether@cpan.org>
225              
226             =item *
227              
228             Florian Ragwitz <rafl@debian.org>
229              
230             =item *
231              
232             Hans Dieter Pearcey <hdp@cpan.org>
233              
234             =item *
235              
236             Chris Prather <chris@prather.org>
237              
238             =item *
239              
240             Matt S Trout <mstrout@cpan.org>
241              
242             =back
243              
244             =head1 COPYRIGHT AND LICENSE
245              
246             This software is copyright (c) 2006 by Infinity Interactive, Inc.
247              
248             This is free software; you can redistribute it and/or modify it under
249             the same terms as the Perl 5 programming language system itself.
250              
251             =cut