X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FMethod%2FDestructor.pm;h=e06a13d240d2f7bdc5c2b30997c0d70743a7fba5;hb=054898323542f0f85865b5d8fad49c3f4ee982c6;hp=9d9e1a39233174d13f668e52769c8eba61f4cec2;hpb=d493b71a848c8df48c4b8823c357d95b3e3fdd83;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm index 9d9e1a3..e06a13d 100644 --- a/lib/Moose/Meta/Method/Destructor.pm +++ b/lib/Moose/Meta/Method/Destructor.pm @@ -4,19 +4,17 @@ package Moose::Meta::Method::Destructor; use strict; use warnings; +use Devel::GlobalDestruction (); use Scalar::Util 'blessed', 'weaken'; - -our $VERSION = '0.73_01'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use Try::Tiny; use base 'Moose::Meta::Method', - 'Class::MOP::Method::Generated'; + 'Class::MOP::Method::Inlined'; sub new { my $class = shift; my %options = @_; - + (ref $options{options} eq 'HASH') || $class->throw_error("You must pass a hash of options", data => $options{options}); @@ -25,25 +23,26 @@ sub new { my $self = bless { # from our superclass - 'body' => undef, + 'body' => undef, 'package_name' => $options{package_name}, - 'name' => $options{name}, + 'name' => $options{name}, # ... - 'options' => $options{options}, + 'options' => $options{options}, + 'definition_context' => $options{definition_context}, 'associated_metaclass' => $options{metaclass}, } => $class; - # we don't want this creating - # a cycle in the code, if not + # we don't want this creating + # a cycle in the code, if not # needed - weaken($self->{'associated_metaclass'}); + weaken($self->{'associated_metaclass'}); $self->_initialize_body; - return $self; + return $self; } -## accessors +## accessors sub options { (shift)->{'options'} } @@ -57,78 +56,105 @@ sub is_needed { || $self->throw_error( "The is_needed method expected a metaclass object as its arugment"); - return $metaclass->find_method_by_name('DEMOLISH'); + return $metaclass->find_method_by_name("DEMOLISHALL"); } sub initialize_body { - warn 'The initialize_body method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"; + Carp::cluck('The initialize_body method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); shift->_initialize_body; } sub _initialize_body { my $self = shift; # TODO: - # the %options should also include a both - # a call 'initializer' and call 'SUPER::' - # options, which should cover approx 90% - # of the possible use cases (even if it - # requires some adaption on the part of + # the %options should also include a both + # a call 'initializer' and call 'SUPER::' + # options, which should cover approx 90% + # of the possible use cases (even if it + # requires some adaption on the part of # the author, after all, nothing is free) - - my @DEMOLISH_methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH'); - - return unless @DEMOLISH_methods; - - my $source = 'sub {'; - - my @DEMOLISH_calls; - foreach my $method (@DEMOLISH_methods) { - push @DEMOLISH_calls => '$_[0]->' . $method->{class} . '::DEMOLISH()'; - } - - $source .= join ";\n" => @DEMOLISH_calls; - $source .= ";\n" . '}'; - warn $source if $self->options->{debug}; - - my $code = $self->_compile_code( - environment => {}, - code => $source, - ) or $self->throw_error("Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source); + my $class = $self->associated_metaclass->name; + my @source = ( + 'sub {', + 'my $self = shift;', + 'return ' . $self->_generate_fallback_destructor('$self'), + 'if Scalar::Util::blessed($self) ne \'' . $class . '\';', + $self->_generate_DEMOLISHALL('$self'), + 'return;', + '}', + ); + warn join("\n", @source) if $self->options->{debug}; + + my $code = try { + $self->_compile_code(source => \@source); + } + catch { + my $source = join("\n", @source); + $self->throw_error( + "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$_", + error => $_, + data => $source, + ); + }; $self->{'body'} = $code; } +sub _generate_fallback_destructor { + my $self = shift; + my ($inv) = @_; + + return $inv . '->Moose::Object::DESTROY(@_)'; +} + +sub _generate_DEMOLISHALL { + my $self = shift; + my ($inv) = @_; + + my @methods = $self->associated_metaclass->find_all_methods_by_name('DEMOLISH'); + return unless @methods; + + return ( + 'local $?;', + 'my $igd = Devel::GlobalDestruction::in_global_destruction;', + 'Try::Tiny::try {', + (map { $inv . '->' . $_->{class} . '::DEMOLISH($igd);' } @methods), + '}', + 'Try::Tiny::catch {', + 'die $_;', + '};', + ); +} + 1; +# ABSTRACT: Method Meta Object for destructors + __END__ =pod -=head1 NAME - -Moose::Meta::Method::Destructor - Method Meta Object for destructors - =head1 DESCRIPTION -This class is a subclass of L that +This class is a subclass of L that provides Moose-specific functionality for inlining destructors. To understand this class, you should read the the -L documentation as well. +L documentation as well. =head1 INHERITANCE C is a subclass of -L I L. +L I L. =head1 METHODS =over 4 -=item B<< Moose::Meta;:Method::Destructor->new(%options) >> +=item B<< Moose::Meta::Method::Destructor->new(%options) >> This constructs a new object. It accepts the following options: @@ -159,18 +185,9 @@ of its parents defines a C method, it needs a destructor. =back -=head1 AUTHORS - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2009 by Infinity Interactive, Inc. - -L +=head1 BUGS -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +See L for details on reporting bugs. =cut