Comment trouver les parties communes dans un chemin avec perl ?

Question

Avoir plusieurs chemins, comme :

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

J'ai besoin de trouver les parties communes - toutes celles qui sont possibles, par exemple dans l'exemple ci-dessus, si possible pour trouver les parties communes :

 /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

etc.

Je n'ai absolument aucune idée de la manière de résoudre ce problème - quelle est la bonne approche ?

• basé sur des chaînes - quelque peu trouver les parties communes d'une corde
• basé sur les listes - diviser tous les chemins en listes et quelque peu comparer des tableaux pour trouver des éléments communs
• arbre-graphe - quelque peu trouver les parties communes d'un graphique
• autre ?

Lorsque je recevrai des instructions sur la façon de résoudre ce problème, je pourrai (probablement) le coder moi-même - ne veulent donc pas service de programmation gratuit - mais j'ai besoin de conseils pour commencer.

Je suis sûr qu'il existe déjà un module CPAN qui pourrait m'aider, mais je n'ai vraiment aucune idée de la façon de trouver le bon module utile parmi la liste de 30 000 modules pour le problème ci-dessus :(.

EDIT - Pour ce dont j'ai besoin, ceci :

J'ai environ 200 000 fichiers, répartis dans 10 000 répertoires, et beaucoup d'entre eux sont liés entre eux, par exemple :

/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

Les fichiers sont de types différents (pdf, images, doc, txt et ainsi de suite), plusieurs sont identiques (comme ci-dessus file2 - facile à filtrer avec Digest::MD5), mais la seule façon de les "regrouper" est de se baser sur les "parties communes" d'un chemin - par exemple "project1/subproject" et ainsi de suite

D'autres fichiers ont le même MD5, ce qui permet de filtrer les doublons, mais ils se trouvent dans des arbres différents, par exemple

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

donc, les fichiers sont les mêmes, (md5 identiques) mais il faut quelque peu déplacer une copie vers le bon endroit (et en supprimer d'autres) et il faut en quelque sorte déterminer les chemins communs "les plus utilisés", et collecter les tags... (les anciens éléments de chemins sont des tags)

L'idée derrière est :

• si les mêmes fichiers md5 sont principalement stocké sous un certain voie commune - Je peux prendre une décision où déplacer une copie ...

Et c'est plus compliqué, mais pour l'explication, il suffit de ce qui précède ;)

J'ai simplement besoin de réduire l'entropie sur mon disque dur ;)

Answer 1

Il y a une discussion sur la recherche des plus longues sous-chaînes consécutives communes dans ce fil de discussion : http://www.nntp.perl.org/group/perl.fwp/2002/02/msg1662.html

Le "gagnant" semble être le code suivant, mais il y a quelques autres choses que vous pouvez essayer :

#!/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");
    }
}

Gardez à l'esprit que vous devrez l'ajuster un peu pour tenir compte du fait que vous ne voulez que des sous-répertoires entiers qui correspondent... par exemple, changez if ($len == 1) à quelque chose comme if ($len == 1 or $lcs !~ /^\// or $lcs !~ /\/$/)

Il faudrait également ajouter une comptabilité pour garder la trace de ceux qui correspondent. Lorsque j'ai exécuté ce code sur vos exemples ci-dessus, il a également trouvé le fichier /abc/ dans les lignes 1 et 5.

Une chose qui peut ou non être un problème est que les deux lignes suivantes :

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

Il y aurait une correspondance :

/abc/another/

Mais pas sur :

/path/to/ppp/

Mais voici les mauvaises nouvelles -- vous devrez faire O(n^2) comparaisons avec n=200,000 fichiers. Cela pourrait prendre une quantité obscène de temps.

Une autre solution serait de parcourir chaque chemin de votre liste, d'ajouter tous ses chemins de répertoire possibles comme clés d'un hachage et de pousser le fichier lui-même dans le hachage (de sorte que la valeur soit un tableau de fichiers contenant ce chemin). Quelque chose comme ceci :

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
        }
    }
}

Bien sûr, cela prendrait une quantité obscène de mémoire. Avec 200 000 fichiers à traiter, vous risquez d'avoir du mal quoi que vous fassiez, mais vous pouvez peut-être le diviser en morceaux plus faciles à gérer. Avec un peu de chance, cela vous donnera un point de départ.

Answer 2

Pour résoudre ce problème, vous avez besoin de la bonne structure de données. Un hachage qui compte les chemins partiels fonctionne bien :

use File::Spec;

my %Count_of = ();

while( <DATA> ){
  my @names = File::Spec->splitdir( $_ );

  # remove file
  pop @names;

  # if absolute path, remove empty names at start
  shift @names while length( $names[0] ) == 0;

  # don't count blank lines
  next unless @names;

  # move two cursor thru the names,
  # and count the partial parts
  # created from one to the other
  for my $i ( 0 .. $#names ){
    for my $j ( $i .. $#names ){
      my $partial_path = File::Spec->catdir( @names[ $i .. $j ] );
      $Count_of{ $partial_path } ++;
    }
  }
}

# now display the results
for my $path ( sort { $Count_of{$b} <=> $Count_of{$a} || $a cmp $b } keys %Count_of ){

  # skip if singleton.
  next if $Count_of{ $path } <= 1;

  printf "%3d : %s\n", $Count_of{ $path }, $path;
}

__DATA__
/abc/def/some/common/part/xyz/file1.ext
/other/path/to/7433/qwe/some/common/part/anotherfile.ext
/misc/path/7433/qwe/some/common/part/filexx.ext
/2443/totally/different/path/file9988.ext
/abc/another/same/path/to/ppp/thisfile.ext
/deep1/deep2/another/same/path/to/diffone/filename.ext