perl - 如何使用 perl 在路径中查找公共(public)部分？

Question

有多个路径，例如:

1: /abc/def/some/common/part/xyz/file1.ext
2: /other/path/to/7433/qwe/some/common/part/anotherfile.ext
3: /misc/path/7433/qwe/some/common/part/filexx.ext
4: /2443/totally/different/path/file9988.ext
5: /abc/another/same/path/to/ppp/thisfile.ext
6: /deep1/deep2/another/same/path/to/diffone/filename.ext

我需要找到共同的部分——每个可能的部分，例如。如果可能的话，在上面找到公共(public)部分:

 /some/common/part/ - in the paths 1,2,3
 /another/same/path/to/ - in the 5,6
 /path/to/ - in the 2,5,6
 /path/ - 2,3,4,5,6

等..

我完全不知道如何解决这个问题——哪种方法好

• 基于字符串 - 有点找到字符串的公共(public)部分
• 基于列表 - 将所有路径拆分为列表并稍微比较数组中的公共(public)元素
• TreeMap - 有点找到图的公共(public)部分
• 其他？

当我找到解决这个问题的方向时，我(可能)能够自己编写代码 - 所以不需要免费编程服务 - 但需要一些指导如何开始。

我确定这里已经有一些 CPAN 模块可以帮助我，但我真的不知道如何从 30k 模块列表中找到正确有用的模块来解决上述问题。 :(

编辑 - 我需要这个:

有大约。 20 万个文件，在 1 万个目录中，其中许多文件“属于一起”，例如:

/u/some/path/project1/subprojct/file1
/u/backup/of/work/date/project1/subproject/file2
/u/backup_of_backup/of/work/date/project1/subproject/file2
/u/new/addtions/to/projec1/subproject/file3

文件类型不同(pdf、图像、doc、txt 等)，有几个是相同的(如上面的 file2 - 易于使用 Digest::MD5 进行过滤)，但“将它们组合在一起”的唯一方法是基于在路径的“公共(public)部分”上——例如“project1/subproject”等等..

另一个文件具有相同的 MD5，因此可以过滤掉重复项，但它们在不同的树中，例如

/u/path/some/file
/u/path/lastest_project/menu/file
/u/path/jquery/menu/file
/u/path/example/solution/jquery/menu/file

因此，文件是相同的(相同的 md5)但需要某种程度上将一个副本移动到正确的位置(并删除其他文件)并且需要某种程度上确定“most used"常用路径，并收集标签...(旧路径元素是标签)

背后的想法是:

• 如果相同的 md5 文件大部分存储在一些公共(public)路径下 - 我可以决定将一个副本移动到哪里...

而且它更复杂，但是上面的解释就足够了；)

只需要降低我硬盘上的熵 ;)

Answer 1

在这个线程中有一些关于寻找最长公共(public)连续子串的讨论:http://www.nntp.perl.org/group/perl.fwp/2002/02/msg1662.html

“赢家”似乎是以下代码，但您还可以尝试其中的一些其他内容:

#!/usr/bin/perl
use strict;
use warnings;

sub lcs {

    my $this = shift;
    my $that = shift;

    my $str = join "\0", $this, $that;
    my $len = 1;
    my $lcs;
    while ($str =~ m{ ([^\0]{$len,}) (?= [^\0]* \0 [^\0]*? \1 ) }xg) {
        $lcs = $1;
        $len = 1 + length($1);
    }

    if ($len == 1) { print("No common substring\n"); }
    else {
        print("Longest common substring of length $len: \"");
        print("$lcs");
        print("\"\n");
    }
}

请记住，您必须稍微调整一下以说明您只需要匹配的整个子目录...即，将 if ($len == 1) 更改为类似if ($len == 1 or $lcs !~/^\//or $lcs !~/\/$/)

您还必须添加一些簿记来跟踪哪些匹配。当我在上面的示例中运行此代码时，它还在第 1 行和第 5 行中找到了 /abc/ 匹配项。

有一件事可能是也可能不是问题是以下两行:

/abc/another/same/path/to/ppp/thisfile.ext
/abc/another/different/path/to/ppp/otherfile.ext

将匹配于:

/abc/another/

但不是:

/path/to/ppp/

但是 -- 坏消息 -- 您将不得不对 n=200,000 个文件进行 O(n^2) 次比较。这可能会花费大量时间。

另一种解决方案是遍历列表中的每个路径，将其所有可能的目录路径作为键添加到散列中，并将文件本身推送到散列中(以便值是具有此路径的文件数组在里面)。像这样:

use strict;
use warnings;
my %links;

open my $fh, "<", 'filename' or die "Can't open $!";
while (my $line = <$fh>) {
    chomp($line);
    my @dirs = split /\//, $line;
    for my $i (0..$#dirs) {
        if ($i == $#dirs) {
            push(@{ $links{$dirs[$i]} }, $line);
        }
        for my $j ($i+1..$#dirs) {
            push(@{ $links{join("/",@dirs[$i..$j])} }, $line);
            #PROCESS THIS if length of array is > 1
        }
    }
}

当然，这会占用大量内存。有 200,000 个文件要处理，无论您尝试什么，您都可能会遇到困难，但也许您可以将其分解成更易于管理的 block 。希望这会给您一个起点。