File Coverage

blib/lib/Clone/Choose.pm

Criterion	Covered	Total	%
statement	69	84	82.1
branch	29	52	55.7
condition	3	7	42.8
subroutine	9	10	90.0
pod	2	3	66.6
total	112	156	71.7

package Clone::Choose;

use strict;
use warnings;
use Carp ();

our $VERSION = "0.008";
$VERSION = eval $VERSION;

our @BACKENDS = (
    Clone       => [0.10, "clone"],
    Storable    => "dclone",
    "Clone::PP" => "clone",
);

my $use_m;

BEGIN
{
    unless ($use_m)
    {
        eval "use Module::Runtime (); 1;"
          and $use_m = Module::Runtime->can("use_module")
          unless $ENV{CLONE_CHOOSE_NO_MODULE_RUNTIME};
        $use_m ||= sub {
            my ($pkg, @imports) = @_;
            my $use_stmt = "use $pkg";
            @imports and $use_stmt = join(" ", $use_stmt, @imports);
            eval $use_stmt;
            $@ and die $@;
            1;
        };
    }
}

sub backend
{
    my $self     = shift;
    my @backends = @BACKENDS;

    if ($ENV{CLONE_CHOOSE_PREFERRED_BACKEND})
    {
        my $favourite = $ENV{CLONE_CHOOSE_PREFERRED_BACKEND};
        my %b         = @backends;
        Carp::croak "$favourite not found" unless $b{$favourite};
        @backends = ($favourite => $b{$favourite});
    }

    while (my ($pkg, $rout) = splice @backends, 0, 2)
    {
        eval { $use_m->($pkg, ref $rout ? ($rout->[0]) : ()); 1; } or next;

        my $fn = $pkg->can(ref $rout ? $rout->[1] : $rout);
        $fn or next;

        return $pkg;
    }

    return;
}

sub can
{
    my $self     = shift;
    my $name     = shift;
    my @backends = @BACKENDS;

    return __PACKAGE__->SUPER::can($name) unless $name eq "clone";

    if ($ENV{CLONE_CHOOSE_PREFERRED_BACKEND})
    {
        my $favourite = $ENV{CLONE_CHOOSE_PREFERRED_BACKEND};
        my %b         = @backends;
        Carp::croak "$favourite not found" unless $b{$favourite};
        @backends = ($favourite => $b{$favourite});
    }

    my $fn;
    while (my ($pkg, $rout) = splice @backends, 0, 2)
    {
        eval { $use_m->($pkg, ref $rout ? ($rout->[0]) : ()); 1; } or next;

        $fn = $pkg->can(ref $rout ? $rout->[1] : $rout);
        $fn or next;

        last;
    }

    return $fn;
}

sub import
{
    my ($me, @params) = @_;
    my $tgt = caller(0);

    my @B = @BACKENDS;
    local @BACKENDS = @B;

    push @params, "clone" unless grep { /^clone$/ } @params;

    while (my $param = shift @params)
    {
        if ($param =~ m/^:(.*)$/)
        {
            my $favourite = $1;
            $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}
              and $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} ne $favourite
              and Carp::croak
              "Environment CLONE_CHOOSE_PREFERRED_BACKEND($ENV{CLONE_CHOOSE_PREFERRED_BACKEND}) not equal to imported ($favourite)";

            my %b = @BACKENDS;
            Carp::croak "$favourite not found" unless $b{$favourite};
            @BACKENDS = ($favourite => $b{$favourite});
        }
        elsif ($param eq "clone")
        {
            my $fn = __PACKAGE__->can("clone");
            $fn or Carp::croak "Cannot find an apropriate clone().";

            no strict "refs";
            *{"${tgt}::clone"} = $fn;

            @params
              and Carp::croak "Parameters left after clone. Please see description.";

            return;
        }
        else
        {
            Carp::croak "$param is not exportable by " . __PACKAGE__;
        }
    }
}

sub get_backends
{
    my $self     = shift;
    my %backends = @BACKENDS;

    if ($ENV{CLONE_CHOOSE_PREFERRED_BACKEND})
    {
        my $favourite = $ENV{CLONE_CHOOSE_PREFERRED_BACKEND};
        Carp::croak "$favourite not found" unless $backends{$favourite};
        %backends = ($favourite => $backends{$favourite});
    }

    return keys %backends;
}

1;

__END__