File Coverage

blib/lib/mop/method.pm

Criterion	Covered	Total	%
statement	62	63	98.4
branch	4	6	66.6
condition	3	6	50.0
subroutine	16	16	100.0
pod	7	7	100.0
total	92	98	93.8

package mop::method;

use v5.16;
use warnings;

use Scalar::Util qw[ weaken ];
use mop::internals::util;

our $VERSION   = '0.03';
our $AUTHORITY = 'cpan:STEVAN';

use parent 'mop::object', 'mop::internals::observable';

mop::internals::util::init_attribute_storage(my %name);
mop::internals::util::init_attribute_storage(my %body);
mop::internals::util::init_attribute_storage(my %associated_meta);
mop::internals::util::init_attribute_storage(my %original_id);

sub name            { ${ $name{ $_[0] }            // \undef } }
sub body            { ${ $body{ $_[0] }            // \undef } }
sub associated_meta { ${ $associated_meta{ $_[0] } // \undef } }

sub set_associated_meta {
    my ($self, $meta) = @_;
    $associated_meta{ $self } = \$meta;
    weaken(${ $associated_meta{ $self } });
}

# temporary, for bootstrapping
sub new {
    my $class = shift;
    my %args  = @_;
    my $self = $class->SUPER::new;
    $name{ $self } = \($args{'name'});
    $body{ $self } = \($args{'body'});
    # NOTE:
    # keep track of the original ID here
    # so that we can still detect method
    # conflicts in roles even after something
    # has been cloned
    # - SL
    $original_id{ $self } = \(mop::id($self));

    $self;
}

# temporary, for bootstrapping
sub clone {
    my $self = shift;
    return ref($self)->new(name => $self->name, body => $self->body);
}

sub execute {
    my ($self, $invocant, $args) = @_;

    $self->fire('before:EXECUTE' => $invocant, $args);

    my @result;
    my $wantarray = wantarray;
    if ( $wantarray ) {
        @result = $self->body->( $invocant, @$args );
    } elsif ( defined $wantarray ) {
        $result[0] = $self->body->( $invocant, @$args );
    } else {
        $self->body->( $invocant, @$args );
    }

    $self->fire('after:EXECUTE' => $invocant, $args, \@result);

    return $wantarray ? @result : $result[0];
}

sub conflicts_with { ${ $original_id{ $_[0] } } ne ${ $original_id{ $_[1] } } }

sub locally_defined { ${ $original_id{ $_[0] } } eq mop::id( $_[0] ) }

sub __INIT_METACLASS__ {
    my $METACLASS = mop::class->new(
        name       => 'mop::method',
        version    => $VERSION,
        authority  => $AUTHORITY,
        superclass => 'mop::object',
    );

    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!name',
        storage => \%name,
    ));
    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!body',
        storage => \%body,
    ));
    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!associated_meta',
        storage => \%associated_meta,
    ));
    $METACLASS->add_attribute(mop::attribute->new(
        name    => '$!original_id',
        storage => \%original_id,
        default => sub { mop::id($_) },
    ));

    $METACLASS->add_method( mop::method->new( name => 'name', body => \&name ) );

    $METACLASS->add_method( mop::method->new( name => 'body',    body => \&body    ) );
    $METACLASS->add_method( mop::method->new( name => 'execute', body => \&execute ) );

    $METACLASS->add_method( mop::method->new( name => 'associated_meta',     body => \&associated_meta     ) );
    $METACLASS->add_method( mop::method->new( name => 'set_associated_meta', body => \&set_associated_meta ) );

    $METACLASS->add_method( mop::method->new( name => 'conflicts_with',  body => \&conflicts_with  ) );
    $METACLASS->add_method( mop::method->new( name => 'locally_defined', body => \&locally_defined ) );

    $METACLASS;
}

1;

__END__