File Coverage

blib/lib/File/Util/Copy.pm

Criterion	Covered	Total	%
statement	17	41	41.4
branch	0	16	0.0
condition	0	4	0.0
subroutine	6	8	75.0
pod	2	2	100.0
total	25	71	35.2

package File::Util::Copy;

use 5.010001;
use strict;
use warnings;
use Log::ger;

use Exporter 'import';
use File::Copy ();

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-11-22'; # DATE
our $DIST = 'File-Util-Copy'; # DIST
our $VERSION = '0.002'; # VERSION

our @EXPORT_OK = qw(
                       copy_noclobber
                       copy_warnclobber
               );

sub copy_noclobber {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    $opts->{pattern} //= " (%02d)";

    my ($from, $to) = @_;
    my $ext; $to =~ s/(\.\w+)\z// and $ext = $1;

    # XXX handle when to is a filehandle ref/blob, which File::Copy supports

    my $i = 0;
    my $to_final;
    while (1) {
        if ($i) {
            my $suffix = sprintf $opts->{pattern}, $i;
            $to_final = $ext ? "$to$suffix$ext" : "$to$suffix";
        } else {
            $to_final = $to;
        }
        lstat $to_final;
        last unless -e _;
        $i++;
    }
    File::Copy::copy($from, $to_final);
}

sub copy_warnclobber {
    my $opts = ref $_[0] eq 'HASH' ? shift : {};
    $opts->{log} //= 0;

    my ($from, $to) = @_;

    # XXX handle when to is a filehandle ref/blob, which File::Copy supports
    if (-e $to) {
        if ($opts->{log}) {
            log_warn "copy_warnclobber(`$from`, `$to`): Target already exists, renaming anyway ...";
        } else {
            warn "copy_warnclobber(`$from`, `$to`): Target already exists, renaming anyway ...\n";
        }
    }

    File::Copy::copy($from, $to);
}

1;
# ABSTRACT: Utilities related to copying files

__END__