File Coverage

blib/lib/Object/Trampoline.pm

Criterion	Covered	Total	%
statement	43	48	89.5
branch	8	12	66.6
condition			n/a
subroutine	15	16	93.7
pod			n/a
total	66	76	86.8

########################################################################
# 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  v1.30.2;
use v5.24;

use Carp;

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

########################################################################
# 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.24;

use Carp;

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

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

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

our $AUTOLOAD = '';

AUTOLOAD
{
    # this version does slightly more work since it
    # has to put using the module into the caller's
    # class before calling the constructor.

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

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

    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.24;

use Carp;

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

# version is defined by the main package.

*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.
# allows $trampoline->VERSION to do the right thing.

our $is_override
= sub
{
    # sub allows testing w/o reproducing the
    # sanity checks in every test.
    #
    # basic checks: non-empty name w/o non-word
    # chars that has as a coderef in UNIVERSAL.

    my $name    = shift
    or return;

    $name       =~ /\W/
    and return;

    defined &{ "UNIVERSAL::$name" }
    or return;

    1
};

for my $name ( keys %{ $::{ 'UNIVERSAL::' } } )
{
    # skip stash entries which cannot map to
    # valid method names.

    $is_override->( $name )
    and
    *{ qualify_to_ref $name }
    = sub
    {
        $AUTOLOAD   = $name;
        goto &AUTOLOAD
    };
}

# stub destroy dodges AUTOLOAD for unused trampolines.

DESTROY {}

# keep require happy
1
__END__