Initial Commit
This commit is contained in:
Riley Schneider
304
database/perl/vendor/lib/Clone/Choose.pm
vendored
Normal file
304
database/perl/vendor/lib/Clone/Choose.pm
vendored
Normal file
@@ -0,0 +1,304 @@
|
||||
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
|
||||
Reference in New Issue
Block a user