Perl：将文件移动到专用文件夹中

Question

我有一个Perl脚本，可以将文件从一个目录（/folder/）移动到另一个目录（/folder2/），然后如果文件名（File20.doc）与文件夹名称（folder/file20）完全匹配，则会将文件放入该文件夹中。

我需要的是，如果文件名的一部分与文件夹名称匹配，则将该文件放入该文件夹中。例如，如果文件名为file24.doc，则将该文件放入file20中。

以下是我拥有的脚本，它会将精确的文件名匹配到相应的文件夹中。

#!/usr/bin/perl
use warnings;
use File::Copy;

my $srcdir = "/folder/";
 my $dest = "/folder2/";

opendir(DIR, $srcdir) or die "Can't open $srcdir: $!";
 @files = grep {!/^\.+$/ }  readdir(DIR);


 foreach my $file (@files) {

 my $old = "$srcdir/$file";


 move($old, $dest) or die "Move $old -> $dest failed: $!";


 }   
close(DIR);

print "

-Complete";
exit;

- user731668

Answer 1

稍微扩展一下Wes的答案，以考虑到部分匹配，我认为这样做会起作用：

foreach my $file (@files) 
{
    my $old = "$srcdir/$file";
    my $new = "$dest/$file";
    my $subdir = $file;
    while (length($subdir)>0)
    {
        if (-d "$dest/$subdir")
        {
            $new = "$dest/$subdir/$file";
            last;
        }
        chop($subdir);
    }

    rename($old, $new) or die "Move $old -> $dest failed: $!";
}  

基本上，只需检查子目录以逐渐更小的前缀来查找文件名。这样，文件将进入与最长前缀匹配的目录名称。

- Brian Rothstein

---

我测试了这段代码，它可以正常工作。我发布了答案，是因为我想说明尝试逐渐缩小目录名称匹配范围以找到最佳匹配的想法。 - Brian Rothstein

哈哈。我对这一切都很新。我想既然我已经问了几个问题，我也应该尝试回答一些问题。但是现在我生怕被踩票！我的意思是，这种恐惧可以让回答更加深思熟虑，但同时，也许当有人踩票时，他们可以发表评论说出错了什么，这样我就可以学习到不应该做什么。 - Brian Rothstein

Answer 2

我也提出了我的解决方案。虽然它还远非完美，但我认为它的好处在于已经将目的地查找程序拆分出来。

use strict;
use warnings;
use File::Copy 'move';

# Determine destination folder for file based on filename.
# All destinations are below a fallback destination provided as input.
sub make_dest_finder {
    my $fallback_dest = shift;
    return sub {
        my $fnam = shift;
        # Determine basename to start looking for a destination folder.
        my $basename = substr $fnam, 0, rindex $fnam, '.';
        # Shorten name while no homonymous folder exists.
        chop $basename while $basename && ! -d "$fallback_dest/$basename";
        return "$fallback_dest/$basename" if $basename;
        return  $fallback_dest;
    };
}

my $srcdir      = "/tmp/folder";
my $dest_finder = make_dest_finder '/tmp/folder2';

opendir my $dh, $srcdir or die "Can't open $srcdir: $!";
my @files = grep ! /^\.+$/, readdir $dh;
close $dh;

my $moved = 0;
foreach my $file (@files) {
    my $old = "$srcdir/$file";
    my $dest = $dest_finder->( $file );
    print STDERR "moving $file to $dest\n";
    if ( ! move $old, $dest ) {
        warn "Move $old -> $dest failed: $!";
        last;
    }
    $moved++;
}

print STDERR "\n\n- moved $moved files\n";

- Lumi

Answer 3

你需要的函数是rename()，而不是move()。

对于匹配部分，最好使用正则表达式将文件名内容拆开，然后测试目录是否存在：

foreach my $file (@files) {
    my $old = "$srcdir/$file";
    my ($basename) = ($file =~ /(.*)\.[^\.]+);
    $dist = $file;
    if ($basename && -d "$basename") {
        $dest = "$basename/$file";
    }
    rename($old, $dest) or die "Move $old -> $dest failed: $!";
}   

- Wes Hardaker

---

不，File::Copy的move是重命名文件的好方法。如果你要将一个文件从一个文件系统移动到另一个文件系统（取决于你的操作系统），rename不一定会起作用。move首先尝试使用rename，如果失败了，它就通过复制和删除来处理。 - cjm