lib/Moose/Meta/Method/Destructor.pm

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