File Coverage

blib/lib/Package/CopyContents.pm

Criterion	Covered	Total	%
statement	101	102	99.0
branch	56	58	96.5
condition	17	18	94.4
subroutine	9	9	100.0
pod	1	1	100.0
total	184	188	97.8

## no critic: Modules::ProhibitAutomaticExportation
package Package::CopyContents;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-02-16'; # DATE
our $DIST = 'Package-CopyContents'; # DIST
our $VERSION = '0.004'; # VERSION

use strict 'subs', 'vars';
use warnings;
use Log::ger;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(copy_contents_from);

sub _list_pkg_contents {
    my $pkg = shift;

    my %contents;
    my $symtbl = \%{"$pkg\::"};
    for my $key (keys %$symtbl) {
        my $val = $symtbl->{$key};
        #print "key=$key, val=$val, ref val=", ref($val), "\n";
        next if $key =~ /::\z/; # skip subpackages
        $contents{$key} = 1 if ref $val eq 'CODE' || # perl >= 5.22
            defined *$val{CODE};
        $contents{"\$$key"} = 1 if defined *$val{SCALAR};
        $contents{"\@$key"} = 1 if defined *$val{ARRAY};
        $contents{"\%$key"} = 1 if defined *$val{HASH};
    }
    %contents;
}

sub copy_contents_from {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    my $src_pkg = shift;

    $opts->{load} = 1 unless defined $opts->{load};
    if ($opts->{dclone}) {
        require Storable;
    }

    (my $src_pkg_pm = "$src_pkg.pm") =~ s!::!/!g;
    if ($opts->{load}) {
        require $src_pkg_pm unless $INC{$src_pkg_pm};
    }
    my %src_contents = _list_pkg_contents($src_pkg);

    my $target_pkg = $opts->{to};
    $target_pkg = caller unless defined $target_pkg;
    my %target_contents = _list_pkg_contents($target_pkg);

  NAME:
    for my $name (sort keys %src_contents) {
        my $skip;
        if ($name =~ /\A\$/ && $opts->{skip_scalar}) {
            log_trace "Not copying $name from $src_pkg to $target_pkg (skip_scalar=1)";
            $skip++; goto SKIPPING;
        }
        if ($name =~ /\A\@/ && $opts->{skip_array}) {
            log_trace "Not copying $name from $src_pkg to $target_pkg (skip_array=1)";
            $skip++; goto SKIPPING;
        }
        if ($name =~ /\A\%/ && $opts->{skip_hash}) {
            log_trace "Not copying $name from $src_pkg to $target_pkg (skip_hash=1)";
            $skip++; goto SKIPPING;
        }
        if ($name !~ /\A[\$\@\%]/ && $opts->{skip_sub}) {
            log_trace "Not copying $name from $src_pkg to $target_pkg (skip_sub=1)";
            $skip++; goto SKIPPING;
        }
        if ($opts->{exclude} && grep { $name eq $_ } @{ $opts->{exclude} }) {
            log_trace "Not copying $name from $src_pkg to $target_pkg (listed in exclude)";
            $skip++; goto SKIPPING;
        }

        my $overwrite = exists $target_contents{$name} ? 1:0;

        if ($opts->{_before_copy}) {
            $skip = 1 if $opts->{_before_copy}->($name, $src_pkg, $target_pkg, $opts, $overwrite);
        }
        if ($skip) {
            log_trace "Not copying $name from $src_pkg to $target_pkg (_before_copy)";
            next NAME;
        }

      SKIPPING:
        {
            last unless $skip;
            if ($opts->{_on_skip}) {
                $opts->{_on_skip}->($name, $src_pkg, $target_pkg, $opts);
            }
            next NAME;
        }

        if ($overwrite) {
            log_trace "Overwriting $name from $src_pkg to $target_pkg";
        } else {
            log_trace "Copying $name from $src_pkg to $target_pkg ...";
        }

        if ($name =~ /\A\$(.+)/) {
            no warnings 'once', 'redefine';
            ${"$target_pkg\::$1"} = ${"$src_pkg\::$1"};
        } elsif ($name =~ /\A\@(.+)/) {
            no warnings 'once', 'redefine';
            @{"$target_pkg\::$1"} = $opts->{dclone} ? @{ Storable::dclone(\@{"$src_pkg\::$1"}) } : @{"$src_pkg\::$1"};
        } elsif ($name =~ /\A\%(.+)/) {
            no warnings 'once', 'redefine';
            %{"$target_pkg\::$1"} = $opts->{dclone} ? %{ Storable::dclone(\%{"$src_pkg\::$1"}) } : %{"$src_pkg\::$1"};
        } else {
            no warnings 'once', 'redefine';
            *{"$target_pkg\::$name"} = \&{"$src_pkg\::$name"};
        }
        if ($opts->{_after_copy}) {
            $opts->{_after_copy}->($name, $src_pkg, $target_pkg, $opts, $overwrite);
        }
    }
}

1;
# ABSTRACT: Copy (some) contents from another package

__END__