File Coverage

blib/lib/Class/Delegation.pm

Criterion	Covered	Total	%
statement	179	198	90.4
branch	56	92	60.8
condition	16	24	66.6
subroutine	43	50	86.0
pod	1	1	100.0
total	295	365	80.8

package Class::Delegation;

our $VERSION = '1.009001';

use strict;
use Carp;

sub ::DEBUG { 0 };

my %mappings;

sub import {
    my $class = shift;
    my $caller = caller();
    while (@_) {
        push @{$mappings{$caller}}, Class::Delegation::->_new(\@_);
    }
}

INIT {
    foreach my $class (keys %mappings) {
        _install_delegation_for($class);
    }
}

sub _install_delegation_for {
    use vars '$AUTOLOAD';
    no strict 'refs';
    my ($class) = @_;
    my $symbol = "${class}::AUTOLOAD";
    print STDERR "Installing $symbol\n" if ::DEBUG;
    my $real_AUTOLOAD = *{$symbol}{CODE}
             || sub {croak "Could not delegate $AUTOLOAD"};

    local $SIG{__WARN__} = sub {};
    *$symbol = sub {
        $$symbol = $AUTOLOAD;
        my ($class, $method) = $AUTOLOAD =~ m/(.*::)(.*)/;
        my ($invocant, @args) = @_;
        print STDERR "Delegating: $AUTOLOAD...\n" if ::DEBUG;
        use Data::Dumper 'Dumper';
        print STDERR "...on: ", Dumper $invocant if ::DEBUG;
        my @context = ($invocant, $method, @args);
        $invocant = "${class}${invocant}" unless ref $invocant;
        my $wantarray = wantarray;
        my @delegators = _delegators_for(@context);
        goto &{$real_AUTOLOAD} unless @delegators;
        my (@results, $delegated);
        DELEGATOR: foreach my $delegator ( @delegators ) {
            next if $delegator->{other} && keys %$delegated;
            my @to = @{$delegator->{to}};
            my @as = @{$delegator->{as}};
            if (@to==1) {
                print STDERR "[$to[0]]\n" if ::DEBUG;
                next DELEGATOR if exists $delegated->{$to[0]};
                foreach my $as (@as) {
                    push @results, delegate($delegated,$wantarray,$invocant,$to[0],$as,\@args);
                }
            }
            elsif (@as==1) {
                print STDERR "[$to[0]]\n" if ::DEBUG;
                foreach my $to (@to) {
                    next if exists $delegated->{$to};
                    push @results, delegate($delegated,$wantarray,$invocant,$to,$as[0],\@args);
                }
            }
            else {
                while (1) {
                    last unless @to && @as;
                    my $to = shift @to;
                    my $as = shift @as;
                    next if exists $delegated->{$to};
                    push @results, delegate($delegated,$wantarray,$invocant,$to,$as,\@args);
                }
            }
        }
        goto &{$real_AUTOLOAD} unless keys %$delegated;
        return $wantarray
            ? ( @results>1 ? @results : @{$results[0]} )
            : ( @results>1 ? \@results : $results[0] );
    };

    unless ($class->can('DESTROY') || _delegators_for($class,'DESTROY')) {
        *{"${class}::DESTROY"} = sub {};
    }
}

sub delegate {
    my ($delegated,$wantarray,$invocant,$to,$as,$args) = @_;
    no strict 'refs';
    my $target = ref $to            ? $to
           : $to =~ /^->(\w+)$/ ? $invocant->$+()
           : $to eq -SELF       ? $invocant
           :                      $invocant->{$to};
    return unless eval {
        $target->can($as)  || $target->can('AUTOLOAD')
    };
    my $result = $wantarray
            ? [$target->$as(@$args)]
            : $target->$as(@$args);
    return if $@;
    $_[0]->{$to}++;
    return $result
}

sub _delegators_for {
    my ($self, $method, @args) = @_;

    my @attrs;
    my $class = ref($self)||$self;
    foreach my $candidate ( @{$mappings{$class}} ) {
        push @attrs, $candidate->{send}->can_send(scalar(@attrs),
                              $candidate->{to},
                              $candidate->{as},
                              @_);
    }
    return @attrs if @attrs;
        no strict 'refs';
    my @ancestors = @{$class.'::ISA'};
    my $parent;
    while ($parent = shift @ancestors) {
        next unless exists $mappings{$parent};
        foreach my $candidate ( @{$mappings{$parent}} ) {
        push @attrs, $candidate->{send}->can_send(scalar(@attrs),
                              $candidate->{to},
                              $candidate->{as},
                              @_);
        }
        return @attrs if @attrs;
        unshift @ancestors, @{$parent.'::ISA'};
    }
    return @attrs;
}

sub _new {
    my ($class, $args) = @_;
    my ($send, $send_val) = splice @$args, 0, 2;
    croak "Expected 'send => ' but found '$send => $send_val'"
        unless $send eq 'send';
    croak "The expected 'to => ' is missing at end of list"
        unless @$args >= 2;
    my ($to, $to_val) = splice @$args, 0, 2;
    croak "Expected 'to => ' but found '$to => $to_val'"
        unless $to eq 'to';

    $send_val  = _class_for(Send => $send_val)->_new($send_val);
    my $to_obj = _class_for(To => $to_val)->_new($to_val);
    my $self = bless { send=>$send_val, to=>$to_obj }, $class;
    if (($args->[0]||"") eq 'as') {
        my ($as, $as_val) = splice @$args, 0, 2;
        croak "Arrays specified for 'to' and 'as' must be same length"
            unless ref($to_val) ne 'ARRAY'
                || ref($as_val) ne 'ARRAY'
                || @$to_val == @$as_val;
        $self->{as} = _class_for(As => $as_val)->_new($as_val);
    }
    else {
        croak "'to => -SELF' is meaningless without 'as => '"
            if $to_val eq -SELF;
        $self->{as} = Class::Delegation::As::Sent->_new();
    }
    return $self;
}

