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=db82b1f550895246a8356467a8185b126b47d9c3;hpb=a7be0f8593e4e7b7f570f49027ee4f8f25d4d8bc;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm index db82b1f..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.69'; -$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,127 +23,171 @@ 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; + $self->_initialize_body; - return $self; + return $self; } -## accessors +## accessors sub options { (shift)->{'options'} } -sub associated_metaclass { (shift)->{'associated_metaclass'} } ## method -sub is_needed { - my $self = shift; - # if called as a class method - # then must pass in a class name - unless (blessed $self) { - (blessed $_[0] && $_[0]->isa('Class::MOP::Class')) - || $self->throw_error("When calling is_needed as a class method you must pass a class name"); - return $_[0]->meta->can('DEMOLISH'); - } - defined $self->{'body'} ? 1 : 0 +sub is_needed { + my $self = shift; + my $metaclass = shift; + + ( blessed $metaclass && $metaclass->isa('Class::MOP::Class') ) + || $self->throw_error( + "The is_needed method expected a metaclass object as its arugment"); + + return $metaclass->find_method_by_name("DEMOLISHALL"); } sub initialize_body { + 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 +=head1 DESCRIPTION + +This class is a subclass of L that +provides Moose-specific functionality for inlining destructors. -Moose::Meta::Method::Destructor - Method Meta Object for destructors +To understand this class, you should read the the +L documentation as well. -=head1 DESCRIPTION +=head1 INHERITANCE -This is a subclass of L which handles -constructing an appropriate Destructor method. This is primarily -used in the making of immutable metaclasses, otherwise it is -not particularly useful. +C is a subclass of +L I L. =head1 METHODS =over 4 -=item B +=item B<< Moose::Meta::Method::Destructor->new(%options) >> -=item B +This constructs a new object. It accepts the following options: -=item B +=over 8 -=item B +=item * package_name -=item B +The package for the class in which the destructor is being +inlined. This option is required. -=item B +=item * name -=item B +The name of the destructor method. This option is required. -=back +=item * metaclass -=head1 AUTHORS +The metaclass for the class this destructor belongs to. This is +optional, as it can be set later by calling C<< +$metamethod->attach_to_class >>. -Stevan Little Estevan@iinteractive.comE +=back + +=item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >> -=head1 COPYRIGHT AND LICENSE +Given a L object, this method returns a boolean +indicating whether the class needs a destructor. If the class or any +of its parents defines a C method, it needs a destructor. -Copyright 2006-2009 by Infinity Interactive, Inc. +=back -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