在 Perl 中批量重命名和移动文件

Question

我正在寻找一种方法来重命名每个找到的 .seg 文件，以包含位于 .seg 文件上方两个目录的文件夹的名称。

例如我在

中找到了一个.seg文件

/data/test_all_runs/TestRun/Focus-HD753/QC/diffCoverage.seg 

并且想重命名它

Focus-HD753.seg

一旦我重命名了文件，我想将它移动到

/data/test_all_runs/TestRun

或$ARGV[0]。这是我当前的代码：

#!/usr/bin/perl
use warnings;
use strict;
use File::Find;
use File::Spec;

my $home = "/data";
my @location_parts = ($home, 'test_all_runs');
push @location_parts, $ARGV[0] if @ARGV;
my $location = File::Spec->catdir(@location_parts);

my @moves;
my @vcf_moves;
sub find_seg {
    my $F = $File::Find::name;
    if ($F =~ /\.seg$/ ) {
        my @path_parts = File::Spec->splitdir($F);
        my $name = $path_parts[-3];
        my $target = File::Spec->catdir($location, "$name.seg"); print $target;
        push @moves, [ $F, $target ];
    }
}   
find({ wanted => \&find_seg, no_chdir => 1 }, $home);

while (@moves) {
    my ($F, $target) = @{ shift @moves };
    warn "$F -> $target";
    rename $F, $target or warn "Can't move to $target";
}

sub find_vcf {
    my $V = $File::Find::name;
    if ($V =~ /(vcf$|oncomine\.tsv$)/ ) {
        my @path_parts = File::Spec->splitdir($V);
       print "The path_parts at 0 is #############".$path_parts[0]."\n";
       print "The path_parts at -1 is #############".$path_parts[-1]."\n";
       print "The path_parts at -2 is #############".$path_parts[-2]."\n";
       print "The path_parts at -3 is #############".$path_parts[-3]."\n";
       print "The path_parts at 1 is #############".$path_parts[1]."\n";
       my $target_vcf = File::Spec->catdir($location, $path_parts[-1]); print $target_vcf;
      push @vcf_moves, [ $V, $target_vcf ];
      print "$V\n";

    }
}

find({ wanted => \&find_vcf, no_chdir=>1}, $home);

while (@vcf_moves) {
    my ($V, $target_vcf) = @{ shift @vcf_moves };
    warn "$V -> $target_vcf";
    rename $V, $target_vcf or warn "Can't move to $target_vcf";
}

Answer 1

使用rename 将文件移动到名称目标和名称。 File::Spec 使代码独立于操作系统。您也可以查看Path::Tiny 以了解类似的任务。

这些移动保存在一个数组中并稍后执行，否则 File::Find 可能会在遍历目录时多次移动同一个文件。

#!/usr/bin/perl
use warnings;
use strict;
use File::Find;
use File::Spec;

my $home = "/data";
my @location_parts = ($home, 'test_all_runs', 'TestRun');
push @location_parts, $ARGV[0] if @ARGV;
my $location = File::Spec->catdir(@location_parts);

my @moves;
sub find_seg {
    my $F = $File::Find::name;

    if ($F =~ /\.seg$/ ) {
        my @path_parts = File::Spec->splitdir($F);
        my $name = $path_parts[-3];
        my $target = File::Spec->catdir($location, "$name.seg");
        push @moves, [ $F, $target ];
    }
}

find({ wanted => \&find_seg, no_chdir => 1 }, $home);
while (@moves) {
    my ($F, $target) = @{ shift @moves };
    warn "$F -> $target";
    rename $F, $target or warn "Can't move to $target";
}

Answer 2

对于名称文件名的修改，您可以使用File::Basename 模块，它是核心的一部分。

#!/usr/bin/env perl
use strict;
use warnings;
use feature qw{say};
use File::Basename;

my $filePath = "/data/test_all_runs/TestRun/Focus-HD753/QC/diffCoverage.seg";
my ($filename, $directories, $extension) = fileparse($filePath, '.seg');

my $target = (split m{/}, $directories)[-2];
say "Target: $target";

my $newFilePath = "$directories$target$extension";
say $newFilePath;

结果：

Target: Focus-HD753
/data/test_all_runs/TestRun/Focus-HD753/QC/Focus-HD753.seg

然后您可以使用 $ARGV[0] 将其移动到您想要的位置（也许使用 File::Copy ？）