Server IP : 85.214.239.14 / Your IP : 3.135.202.168 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /proc/2/task/2/cwd/usr/share/perl5/Clone/ |
Upload File : |
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