X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FMethod%2FDestructor.pm;h=98121fc8721ff5699108ca2c6210afc4ccb969b7;hb=6f94c802188d44415bafdd64422cecd24585a289;hp=9215bc05b802bd37e9ada83262068ae8d3920fb1;hpb=2351f08e7d635babd893a7951af6ef553ef23cec;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Method/Destructor.pm b/lib/Moose/Meta/Method/Destructor.pm index 9215bc0..98121fc 100644 --- a/lib/Moose/Meta/Method/Destructor.pm +++ b/lib/Moose/Meta/Method/Destructor.pm @@ -6,17 +6,17 @@ use warnings; use Scalar::Util 'blessed', 'weaken'; -our $VERSION = '0.59'; +our $VERSION = '0.87'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; 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,74 +25,87 @@ 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}, '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; - { - $code = eval $source; - $self->throw_error("Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source) if $@; + + my $source; + if ( @DEMOLISH_methods ) { + $source = 'sub {'; + + my @DEMOLISH_calls; + foreach my $method (@DEMOLISH_methods) { + push @DEMOLISH_calls => '$_[0]->' . $method->{class} . '::DEMOLISH()'; + } + + $source .= join ";\n" => @DEMOLISH_calls; + + $source .= ";\n" . '}'; + } else { + $source = 'sub { }'; } + + warn $source if $self->options->{debug}; + + my ( $code, $e ) = $self->_compile_code( + environment => {}, + code => $source, + ); + + $self->throw_error( + "Could not eval the destructor :\n\n$source\n\nbecause :\n\n$e", + error => $e, data => $source ) + if $e; + $self->{'body'} = $code; } @@ -103,34 +116,55 @@ __END__ =pod -=head1 NAME +=head1 NAME Moose::Meta::Method::Destructor - Method Meta Object for destructors =head1 DESCRIPTION -This is a subclass of L which handles -constructing an approprate Destructor method. This is primarily -used in the making of immutable metaclasses, otherwise it is -not particularly useful. +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. + +=head1 INHERITANCE + +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 * name + +The name of the destructor method. This option is required. + +=item * metaclass + +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 >>. + +=back -=item B +=item B<< Moose::Meta;:Method::Destructor->is_needed($metaclass) >> -=item B +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. =back @@ -140,12 +174,12 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2008 by Infinity Interactive, Inc. +Copyright 2006-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut