Commit | Line | Data |
acf10771 |
1 | |
2 | package Moose::Meta::Method::Destructor; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use Carp 'confess'; |
8 | use Scalar::Util 'blessed', 'weaken'; |
9 | |
10 | our $VERSION = '0.01'; |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
12 | |
13 | use base 'Moose::Meta::Method'; |
14 | |
15 | sub new { |
16 | my $class = shift; |
17 | my %options = @_; |
18 | |
19 | (exists $options{options} && ref $options{options} eq 'HASH') |
20 | || confess "You must pass a hash of options"; |
21 | |
22 | my $self = bless { |
23 | # from our superclass |
24 | '&!body' => undef, |
25 | # ... |
26 | '%!options' => $options{options}, |
27 | '$!associated_metaclass' => $options{metaclass}, |
28 | } => $class; |
29 | |
30 | # we don't want this creating |
31 | # a cycle in the code, if not |
32 | # needed |
33 | weaken($self->{'$!associated_metaclass'}); |
34 | |
35 | $self->intialize_body; |
36 | |
37 | return $self; |
38 | } |
39 | |
40 | ## accessors |
41 | |
42 | sub options { (shift)->{'%!options'} } |
43 | sub associated_metaclass { (shift)->{'$!associated_metaclass'} } |
44 | |
45 | ## method |
46 | |
47 | sub is_needed { defined $_[0]->{'&!body'} ? 1 : 0 } |
48 | |
49 | sub intialize_body { |
50 | my $self = shift; |
51 | # TODO: |
52 | # the %options should also include a both |
53 | # a call 'initializer' and call 'SUPER::' |
54 | # options, which should cover approx 90% |
55 | # of the possible use cases (even if it |
56 | # requires some adaption on the part of |
57 | # the author, after all, nothing is free) |
58 | my $source = 'sub {'; |
59 | |
60 | my @DEMOLISH_calls; |
61 | foreach my $method ($self->associated_metaclass->find_all_methods_by_name('DEMOLISH')) { |
62 | push @DEMOLISH_calls => '$_[0]->' . $method->{class} . '::DEMOLISH()'; |
63 | } |
64 | |
65 | $source .= join "\n" => @DEMOLISH_calls; |
66 | |
67 | $source .= ";\n" . '}'; |
68 | warn $source if $self->options->{debug}; |
69 | |
70 | my $code; |
71 | { |
72 | $code = eval $source; |
73 | confess "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@" if $@; |
74 | } |
75 | $self->{'&!body'} = $code; |
76 | } |
77 | |
78 | |
79 | 1; |
80 | |
81 | __END__ |
82 | |
83 | =pod |
84 | |
587ae0d2 |
85 | =head1 NAME |
86 | |
87 | Moose::Meta::Method::Destructor - Method Meta Object for destructors |
88 | |
587ae0d2 |
89 | =head1 DESCRIPTION |
90 | |
d44714be |
91 | This is a subclass of L<Class::MOP::Method> which handles |
92 | constructing an approprate Destructor method. This is primarily |
93 | used in the making of immutable metaclasses, otherwise it is |
94 | not particularly useful. |
95 | |
587ae0d2 |
96 | =head1 METHODS |
97 | |
98 | =over 4 |
99 | |
100 | =item B<new> |
101 | |
102 | =item B<attributes> |
103 | |
104 | =item B<meta_instance> |
105 | |
106 | =item B<options> |
107 | |
108 | =item B<is_needed> |
109 | |
110 | =item B<intialize_body> |
111 | |
112 | =item B<associated_metaclass> |
113 | |
114 | =back |
115 | |
116 | =head1 AUTHORS |
117 | |
118 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
119 | |
120 | =head1 COPYRIGHT AND LICENSE |
121 | |
b77fdbed |
122 | Copyright 2006, 2007 by Infinity Interactive, Inc. |
587ae0d2 |
123 | |
124 | L<http://www.iinteractive.com> |
125 | |
126 | This library is free software; you can redistribute it and/or modify |
127 | it under the same terms as Perl itself. |
128 | |
129 | =cut |
130 | |