File Coverage

blib/lib/Object/Trampoline.pm

Criterion	Covered	Total	%
statement	48	54	88.8
branch	9	14	64.2
condition			n/a
subroutine	15	16	93.7
pod			n/a
total	72	84	85.7

########################################################################
# Object::Trampoline
# delay construction of objects until they are needed.
#
# the only purpose for the top two classes is having an autoload
# that blesses things into O::T::Bounce.
########################################################################
########################################################################
# housekeeping
########################################################################

package Object::Trampoline;
use v5.12;

use Carp;

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

our $VERSION    = '1.41';
$VERSION        = eval $VERSION;

# minimal sanity check for valid class name, used in both
# O::T and O::T::U.

my $pkg_rx      = qr{^ [_A-Za-z](?:\w*) (?:::\w+)* $}x;

########################################################################
# AUTOLOAD is the only public interface
########################################################################
########################################################################
#
# start by grabbing the destination class and its arguments
# off the stack.  the constructor name is whatever is
# being autoloaded.
#
# there may not be any arguments... either way i need
# to make a lexical copy of the stack for use in the
# closure.
#
# the closure delays actual contstruction until it is
# dereferenced in O::T::Bounce::AUTOLOAD.
#
# $sub is syntatic sugar but is inexpensive enough to
# construct.
#
# Note: there are no DESTROY blocks in the constructing
# classes since no objects ever live there: they begin
# life in O::T::Bounce.

our $AUTOLOAD = '';

AUTOLOAD
{
    # discard this class: once here it is used up.
    # lacking a prototype is fatal; anything else becomes
    # a run-time error.

    my ( undef, $proto, @argz ) = @_;

    $proto
    or croak "Object::Trampoline: false prototype.";

    my $method  = ( split /::/, "$AUTOLOAD" )[ -1 ];

    my $sub     = sub { $proto->$method( @argz ) };

    bless $sub, 'Object::Trampoline::Bounce'
}

########################################################################
# same gizmo as O::T except that the class is use-ed before the
# constructor is called.
########################################################################
# housekeeping
########################################################################

package Object::Trampoline::Use;
use v5.12;

use Carp;

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

*VERSION = \$Object::Trampoline::VERSION;

our $AUTOLOAD = '';

########################################################################
# AUTOLOAD is the only public interface
########################################################################

AUTOLOAD
{
    # this version does slightly more work since it
    # has to put using the module into the caller's
    # class before calling the constructor.
    #
    # the eval is unavoidable since use requires the
    # module's package name as a bareword.

    my ( undef, $proto, @argz ) = @_;

    $proto
    or croak "Object::Trampoline::Use: false prototype.";

    # sanity check: the prototype is words glued together with
    # double-colons. not perfect but worthwhile since most
    # injection attempts will at least require a path or space.

    for( split '::' => $proto )
    {
        /\W/ and croak
        "Botched trampoline_use: '$_' invalid module name";
    }

    # Note: add a sanity pre-check w/ warning for non-existant
    # module.

    my $method  = ( split /::/, $AUTOLOAD )[ -1 ];
    my $caller  = caller;

    my $init
    = qq
    {
        package $caller;
        use $proto
    };

    my $sub =
    sub
    {
        eval "$init"
        or croak "Failed: $init\n$@";

        $proto->$method( @argz )
    };

    bless $sub, 'Object::Trampoline::Bounce'
}

########################################################################
# where the object ends up. All this does is possibly use the package
# then construct the object and dispatch the call to whatever the
# caller was looking for -- which may fail if the package doesn't
# implement the method.
#
# $_[0] = $_[0]->() replaces the trampoline argument
# with the real thing by calling its constructor -- call
# by reference is a Very Good Thing.
#
# after that it can be shifted off and used to access
# the method. note that this is necessary in order
# to allow for classes which implement their methods
# via AUTOLOAD (which will defeat using $obj->can( $name )).
#
# note that it's up to the caller to deal with any exceptions
# that come out of calling the method.
#
# goto is a more effecient way to get there if the class
# has an explicit method for handling the call; otherwise
# use the name to dispatch the call.

package Object::Trampoline::Bounce;

use v5.12;

use Carp;

use Scalar::Util    qw( blessed         );
use Symbol          qw( qualify_to_ref  );

*VERSION = \$Object::Trampoline::VERSION;

our $AUTOLOAD = '';

AUTOLOAD
{
    # caller gets back any execption as-is.

    $_[0]   = $_[0]->()
    or croak "Failed constructor";

    my $class   = blessed $_[0]
    or croak "Failed constructor: '$_[0]' not blessed";

    my $method = ( split /::/, $AUTOLOAD )[ -1 ];

    if( my $sub = $class->can( $method ) )
    {
        goto &$sub
    }
    else
    {
        # deal with autoloaded methods, or die trying...

        my $obj = shift;

        $obj->$method( @_ )
    }
}

# re-route methods from UNIVERSAL through the bounce.

for my $name ( keys %{ $::{ 'UNIVERSAL::' } } )
{
    *{ qualify_to_ref $name }
    = sub
    {
        $AUTOLOAD = $name;

        goto &AUTOLOAD
    };
}

# stub destroy dodges AUTOLOAD for unused trampolines.

DESTROY {}

# keep require happy

1

__END__