File Coverage

blib/lib/Method/Delegation.pm

Criterion	Covered	Total	%
statement	68	78	87.1
branch	29	38	76.3
condition	5	8	62.5
subroutine	13	14	92.8
pod	1	1	100.0
total	116	139	83.4

package Method::Delegation;

use 5.006;
use strict;
use warnings;
use Carp;
use Sub::Install;
use base 'Exporter';
our @EXPORT = qw(delegate);    ## no critic
our $VERSION = '0.02';

sub delegate {
    my %arg_for = @_;

    my ( $package, undef, undef ) = caller;
    my $delegate = delete $arg_for{to}
      or croak("You must supply a 'to' argument to delegate()");
    my $methods = delete $arg_for{methods}
      or croak("You must supply a 'methods' argument to delegate()");
    my $args        = delete $arg_for{args};
    my $if_true     = delete $arg_for{if_true};
    my $else_return = delete $arg_for{else_return};
    my $override    = delete $arg_for{override};

    if ( defined $else_return && !defined $if_true ) {
        croak(
            "You must supply a 'if_true' argument if 'else_return' is defined"
        );
    }

    if ( 'ARRAY' eq ref $methods ) {
        $methods = { map { $_ => $_ } @$methods };
    }
    elsif ( !ref $methods ) {
        $methods = { $methods => $methods };
    }
    elsif ( 'HASH' ne ref $methods ) {
        croak("I don't know how to delegate to '$delegate' from '$methods'");
    }

    unless ( keys %$methods ) {
        croak("You have not provideed any methods to delegate");
    }
    if ( keys %arg_for ) {
        my $unknown = join ', ' => sort keys %arg_for;
        croak("Unknown keys supplied to delegate(): $unknown");
    }

    if ( ( $if_true || '' ) eq "1" ) {
        $if_true = $delegate;
    }
    _assert_valid_method_name($delegate);
    _assert_valid_method_name($if_true) if defined $if_true;

    while ( my ( $method, $to ) = each %$methods ) {
        _assert_valid_method_name($method);
        _assert_valid_method_name($to);

        my $coderef;
        if ($if_true) {
            if ($args) {
                $coderef = sub {
                    my $self = shift;
                    if ( $self->$if_true ) {
                        return $self->$delegate->$to(@_);
                    }
                    return defined $else_return ? $else_return : ();
                };
            }
            else {
                $coderef = sub {
                    my $self = shift;
                    if ( $self->$if_true ) {
                        return $self->$delegate->$to;
                    }
                    return defined $else_return ? $else_return : ();
                };
            }
        }
        else {
            if ($args) {
                $coderef = sub {
                    my $self = shift;
                    return $self->$delegate->$to(@_);
                };
            }
            else {
                $coderef = sub {
                    my $self = shift;
                    return $self->$delegate->$to;
                };
            }
        }

        {
            no strict 'refs';    ## no critic
            if ( !$override && defined *{"${package}::$method"}{CODE} ) {
                croak(
                    "Package '$package' already has a method named '$method'"
                );
            }
        }

        _install_delegate( $coderef, $package, $method );
    }
}

sub _install_delegate {
    my ( $coderef, $package, $method ) = @_;

    Sub::Install::install_sub(
        {
            code => $coderef,
            into => $package,
            as   => $method,
        }
    );
}

sub _assert_valid_method_name {
    my $name = shift;
    if ( $name =~ /^[a-z_][a-z0-9_]*$/i ) {
        return $name;
    }
    croak("Illegal method name: '$name'");
}

1;

__END__