File Coverage

blib/lib/Object/Destroyer.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	30	30	100.0
condition	5	7	71.4
subroutine	10	10	100.0
pod	3	4	75.0
total	101	104	97.1

package Object::Destroyer;

# See POD at end for details

use 5.006;
use strict;
use warnings;
use Carp         ();
##use Scalar::Util ();

our $VERSION = '2.02'; # TRIAL

if ( eval { require Scalar::Util } ) {
    Scalar::Util->import('blessed');
} else {
    *blessed = sub {
        my $ref = ref($_[0]);
        return $ref
            if $ref &&  ($ref ne 'SCALAR') && ($ref ne 'ARRAY') &&
                        ($ref ne 'HASH') && ($ref ne 'CODE') &&
                        ($ref ne 'REF') && ($ref ne 'GLOB') &&
                        ($ref ne 'LVALUE');
        return;
    }
}

sub new {
    if ( ref $_[0] ) {
        # This is a method called on an existing
        # Destroyer, and should actually be passed through
        # to the encased object via the AUTOLOAD
        $Object::Destroyer::AUTOLOAD = '::new';
        goto &AUTOLOAD;
    }

    # *ahem*... where were we...
    my $destroyer = shift;
    my $ref = shift || '';
    my $self = {};

    if ( ref($ref) eq 'CODE' ) {
        ##
        ## Object::Destroyer->new( sub {...} )
        ##
        $self->{code} = $ref;
    } elsif ( my $class = blessed($ref) ) {
        ##
        ## Object::Destroyer->new( $object, 'optional_method' )
        ##
        my $method = shift || 'DESTROY';
        Carp::croak("Second argument to constructor must be a method name")
            if ref($method);
        Carp::croak("Object::Destroyer requires that $class has a $method method")
            unless $class->can($method);
        $self->{object} = $ref;
        $self->{method} = $method;
    } else {
        ##
        ## And what is this?
        ##
        Carp::croak("You should pass an object or code reference to constructor");
    }
    Carp::croak("Extra arguments to constructor") if @_;

    return bless $self, $destroyer;
}

# Hand off general method calls to the encased object.
# Rather than just doing a $self->{object}->$method(@_), which
# would leave us in the call stack, find the actual subroutine
# that will be executed, and goto that directly.
sub AUTOLOAD {
    my $self = shift;

    my ($method) = $Object::Destroyer::AUTOLOAD =~ /^.*::(.*)$/;
    if (my $object = $self->{object}) {
        if (my $function = $object->can($method)) {
            ##
            ## Rearrange stack - instead of
            ## $object_destroy->method(@params)
            ## make it look like
            ## $underlying_object->method(@params)
            ##
            unshift @_, $object;
            goto &$function;
        } elsif ( $object->can("AUTOLOAD") ) {
            ##
            ## We can't just goto to AUTOLOAD method in unknown
            ## package (it may be in base class of $object).
            ## We have to preserve the method's name.
            ##
            if (wantarray) {
                ## List context
                return $object->$method(@_);
            } elsif ( defined wantarray ) {
                ## Scalar context
                return scalar $object->$method(@_);
            } else {
                ## Void context
                $object->$method(@_);
                return;
            }
        } else {
            ##
            ## Probably this is a caller's error
            ##
            my $package = ref $self->{object};
            Carp::croak(qq[Can't locate object method "$method" via package "$package"]);
        }
    }

    ##
    ## No object at all. Either we have a $coderef instead of object
    ## or DESTROY has been called already.
    ##
    Carp::croak("Can't locate object to call method '$method'");
}

sub dismiss{
    $_[0]->{dismissed} = 1;
}

##
## Use our automatically triggered DESTROY to call the
## non-automatically triggered clean-up method of the encased object
##
sub DESTROY {
    my $self = shift;

    if ( $self->{dismissed} ) {
        ## do nothing
    } elsif ( $self->{code} ) {
        $self->{code}->();
    } elsif ( my $object = $self->{object} ) {
        my $method = $self->{method};
        $object->$method();
    }

    %$self = ();
}

##
## Catch a couple of specific cases that would be handled by UNIVERSAL
## before our AUTOLOAD got a chance to dispatch it.
##
## We are both 'Object::Destroyer' (or it's derived class)
## and underlying object's class
##
sub isa {
    my $self  = shift;
    my $class = shift;

    return  $class eq __PACKAGE__ ||
        ($self->{object} && $self->{object}->isa($class));
}

sub can {
    my $self = shift;
    return $self->{object}->can(@_) if $self->{object};
}

1;

__END__