Made the delegation closure have useful error trace information.

[gitmo/Moose.git] / lib / Moose / Meta / Method / Delegation.pm

package Moose::Meta::Method::Delegation;

use strict;
use warnings;

use Carp         'confess';
use Scalar::Util 'blessed', 'weaken';

our $VERSION   = '0.94';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';

use base 'Moose::Meta::Method',
         'Class::MOP::Method::Inlined';


sub new {
    my $class   = shift;
    my %options = @_;

    ( exists $options{attribute} )
        || confess "You must supply an attribute to construct with";

    ( blessed( $options{attribute} )
            && $options{attribute}->isa('Moose::Meta::Attribute') )
        || confess
        "You must supply an attribute which is a 'Moose::Meta::Attribute' instance";

    ( $options{package_name} && $options{name} )
        || confess
        "You must supply the package_name and name parameters $Class::MOP::Method::UPGRADE_ERROR_TEXT";

    ( $options{delegate_to_method} && ( !ref $options{delegate_to_method} )
            || ( 'CODE' eq ref $options{delegate_to_method} ) )
        || confess
        'You must supply a delegate_to_method which is a method name or a CODE reference';

    exists $options{curried_arguments}
        || ( $options{curried_arguments} = [] );

    ( $options{curried_arguments} &&
        ( 'ARRAY' eq ref $options{curried_arguments} ) )
        || confess 'You must supply a curried_arguments which is an ARRAY reference';

    my $self = $class->_new( \%options );

    weaken( $self->{'attribute'} );

    $self->_initialize_body;

    return $self;
}

sub _new {
    my $class = shift;
    my $options = @_ == 1 ? $_[0] : {@_};

    return bless $options, $class;
}

sub curried_arguments { (shift)->{'curried_arguments'} }

sub associated_attribute { (shift)->{'attribute'} }

sub delegate_to_method { (shift)->{'delegate_to_method'} }

sub is_inline {
    (shift)->{is_inline}
}

sub definition_context {
    exists $_[0]->{definition_context} ? $_[0]->{definition_context}
        : ($_[0]->{definition_context} = $_[0]->_generate_definition_context);
}

sub _generate_definition_context {
    my $self = shift;
    my $attr = $self->associated_attribute;
    my $ctx = $attr->definition_context;
    return unless $ctx;

    my $desc = "delegation of "
        . $self->name
        . ' to '
        . $attr->name
        . '->'
        . $self->delegate_to_method;

    return { %$ctx, description => $desc };
}

sub _initialize_body {
    my $self = shift;

    my $method_to_call = $self->delegate_to_method;
    return $self->{body} = $method_to_call
        if ref $method_to_call;

    return $self->{body} = $self->is_inline
        ? $self->_generate_body_inline
        : $self->_generate_body;
}

sub _generate_body_inline {
    my $self = shift;
    my $method_to_call = $self->delegate_to_method;
    my $attr = $self->associated_attribute;
    my $attr_name = $attr->name;
    my $meta_instance = $attr->associated_class->instance_metaclass;
    my $handle_name = $self->name;

    my ( $code, $e ) = $self->_compile_code(
        environment => {
            '@curried_arguments' => $self->curried_arguments,
            '$method' => \$self,
        },
        code => (
            'sub {'."\n"
            . 'my $instance = shift; '."\n"
            . 'my $proxy = '
            . $meta_instance->inline_get_slot_value('$instance',$attr_name)
            . ';'."\n"
            . 'my $error '."\n"
            . '  = !defined $proxy                  ?  q{ is not defined} '."\n"
            . q{  : ref($proxy) && !Scalar::Util::blessed($proxy) ? qq{ is not an object (got '$proxy')} }."\n"
            . '  : undef;'."\n"
            . 'if ($error) {'."\n"
            . '  $method->throw_error('."\n"
            . '    "Cannot delegate '. $handle_name.' to '.$method_to_call
            . ' because the value of '
            . $attr_name
            . '" . $error, '."\n"
            . '  method_name => q{'.$method_to_call.'}, '."\n"
            . '  object      => $instance, '."\n"
            . ');}'."\n"
            . ($self->curried_arguments
                   ? 'unshift @_, @{curried_arguments};'."\n"
                   : '')
            . '$proxy->'.$method_to_call.'(@_);'."\n"
            . '};'
        ),
    );
    confess "Could not generate inline accessor because : $e" if $e;

    return $code;
}

sub _generate_body {
    my $self = shift;

    my $method_to_call = $self->delegate_to_method;

    my $accessor = $self->_get_delegate_accessor;

    my $handle_name = $self->name;

    # NOTE: we used to do a goto here, but the goto didn't handle
    # failure correctly (it just returned nothing), so I took that
    # out. However, the more I thought about it, the less I liked it
    # doing the goto, and I preferred the act of delegation being
    # actually represented in the stack trace.  - SL
    # not inlining this, since it won't really speed things up at
    # all... the only thing that would end up different would be
    # interpolating in $method_to_call, and a bunch of things in the
    # error handling that mostly never gets called - doy
    return sub {
        my $instance = shift;
        my $proxy    = $instance->$accessor();

        my $error
            = !defined $proxy                 ? ' is not defined'
            : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}
            : undef;

        if ($error) {
            $self->throw_error(
                "Cannot delegate $handle_name to $method_to_call because "
                    . "the value of "
                    . $self->associated_attribute->name
                    . $error,
                method_name => $method_to_call,
                object      => $instance
            );
        }
        unshift @_, @{ $self->curried_arguments };
        $proxy->$method_to_call(@_);
    };
}

sub _get_delegate_accessor {
    my $self = shift;
    my $attr = $self->associated_attribute;

    # NOTE:
    # always use a named method when
    # possible, if you use the method
    # ref and there are modifiers on
    # the accessors then it will not
    # pick up the modifiers too. Only
    # the named method will assure that
    # we also have any modifiers run.
    # - SL
    my $accessor = $attr->has_read_method
        ? $attr->get_read_method
        : $attr->get_read_method_ref;

    $accessor = $accessor->body if Scalar::Util::blessed $accessor;

    return $accessor;
}

1;

__END__

=pod

=head1 NAME

Moose::Meta::Method::Delegation - A Moose Method metaclass for delegation methods

=head1 DESCRIPTION

This is a subclass of L<Moose::Meta::Method> for delegation
methods.

=head1 METHODS

=over 4

=item B<< Moose::Meta::Method::Delegation->new(%options) >>

This creates the delegation methods based on the provided C<%options>.

=over 4

=item I<attribute>

This must be an instance of C<Moose::Meta::Attribute> which this
accessor is being generated for. This options is B<required>.

=item I<delegate_to_method>

The method in the associated attribute's value to which we
delegate. This can be either a method name or a code reference.

=item I<curried_arguments>

An array reference of arguments that will be prepended to the argument list for
any call to the delegating method.

=back

=item B<< $metamethod->associated_attribute >>

Returns the attribute associated with this method.

=item B<< $metamethod->curried_arguments >>

Return any curried arguments that will be passed to the delegated method.

=item B<< $metamethod->delegate_to_method >>

Returns the method to which this method delegates, as passed to the
constructor.

=back

=head1 BUGS

See L<Moose/BUGS> for details on reporting bugs.

=head1 AUTHOR

Dave Rolsky E<lt>autarch@urth.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2009 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut