File Coverage

blib/lib/Class/Decorator.pm

Criterion	Covered	Total	%
statement	73	101	72.2
branch	11	30	36.6
condition	8	12	66.6
subroutine	12	13	92.3
pod	0	4	0.0
total	104	160	65.0

package Class::Decorator;
use Carp;
use strict;
use vars qw ( $VERSION $METH $METHOD $AUTOLOAD );

$VERSION = '0.99';

sub new
{
    my ($caller, %args) = @_;
    my $class = ref($caller) || $caller;
    bless {
	pre     => $args{pre}     || sub {}, # performed before dispatched method
	post    => $args{post}    || sub {}, # performed after dispatched method
	obj     => $args{obj}     || croak("decorator must be constructed with a component to be decorated"),
	methods => $args{methods} || {}
	}, $class;
}

sub DESTROY {}

sub VERSION
{
    my ($self, @args) = @_;
    my ($pre, $post) = ($self->{pre}, $self->{post});

    if (exists ${$self->{methods}}{VERSION}) {
	if (exists ${$self->{methods}->{VERSION}}{pre}) {
	    $pre = ${$self->{methods}->{VERSION}}{pre};
	}
	if (exists ${$self->{methods}->{VERSION}}{post}) {
	    $post = ${$self->{methods}->{VERSION}}{post};
	}
    }

    $pre->(@args);
    my $return_value = $self->{obj}->VERSION(@args);
    $post->(@args);
    return $return_value;
}

sub isa
{
    my ($self, @args) = @_;
    my ($pre, $post) = ($self->{pre}, $self->{post});

    if (exists ${$self->{methods}}{isa}) {
	if (exists ${$self->{methods}->{isa}}{pre}) {
	    $pre = ${$self->{methods}->{isa}}{pre};
	}
	if (exists ${$self->{methods}->{isa}}{post}) {
	    $post = ${$self->{methods}->{isa}}{post};
	}
    }

    $pre->(@args);
    my $return_value = $self->{obj}->isa(@args);
    $post->(@args);
    return $return_value;
}

sub can
{
    my ($self, @args) = @_;
    my ($pre, $post) = ($self->{pre}, $self->{post});

    if (exists ${$self->{methods}}{can}) {
	if (exists ${$self->{methods}->{can}}{pre}) {
	    $pre = ${$self->{methods}->{can}}{pre};
	}
	if (exists ${$self->{methods}->{can}}{post}) {
	    $post = ${$self->{methods}->{can}}{post};
	}
    }

    $pre->(@args);
    my $return_value = $self->{obj}->can(@args);
    $post->(@args);
    return $return_value;
}

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

    # check to see whether method name is of form Foo::Bar::Baz
    if ($AUTOLOAD =~ /.+::(.+)$/) {
	$METHOD = $METH = $1; # $METH for backward compaitibility (v0.01)
    } else {
	die("cannot find method name");
    }

    my $dispatch = $self->{obj}->can($METHOD);

    ############################
    # construct the subroutine #
    ############################
    my $sub = sub {
	my ($decorator, @args) = @_;
	my ($pre, $post) = ($decorator->{pre}, $decorator->{post});
	if (exists ${$decorator->{methods}}{$METHOD}) {
	    if (exists ${$decorator->{methods}->{$METHOD}}{pre}) {
		$pre = ${$decorator->{methods}->{$METHOD}}{pre};
	    }
	    if (exists ${$decorator->{methods}->{$METHOD}}{post}) {
		$post = ${$decorator->{methods}->{$METHOD}}{post};
	    }
	}

	if (wantarray) {
	    () = $pre->(@args);
	    my @return_values = $decorator->{obj}->$METHOD(@args);
	    () = $post->(@args);
	    return @return_values;
	} else {
	    $pre->(@args);
	    my $return_value = $decorator->{obj}->$METHOD(@args);
	    $post->(@args);
	    return $return_value;
	}
    };

    ###########################
    # load the subroutine     #
    ###########################
    {
	no strict "refs"; # keep following line happy
	*{$AUTOLOAD} = $sub;
    }

    ############################
    # call the subroutine      #
    ############################
    if (wantarray) {
	my @return_values = $sub->($self, @args);
	return @return_values;
    } else {
	my $return_value = $sub->($self, @args);
	return $return_value;
    }
}

1;
__END__