File Coverage

blib/lib/Method/Delegation.pm

Criterion	Covered	Total	%
statement	77	88	87.5
branch	32	42	76.1
condition	3	6	50.0
subroutine	14	15	93.3
pod	1	1	100.0
total	127	152	83.5

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.03';

sub delegate {
    my %arg_for = @_;

    my ( $package, undef, undef ) = caller;
    my $delegate    = delete $arg_for{to};
    my $methods     = delete $arg_for{methods};
    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};
    my $maybe_to    = delete $arg_for{maybe_to};

    if ( keys %arg_for ) {
        my $unknown = join ', ' => sort keys %arg_for;
        croak("Unknown keys supplied to delegate(): $unknown");
    }

    if ($maybe_to) {
        if ($delegate) {
            croak(
                "You supplied both 'maybe_to' and 'to'. I don't know which to use.");
        }
        if ($if_true) {
            croak(
"You supplied both 'maybe_to' and 'if_true'. I don't know which to use."
            );
        }
        ( $delegate, $if_true ) = ($maybe_to) x 2;
    }
    $delegate or croak("You must supply a 'to' argument to delegate()");
    $methods  or croak("You must supply a 'methods' argument to delegate()");
    $methods = _normalize_methods( $methods, $delegate );

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

    _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 _normalize_methods {
    my ( $methods, $delegate ) = @_;

    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");
    }
    return $methods;
}

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__