305 lines
7.4 KiB
Perl
305 lines
7.4 KiB
Perl
package Clone::Choose;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use Carp ();
|
|
|
|
our $VERSION = "0.010";
|
|
$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;
|
|
}
|
|
}
|
|
|
|
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__
|
|
|
|
=head1 NAME
|
|
|
|
Clone::Choose - Choose appropriate clone utility
|
|
|
|
=begin html
|
|
|
|
<a href="https://travis-ci.org/perl5-utils/Clone-Choose"><img src="https://travis-ci.org/perl5-utils/Clone-Choose.svg?branch=master" alt="Travis CI"/></a>
|
|
<a href='https://coveralls.io/github/perl5-utils/Clone-Choose?branch=master'><img src='https://coveralls.io/repos/github/perl5-utils/Clone-Choose/badge.svg?branch=master' alt='Coverage Status'/></a>
|
|
|
|
=end html
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use Clone::Choose;
|
|
|
|
my $data = {
|
|
value => 42,
|
|
href => {
|
|
set => [ 'foo', 'bar' ],
|
|
value => 'baz',
|
|
},
|
|
};
|
|
|
|
my $cloned_data = clone $data;
|
|
|
|
# it's also possible to use Clone::Choose and pass a clone preference
|
|
use Clone::Choose qw(:Storable);
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<Clone::Choose> checks several different modules which provides a
|
|
C<clone()> function and selects an appropriate one. The default preference
|
|
is
|
|
|
|
Clone
|
|
Storable
|
|
Clone::PP
|
|
|
|
This list might evolve in future. Please see L</EXPORTS> how to pick a
|
|
particular one.
|
|
|
|
=head1 EXPORTS
|
|
|
|
C<Clone::Choose> exports C<clone()> by default.
|
|
|
|
One can explicitly import C<clone> by using
|
|
|
|
use Clone::Choose qw(clone);
|
|
|
|
or pick a particular C<clone> implementation
|
|
|
|
use Clone::Choose qw(:Storable clone);
|
|
|
|
The exported implementation is resolved dynamically, which means that any
|
|
using module can either rely on the default backend preference or choose
|
|
a particular one.
|
|
|
|
It is also possible to select a particular C<clone> backend by setting the
|
|
environment variable CLONE_CHOOSE_PREFERRED_BACKEND to your preferred backend.
|
|
|
|
This also means, an already chosen import can't be modified like
|
|
|
|
use Clone::Choose qw(clone :Storable);
|
|
|
|
When one seriously needs different clone implementations, our I<recommended>
|
|
way to use them would be:
|
|
|
|
use Clone::Choose (); # do not import
|
|
my ($xs_clone, $st_clone);
|
|
{ local @Clone::Choose::BACKENDS = (Clone => "clone"); $xs_clone = Clone::Choose->can("clone"); }
|
|
{ local @Clone::Choose::BACKENDS = (Storable => "dclone"); $st_clone = Clone::Choose->can("clone"); }
|
|
|
|
Don't misinterpret I<recommended> - modifying C<@Clone::Choose::BACKENDS>
|
|
has a lot of pitfalls and is unreliable beside such small examples. Do
|
|
not hesitate open a request with an appropriate proposal for choosing
|
|
implementations dynamically.
|
|
|
|
The use of C<@Clone::Choose::BACKENDS> is discouraged and will be deprecated
|
|
as soon as anyone provides a better idea.
|
|
|
|
=head1 PACKAGE METHODS
|
|
|
|
=head2 backend
|
|
|
|
C<backend> tells the caller about the dynamic chosen backend:
|
|
|
|
use Clone::Choose;
|
|
say Clone::Choose->backend; # Clone
|
|
|
|
This method currently exists for debug purposes only.
|
|
|
|
=head2 get_backends
|
|
|
|
C<get_backends> returns a list of the currently supported backends.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Jens Rehsack <rehsack at cpan dot org>
|
|
Stefan Hermes <hermes at cpan dot org>
|
|
|
|
=head1 BUGS
|
|
|
|
Please report any bugs or feature requests to
|
|
C<bug-Clone-Choose at rt.cpan.org>, or through the web interface at
|
|
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Clone-Choose>.
|
|
I will be notified, and then you'll automatically be notified of progress
|
|
on your bug as I make changes.
|
|
|
|
=head1 SUPPORT
|
|
|
|
You can find documentation for this module with the perldoc command.
|
|
|
|
perldoc Clone::Choose
|
|
|
|
You can also look for information at:
|
|
|
|
=over 4
|
|
|
|
=item * RT: CPAN's request tracker
|
|
|
|
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Clone-Choose>
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation
|
|
|
|
L<http://annocpan.org/dist/Clone-Choose>
|
|
|
|
=item * CPAN Ratings
|
|
|
|
L<http://cpanratings.perl.org/d/Clone-Choose>
|
|
|
|
=item * Search CPAN
|
|
|
|
L<http://search.cpan.org/dist/Clone-Choose/>
|
|
|
|
=back
|
|
|
|
=head1 LICENSE AND COPYRIGHT
|
|
|
|
Copyright 2017 Jens Rehsack
|
|
Copyright 2017 Stefan Hermes
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of either: the GNU General Public License as published
|
|
by the Free Software Foundation; or the Artistic License.
|
|
|
|
See http://dev.perl.org/licenses/ for more information.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Clone>, L<Clone::PP>, L<Storable>
|
|
|
|
=cut
|