File Coverage

lib/Object/Wrapper.pm

Criterion	Covered	Total	%
statement	29	34	85.2
branch	6	14	42.8
condition	3	12	25.0
subroutine	8	9	88.8
pod	3	3	100.0
total	49	72	68.0

########################################################################
# housekeeping
########################################################################

package Object::Wrapper;

use 5.8.0;
use strict;

use Carp;

use Scalar::Util    qw( blessed refaddr reftype );

########################################################################
# package variables
########################################################################

our $VERSION    = 0.01;
our $AUTOLOAD   = '';
my %cleanupz    = ();

########################################################################
# utility subs
########################################################################

AUTOLOAD
{
    my $franger = shift;

    my $i       = rindex $AUTOLOAD, '::';
    my $name    = substr $AUTOLOAD, 2 + $i;

    my $sub     = $franger->[0]->can( $name )
    or confess "Bogus $AUTOLOAD: '$franger->[0]' cannot '$name'";

    $franger->[0]->$sub( @_ )
}

DESTROY
{
    my $franger = shift;

    my $class   = blessed $franger || $franger;

    # $cleanupz{ $class } may be a method name or coderef.

    my $cleanup = $cleanupz{ $class } || $franger->can( 'cleanup' )
    or confess "Bogus franger: no cleanup for '$franger' or '$class'";

    my $sub
    = ref $cleanup
    ? $cleanup
    : $franger->can( $cleanup )
    or confess "Bogus $class: no cleanup for '$franger' ($class)";

    'CODE' eq reftype $sub
    or confess "Bogus $class: not a coderef '$sub'";

    $cleanup->( @$franger );

    return
}

########################################################################
# public interface
########################################################################

sub new
{
    my $proto   = shift;
    my $class   = blessed $proto || $proto;

    my $object  = shift
    or croak "Bogus franger: missing object";

    bless [ $object, @_ ], $class
}

sub cleanup_handler :lvalue
{
    my $proto   = shift;
    my $class   = blessed $proto || $proto;

    @_
    and $cleanupz{ $class } = shift;

    my $tmp = \$cleanupz{ $class };

    $$tmp
}

# stub cleanup for cases where the AUTOLOAD validation
# is sufficient by itself.

sub cleanup {}

# keep require happy

1

__END__