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