File Coverage

blib/lib/IOC/Proxy.pm

Criterion	Covered	Total	%
statement	110	110	100.0
branch	24	26	92.3
condition	3	5	60.0
subroutine	21	21	100.0
pod	4	4	100.0
total	162	166	97.5

package IOC::Proxy;

use strict;
use warnings;

our $VERSION = '0.07';

use Scalar::Util qw(blessed);

use IOC::Exceptions;

sub new {
    my ($_class, $config) = @_;
    my $class = ref($_class) || $_class;
    my $proxy_server = {};
    bless($proxy_server, $class);
    $proxy_server->_init($config);
    return $proxy_server;
}

sub _init {
    my ($self, $config) = @_;
    $self->{config} = $config;
}

sub wrap {
    my ($self, $obj) = @_;
    (blessed($obj))
        || throw IOC::InsufficientArguments "You can only wrap other objects";
    my $obj_class = $self->_getObjectClass($obj);

    my $methods = {};
    $self->_collectAllMethods($obj_class, $methods);
    (keys %{$methods}) || throw IOC::OperationFailed "No methods could be found in '$obj_class'";

    my $proxy_package = $self->_createProxyPackageName($obj_class);

    eval $self->_createPackageString($obj_class, $proxy_package);
    throw IOC::OperationFailed "Could not create proxy package '$proxy_package' for object '$obj'" => $@ if $@;

    $self->_installMethods($obj_class, $proxy_package, $methods);

    $self->onWrap($obj, $proxy_package);
    bless $obj, $proxy_package;
}

sub onMethodCall {
    my ($self, $method_name, $method_full_name, $current_args) = @_;
    if (exists ${$self->{config}}{on_method_call}) {
        $self->{config}->{on_method_call}->($self, $method_name, $method_full_name, $current_args);
    }
}

sub onWrap {
    my ($self, $object, $proxy_package) = @_;
    if (exists ${$self->{config}}{on_wrap}) {
        $self->{config}->{on_wrap}->($self, $object, $proxy_package);
    }
}

# PRIVATE METHODS

sub _collectAllMethods {
    my ($self, $obj_class, $methods, $cache) = @_;
    $cache ||= {};
    return if exists ${$cache}{$obj_class};
    $cache->{$obj_class}++;

    no strict 'refs';
    do {
        $methods->{$_} = {
            full_name => "${obj_class}::$_",
            code => \&{"${obj_class}::$_"}
        } unless exists ${$methods}{$_}
    } foreach
        grep { defined &{"${obj_class}::$_"} }
            keys %{"${obj_class}::"};

    $self->_collectAllMethods($_, $methods, $cache) foreach @{"${obj_class}::ISA"};
}

sub _createPackageString {
    my ($self, $obj_class, $proxy_package) = @_;
    my $overload = "";
    unless ($obj_class->can('(""')) {
        $overload = q|use overload '""' => sub {
                        my $real = overload::StrVal($_[0]);
                        $real =~ s/\:\:\_\:\:Proxy//;
                        return $real;
                    }, fallback => 1|;
    }
    return qq|
        package $proxy_package;
        our \@ISA = ('$obj_class');
        $overload;
    |;
}

sub _installMethods {
    my ($self, $obj_class, $proxy_package, $methods) = @_;
    no strict 'refs';
    while (my ($method_name, $method) = each %{$methods}) {
        next if defined &{"${proxy_package}::$method_name"};
        next if $method_name eq '()'; # this is the overloaded indicator, we shouldn't proxy this
        if ($method_name eq 'AUTOLOAD') {
            *{"${proxy_package}::$method_name"} = sub {
                            my $a = our $AUTOLOAD;
                            # we cannot call this here as it will create a new
                            # reference to the object (in the \@_) and that will
                            # defeat the use of DESTORY, so we just ignore this
                            # if we get called by destroy
                            if ($a =~ /DESTROY/) {
                                $self->onMethodCall($method_name, $method->{full_name}, []);
                            }
                            else {
                                $self->onMethodCall($method_name, $method->{full_name}, [ @_ ]);
                            }
                            $a =~ s/\:\:\_\:\:Proxy//;
                            ${"${obj_class}::AUTOLOAD"} = $a;
                            goto &{$method->{code}};
                        };
        }
        elsif ($method_name eq 'DESTROY') {
            *{"${proxy_package}::$method_name"} = sub {
                            # we cannot call onMethodCall this here as it will create a new
                            # reference to the object (in the \@_) and that will
                            # defeat the use of DESTORY, so we just ignore this
                            # if we get called by destroy
                            $self->onMethodCall($method_name, $method->{full_name}, []);
                            goto &{$method->{code}};
                        };
        }
        else {
            *{"${proxy_package}::$method_name"} = sub {
                            $self->onMethodCall($method_name, $method->{full_name}, [ @_ ]);
                            goto &{$method->{code}};
                        };
        }
    }
}

sub _createProxyPackageName {
    my ($self, $obj_class) = @_;
    return "${obj_class}::_::Proxy"
}

sub _getObjectClass {
    my ($self, $obj) = @_;
    return ref($obj);
}

1;

__END__