my %allowed;
@{$allowed{Send}}{qw(ARRAY Regexp CODE)} = ();
@{$allowed{To}}{qw(ARRAY Regexp CODE)} = ();
@{$allowed{As}}{qw(ARRAY CODE)} = ();

sub _class_for {
    my ($subclass, $value) = @_;
    my $type = ref($value);
    return "Class::Delegation::${subclass}::SCALAR" unless $type;
    croak "'\l$subclass' value cannot be $type reference"
        unless exists $allowed{$subclass}{$type};
    return "Class::Delegation::${subclass}::${type}";
}

package # Hide from CPAN indexer
SELF;

sub DESTROY {}
sub AUTOLOAD {
    my ($name) = $SELF::AUTOLOAD =~ m/.*::(.+)/;
    bless \$name, 'SELF'
}
use overload 'neg' => sub { "->${$_[0]}" };


package Class::Delegation::Send::SCALAR;

sub _new {
    return bless {}, "Class::Delegation::Send::ALL" if $_[1] eq '-ALL';
    return bless {}, "Class::Delegation::Send::OTHER" if $_[-1] eq '-OTHER';
    my $val = pop;
    return bless \$val, $_[0]
}

sub can_send {
    my ($self, $sent, $to, $as, @context) = @_;
    return { to => [$to->attr_for(@context)],
         as => [$as->name_for(@context)],
           }
        if $$self eq $context[1];
    return;
}


package Class::Delegation::Send::ARRAY;

sub _new {
    my @delegators =
        map { Class::Delegation::_class_for(Send => $_)->_new($_) } @{$_[1]};
    bless \@delegators, $_[0];
}

sub can_send {
    my ($self, @context) = @_;
    return map { $_->can_send(@context) } @$self;
}


package Class::Delegation::Send::Regexp;

sub _new {
    my ($class, $regex) = @_;
    my $self = bless \$regex, $class;
    return $self;
}


sub can_send {
    my ($self, $sent, $to, $as, @context) = @_;
    return { to => [$to->attr_for(@context)],
         as => [$as->name_for(@context)],
           }
        if $context[1] =~ $$self;
    return;
}


package Class::Delegation::Send::CODE;

sub _new { bless $_[1], $_[0] }

sub can_send {
    my ($self, $sent, $to, $as, @context) = @_;
    return { to => [$to->attr_for(@context)],
         as => [$as->name_for(@context)],
           }
        if $self->(@context);
    return;
}

package Class::Delegation::Send::ALL;

sub can_send {
    my ($self, $sent, $to, $as, @context) = @_;
    return { to => [$to->attr_for(@context)],
         as => [$as->name_for(@context)],
           }
        if $context[1] ne 'DESTROY';
    return;
}

package Class::Delegation::Send::OTHER;

sub can_send {
    my ($self, $sent, $to, $as, @context) = @_;
    return { to => [$to->attr_for(@context)],
         as => [$as->name_for(@context)],
         other => 1,
           }
        if $context[1] ne 'DESTROY';
    return;
}


package Class::Delegation::To::SCALAR;

sub _new {
    my ($class, $value) = @_;
    return bless {}, "Class::Delegation::To::ALL" if $value eq '-ALL';
    return bless \$value, $class
}

sub attr_for { return ${$_[0]} }


package Class::Delegation::To::ARRAY;

sub _new {
    my ($class, $array) = @_;
    bless [ map {("Class::Delegation::To::".(ref||"SCALAR"))->_new($_)} @$array ], $class;
}

sub attr_for {
    my ($self, @context) = @_;
    return map { $_->attr_for(@context) } @$self;
}

package Class::Delegation::To::Regexp;

sub _new {
    my ($class, $regex) = @_;
    my $self = bless \$regex, $class;
    return $self;
}

sub attr_for {
    my ($self, $invocant, @context) = @_;
    print STDERR "[[$$self]]\n" if ::DEBUG;
    return grep {  $_ =~ $$self } keys %$invocant;
}


package Class::Delegation::To::CODE;

sub _new { bless $_[1], $_[0] }

sub attr_for {
    my ($self, @context) = @_;
    return $self->(@context)
}


package Class::Delegation::To::ALL;

sub attr_for {
    my ($self, $invocant, @context) = @_;
    return keys %$invocant;
}



package Class::Delegation::As::SCALAR;

sub _new {
    my ($class, $value) = @_;
    bless \$value, $class;
}

sub name_for { ${$_[0]} }

package Class::Delegation::As::ARRAY;

sub _new {
    my ($class, $value) = @_;
    bless $value, $class;
}

sub name_for { @{$_[0]} }


package Class::Delegation::As::Sent;

sub _new { bless {}, $_[0] }

sub name_for {
    my ($self, $invocant, $method) = @_;
    return $method;
}

package Class::Delegation::As::CODE;

sub _new { bless $_[1], $_[0] }

sub name_for {
    my ($self, @context) = @_;
    return $self->(@context)
}

1;

__END__