FAQ PerlConsultez toutes les FAQ

Nombre d'auteurs : 18, nombre de questions : 250, dernière mise à jour : 29 octobre 2015  Ajouter une question

 

Bienvenue sur la FAQ Perl. Cette FAQ a pour vocation de vous enseigner ou de vous faire revoir les notions élémentaires de ce fantastique langage. Perl est très utilisé dans différents domaines depuis la gestion système, le réseaux, l'administration de bases de données, le web (CGI), la bureautique, la conception d'interfaces graphiques ou des contextes scientifiques telle la bioinformatique. Nous espérons que cette FAQ vous sera d'une grande utilité.

Vous souhaitez participer à l'amélioration de cette FAQ, n'hésitez pas !! Commentez

Bonne lecture !


SommaireCodes sources utilesDes codes sourcesFichiers et répertoires (15)
précédent sommaire suivant
 

Le but est de pouvoir lister les répertoires d'un répertoire de manière récursive ou non. Voici une procédure qui vous permettra de le faire. Le premier argument doit être un nom de répertoire, et le deuxième (optionnel) doit être 1 (recherche recursive) ou 0 (pas de rechercher récursive).

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
#!/usr/bin/perl 
use warnings; 
use strict; 
  
my $repertoire = 'C:\tmp'; 
foreach my $rep ( lister_repertoires( $repertoire, 1 ) ) { 
  print "Rep : $rep\n"; 
} 
  
#====================================================== 
# Nombre d'arguments : 1 ou 2 
# Argument(s)        : un répertoire et valeur 0 ou 1 
# Retourne           : Tableau de répertoires (@repertoires) 
#====================================================== 
sub lister_repertoires { 
  my ( $repertoire, $recursivite ) = @_; 
  
  require Cwd; 
  require File::Spec; 
  
  my $cwd = Cwd::getcwd(); 
  
  # Recherche dans les sous-répertoires ou non 
  if ( ( not defined $recursivite ) || ( $recursivite != 1 ) ) { $recursivite = 0; } 
  
  # Verification répertoire 
  if ( not defined $repertoire ) { die "Aucun repertoire de specifie\n"; } 
  
  # Ouverture d'un répertoire 
  opendir my $fh_rep, $repertoire or die "impossible d'ouvrir le répertoire $repertoire\n"; 
  
  # Liste fichiers et répertoire sauf (. et ..) 
  my @fic_rep = grep { !/^\.\.?$/ } readdir $fh_rep; 
  
  # Fermeture du répertoire 
  closedir $fh_rep or die "Impossible de fermer le répertoire $repertoire\n"; 
  
  chdir $repertoire; 
  $repertoire = Cwd::getcwd(); 
  
  # On récupère tous les répertoires 
  my @repertoires; 
  foreach my $nom (@fic_rep) { 
    my $notre_repertoire = File::Spec->catdir( $repertoire, $nom ); 
  
    if ( -d $notre_repertoire and $recursivite == 0 ) { 
      push @repertoires, $notre_repertoire; 
    } 
    elsif ( -d $notre_repertoire and $recursivite == 1 ) { 
      push @repertoires, $notre_repertoire; 
      push @repertoires, lister_repertoires($notre_repertoire, $recursivite);    # recursivité 
    } 
  } 
  
  chdir $cwd; 
  
  return @repertoires; 
}

Mis à jour le 15 mars 2013 djibril

Le but est de pouvoir lister les fichiers d'un répertoire de manière récursive ou non. Voici une procédure que vous permettra de la faire. Le premier argument doit être un nom de répertoire, et le deuxième (optionnel) doit être 1 (recherche recursive) ou 0 (pas de rechercher récursive).

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
#!/usr/bin/perl 
use warnings; 
use strict; 
  
my $repertoire = 'C:/tmp'; 
foreach my $fichier ( lister_fichiers( $repertoire, 1 ) ) { 
  print "Fichier : $fichier\n"; 
} 
  
#====================================================== 
# Nombre d'arguments : 1 ou 2 
# Argument(s)        : un répertoire et valeur 0 ou 1 
# Retourne           : Tableau de fichier (@fichiers) 
#====================================================== 
sub lister_fichiers { 
  my ( $repertoire, $recursivite ) = @_; 
  
  require Cwd; 
  require File::Spec; 
  
  my $cwd = Cwd::getcwd(); 
  
  # Recherche dans les sous-répertoires ou non 
  if ( ( not defined $recursivite ) || ( $recursivite != 1 ) ) { $recursivite = 0; } 
  
  # Verification répertoire 
  if ( not defined $repertoire ) { die "Aucun repertoire de specifie\n"; } 
  
  # Ouverture d'un répertoire 
  opendir my $fh_rep, $repertoire or die "impossible d'ouvrir le répertoire $repertoire\n"; 
  
  # Liste fichiers et répertoire sauf (. et ..) 
  my @fic_rep = grep { !/^\.\.?$/ } readdir $fh_rep; 
  
  # Fermeture du répertoire 
  closedir $fh_rep or die "Impossible de fermer le répertoire $repertoire\n"; 
  
  chdir $repertoire; 
  $repertoire = Cwd::getcwd(); 
  
  # On récupère tous les fichiers 
  my @fichiers; 
  foreach my $nom (@fic_rep) { 
    my $notre_fichier = File::Spec->catfile( $repertoire, $nom ); 
  
    if ( -f $notre_fichier ) { 
      push @fichiers, $notre_fichier; 
    } 
    elsif ( -d $notre_fichier and $recursivite == 1 ) { 
      push @fichiers, lister_fichiers($notre_fichier, $recursivite);    # recursivité 
    } 
  } 
  
  chdir $cwd; 
  
  return @fichiers; 
}
Code : Sélectionner tout
1
2
3
4
5
Fichier : C:\tmp\.metadata\.log 
Fichier : C:\tmp\.metadata\.plugins\org.eclipse.core.runtime\.settings\com.sneda.pgi.application.prefs 
Fichier : C:\tmp\.metadata\.plugins\org.eclipse.core.runtime\.settings\org.eclipse.ui.prefs 
Fichier : C:\tmp\.metadata\.plugins\org.eclipse.ui.workbench\dialog_settings.xml 
Fichier : C:\tmp\.metadata\.plugins\org.eclipse.ui.workbench\workbench.xml
Cette procédure utilise le module File::Spec qui permet d'avoir les bons chemins de fichiers quelque soit la plateforme.

Si vous chercher un module pour lister des fichiers et vous permettant d'effectuer de traitements sur chacun d'eux, regardez le module File::Find. Il est présent dans le core de Perl, il est inutile de chercher à l'installer. Exemple :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
#!/usr/bin/perl 
use warnings; 
use strict; 
use File::Find; 
  
find( { wanted => \&process, }, 'C:/tmp' ); 
  
sub process { 
  if ( -f $File::Find::name ) { print "File::Find : $File::Find::name\n"; } 
}
Code : Sélectionner tout
1
2
3
4
5
File::Find : C:\tmp\.metadata\.log 
File::Find : C:\tmp\.metadata\.plugins\org.eclipse.core.runtime\.settings\com.sneda.pgi.application.prefs 
File::Find : C:\tmp\.metadata\.plugins\org.eclipse.core.runtime\.settings\org.eclipse.ui.prefs 
File::Find : C:\tmp\.metadata\.plugins\org.eclipse.ui.workbench\dialog_settings.xml 
File::Find : C:\tmp\.metadata\.plugins\org.eclipse.ui.workbench\workbench.xml

Mis à jour le 23 août 2007 djibril

Lorsque vous manipulez des fichiers ou répertoires, vous avez souvent besoin de construire et manipuler des chemins. Le premier réflexe sous Linux est d'utiliser des slashes (/) ou des backslashes (\) sous Windows. Des fois, vous pouvez être amené à utiliser des expressions régulières pour convertir des / en \ ou l'inverse.

Ce genre de manipulation est assez fastidieux et ne rend pas toujours les programmes portables. Voici un exemple :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
#!/usr/bin/perl 
use strict; 
use warnings; 
  
my $repertoire     = 'C:/repertoire'; 
my $nom_fichier    = 'fichier.txt'; 
my $chemin_fichier = $repertoire . '/' . $nom_fichier;
ou

Code perl : Sélectionner tout
1
2
3
4
5
6
7
#!/usr/bin/perl 
use strict; 
use warnings; 
  
my $repertoire     = 'C:\repertoire'; 
my $nom_fichier    = 'fichier.txt'; 
my $chemin_fichier = $repertoire . '\' . $nom_fichier;
La meilleure solution est de toujours utiliser le module Perl File::Spec qui est disponible dans le core de Perl. Vous n'aurez plus besoin de vous soucier de la plateforme sous laquelle tournera le programme. Voici un exemple d'utilisation :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Spec; 
  
my $repertoire     = 'C:\repertoire'; 
my $nom_fichier    = 'fichier.txt'; 
my $chemin_fichier = File::Spec->catfile($repertoire, $nom_fichier); 
print $repertoire,"\n"; 
  
my $chemin_repertoire = File::Spec->catdir('\test', 'tmp', 'dossier'); 
print $chemin_repertoire,"\n";
Code : Sélectionner tout
1
2
C:\repertoire 
\test\tmp\dossier
Code : Sélectionner tout
1
2
C:/repertoire 
/test/tmp/dossier
Pour en savoir plus, consultez la documentation officielle du module. Commentez

Mis à jour le 16 mars 2012 djibril

  • Renommer un fichier

Pour renommer un fichier en perl, une fonction perl existe déjà.

Code perl : Sélectionner tout
1
2
3
4
5
6
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Copy; 
# Pour renommer un fichier toto.txt en tutu.txt 
rename("toto.txt","tutu.txt");
  • Copier un fichier

Pour copier un fichier, la façon la plus propre et la plus simple est d'utiliser le module CPAN File::Copy déjà fait pour ça. C'est un module parmi tant d'autres.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Copy; 
my $fichier1 = "toto.txt"; 
my $fichier2 = "tutu.txt"; 
# Copie le fichier dans le même répertoire avec un nouveau nom 
copy($fichier1,$fichier2); 
  
# copie le fichier dans un autre répertoire avec un nom différent 
copy($fichier1,'C:/tata.txt'); 
  
# copie le fichier dans un autre répertoire avec le même nom 
copy($fichier1,'C:/');
Pour en savoir plus : File::Copy

Mis à jour le 26 juillet 2007 djibril

  • Faire une copie d'un répertoire

Utiliser le module File::Copy::Recursive, il est fait pour ça.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Copy::Recursive qw(fcopy rcopy dircopy fmove rmove dirmove); 
my $repertoire1 = "./rep1"; 
my $repertoire2 = "./rep2"; 
dircopy($repertoire1,$repertoire2) or die("Impossible de copier $repertoire1 $!");
  • Supprimer un répertoire en perl

Il existe une fonction en perl permettant de supprimer un répertoire en perl, mais ce dernier ne fonctionne que si le répertoire en question est vide.

Code perl : Sélectionner tout
1
2
3
4
5
6
#!/usr/bin/perl 
use strict; 
use warnings; 
  
my $repertoire_vide = "./rep1"; 
rmdir($repertoire);
Si vos répertoires ne sont pas vides, vous pouvez parcourir tous le repertoire récursivement et supprimer les fichiers. Ensuite parcourir les répertoires un à un et les supprimer un à un en partant de celui le plus en profondeur dans l'arborescence. Ca peut être un bon exercice. Mais sachez qu'il existe un module prêt à l'emploi et simple d'utilisation. Utiliser le module File::Path.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Path; 
my $repertoire1 = "./rep1"; 
rmtree([$repertoire1], 1, 1); 
# rmtree([$repertoire1, $repertoire2, $repertoire3], 1, 1);
En savoir plus sur File::Path

Mis à jour le 26 juillet 2007 djibril

Il est souvent utile de créer un fichier temporaire lorsque l'on traite un fichier. On a pour mauvaise habitude de créer un fichier avec un nom arbitraire, de tester si ce dernier n'existe pas, etc. Bien évidemment, c'est une mauvaise idée car perl nous fournit déjà ce qu'il faut. (Le module File::Temp est déjà dans le core de perl depuis perl 5.6.1.)
Exemple :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Temp qw/ tempfile /; 
  
# Création d'un fichier temporaire qui sera supprimé une fois le script terminé. 
# N'oubliez pas les 4 XXXX, perl créera un fichier avec à la place des X des caractères aléatoires. 
my ($fh_temp, $file_temp) = tempfile("fichier_temporaireXXXX", UNLINK => 1);  
  
# Fermeture du fichier temporaire 
close($fh_temp);

Mis à jour le 26 juillet 2007 djibril

Il y a deux solutions :

  • utiliser les expressions régulières

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
#!/usr/bin/perl 
use strict; 
use warnings; 
my $fichier = "C:\\Documents and Settings\\djibril\\fichier_faqperl.txt"; 
#ou my $fichier = "C:/Documents and Settings/djibril/fichier_faqperl.txt"; 
#ou my $fichier = "/home/djibril/fichier_faqperl.txt"; 
  
my ($repertoire,$nom_fichier) = $fichier =~ /(.+[\/\\])([^\/\\]+)$/; 
print "($repertoire,$nom_fichier)\n";

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Basename; 
my $fichier = "C:\\Documents and Settings\\djibril\\fichier_faqperl.txt"; 
#ou my $fichier = "C:/Documents and Settings/djibril/fichier_faqperl.txt"; 
#ou my $fichier = "/home/djibril/fichier_faqperl.txt"; 
  
my $repertoire = dirname($fichier); 
my $nom_fichier = basename($fichier); 
print "($repertoire,$nom_fichier)\n";
Pour récupérer également l'extension d'un fichier, le module File::Basename nous facilite grandement la vie grâce à la méthode fileparse. Voici des exemples de codes provenant de la documentation du module.

  • fileparse

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
my ($filename, $directories, $suffix) = fileparse($path); 
my($filename, $directories, $suffix) = fileparse($path, @suffixes); 
my $filename                         = fileparse($path, @suffixes);  
  
fileparse("/foo/bar/baz.txt", qr/\.[^.]*/); # On Unix returns ("baz", "/foo/bar", ".txt") 
fileparse("/foo/bar/baz");                  # On Unix returns ("baz", "/foo/bar/", "") 
fileparse("C:/foo/bar/baz"); 				# On Windows returns ("baz", "C:/foo\bar/", "") 
fileparse("/foo/bar/baz/"); 				# On Unix returns ("", "/foo/bar/baz/", "")

Mis à jour le 26 juillet 2007 djibril

Pour les débutants en programmation, sachez que le problème de modification d'un fichier et les solutions exposées ici sont utilisables dans n'importe quel langage. On ne peut pas simplement"modifier une ligne" dans un fichier, ceci est rendu impossible par la façon dont est stockée un fichier. En effet le fichier est une suite d'octets contigus en mémoire (ou du moins qui nous apparaissent ainsi à notre niveau), donc "modifier une ligne" implique forcément de déplacer toute la fin du fichier pour combler le trou à partir du moment où la modification implique un changement de longueur de la ligne…

Voici plusieurs stratégies pour traiter ce problème :

  • On ouvre en lecture/écriture, on met l'ensemble du fichier en mémoire (par exemple dans un tableau de lignes), on le modifie là, on tronque le fichier initial et on réécrit la version modifiée
  • On lit enregistrement par enregistrement (ligne par ligne par exemple) le fichier, et on modifie chaque enregistrement selon ses besoins, puis on le réécrit dans un autre fichier, finalement on écrase le fichier original par la version modifiée.
  • Variation 1 : On ne met en mémoire que la fin du fichier, la partie à partir de la première modification
  • Variation 2 : On utilise un tampon pour mettre à jour la fin du fichier en procédant par petit bout, sans écraser les données qu'on n'a pas encore mis en mémoire.

Chacune de ses solutions a ses avantages et ses inconvénients :

  • Pour les gros fichiers cette stratégie est très lourde en mémoire.
  • Bonne solution, sauf si son disque est encombré (en effet le fichier est présent en double sur le disque avant l'étape finale)... De plus ce n'est pas forcément optimal de tout recopier alors qu'on a modifié qu'un enregistrement.
  • Pas mal, mais même problème que le 1 si l'enregistrement est au début du fichier.
  • L'idéal, ou presque, mais très complexe à mettre en place, surtout de façon intelligente (c'est à dire par exemple en permettant de commander plusieurs modifications avant de commencer à changer
    réellement le fichier sous-jacent).

Nous vous conseillons de s'en tenir à la solution 2 dès lors que l'on a de grosses modifications à effectuer sur des fichiers dont on n'est pas sûr de la taille.
La solution 1 peut convenir si on est sûr que les fichiers resteront petits (mais on peut rarement être vraiment sûr dans un environnement informatique).
La solution 4 est trop complexe pour être utilisée à la main de façon raisonnable (efficacement), mais ça tombe bien, Perl est fourni en standard depuis la 5.8 avec un module Tie::File qui implémente ce modèle de façon intelligente. (Tie::File est compatible avec Perl depuis la version 5.4 mais n'est pas en standard avec les versions inférieures à la 5.8) Tie::File permet de "lier" un tableau à un fichier, de sorte que l'on peut manipuler un fichier comme s'il s'agissait d'un tableau de lignes, et Tie::File s'occupe de toutes les modifications réelles du fichier.
Par exemple il est possible de supprimer une ou des lignes avec splice(), il est possible de "retarder" l'application des modifications, de sortes que plusieurs soit appliquées à la fois.

Nous allons écrire un script qui modifie la troisième ligne d'un fichier pour lui rajouter par exemple la chaîne ", et Bob était là."

Méthode 1
  • Méthode 1, exemple

Avec cette méthode, on écrira ceci :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
#!/usr/bin/perl 
use strict; 
use warnings; 
  
# on récupère l'argument 
my $nom_fichier = shift; 
  
# on vérifie si le fichier existe 
die "Ce fichier <$nom_fichier> n'existe pas (ou n'est pas un vrai fichier)." 
   if -f $nom_fichier; 
  
# on commence par ouvrir le fichier en lecture 
open my($fichier), '<', $nom_fichier 
   or die "Ce fichier $nom_fichier n'a pu être ouvert : $!\n"; 
  
# on place le contenu dans un tableau de ligne 
my @lignes = <$fichier>; 
  
# on referme le fichier 
close $fichier; 
  
# on modifie la 3e ligne 
chomp( $lignes[2] ); 
$lignes[2] .= ", et Bob était là.\n"; 
  
# on rouvre le fichier en écriture en écrasant le contenu 
open my($fichier), '>', $nom_fichier 
   or die "Ce fichier $nom_fichier n'a pu être ouvert : $!\n"; 
  
# et on réécrit le contenu modifié 
print $fichier @lignes; 
  
close $fichier 
  
__END__ 
On a fini.
Il y a des variantes bien sûr, par exemple il n'est pas toujours avantageux de lire dans un tableau de lignes (quand les modifications que l'on veut faire ne sont pas basés sur une vision ligne par ligne du fichier).

Méthode 2
  • Méthode 2, exemple 1

Voici une fonction qui implémente la 2ème méthode, et un exemple d'utilisation de cette fonction qui fait la même chose que l'exemple précédent :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
#!/usr/bin/perl 
use strict; 
use warnings; 
  
use File::Copy qw(move); 
use File::Temp; 
  
# on crée une fonction qui prend un bloc et un nom de fichier en paramètre 
# et exécute le bloc à chaque ligne du fichier : 
# dans le bloc $_ vaut la ligne courante, et toute modification de $_ 
# est reflétée sur la ligne dans le fichier 
sub modify_in_place (&$); 
  
my $filename = shift; 
  
# $. vaut le numéro de ligne dans le fichier qu'on est en train de lire 
modify_in_place { s/$/, et Bob était là./ if $. == 3 } $filename; 
  
sub modify_in_place (&$) { 
    my $block    = shift; 
    my $filename = shift; 
    local $_; 
    open my ($file), '<', $filename 
      or die "This file $filename couldn't be opened : $!\n"; 
  
    # on utilise File::Temp pour créer un fichier temporaire en toute sécurité 
    my $tempfile = new File::Temp(); 
  
    while (<$file>) { 
        $block->(); 
        print $tempfile $_; 
    } 
    close $file; 
    close $tempfile; 
    move "$tempfile", $filename 
      or die "We couldn't overwrite $filename with $tempfile : $!\n"; 
} 
  
__END__
Dans ce code j'utilise File::Temp et File::Copy, ces deux modules sont distribués en standard avec Perl depuis la version 5.6.1 (5.2 pour File::Copy). Si votre version est plus vieille, vous pouvez créer un fichier temporaire à la main ou installer le module File::Temp si c'est possible. Pour ceux qui s'intéressent à des techniques "avancées" en Perl, remarquez que le prototype (&$) attribué à ma fonction m'autorise à l'utiliser comme un grep() ou un map() (bloc nu et pas de virgule). Il s'agit là d'une utilisation correcte des prototypes en Perl, ils n'ont jamais été conçu pour vérifier le type des arguments, mais plutôt pour permettre de créer des fonctions dont la syntaxe soit proche de celle des built-ins.

  • Méthode 2, exemple 2

Voici un autre exemple qui implémente toujours la méthode 2 sans utiliser les prototypes et la syntaxe proche de celle des built-ins. Mais gardez toujours en tête que cette méthode est intéressante quand il y a plusieurs modifications à faire dans le fichier et qu'en plus, que l'on ne sache pas forcément les lignes à modifier.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
#!/usr/bin/perl 
use strict; 
use warnings; 
use File::Temp; 
  
# creation du fichier temporaire 
my ($fh_temp, $file_temp)  
    = tempfile( "fichier_temporaireXXXX", UNLINK => 1); 
  
# Ouverture du fichier à modifier        
open (my $fh, '<', $file) or die "Can't open $file : $!\n"; 
  
# declaration d'un compteur 
my $compteur = 0; 
  
# Lecture du fichier ligne à ligne 
while(my $ligne = <$fh>) { 
  $compteur ++; 
  chomp ($ligne); 
  # modification de la ligne 
  if ($compteur == 3) { 
    $ligne = $ligne.", et Bob était là."; 
  } 
  # ecriture dans le fichier temporaire 
  print {$fh_temp} "$ligne\n"; 
} 
close($fh_temp); 
close($fh); 
  
# copie du fichier temporaire 
rename($file_temp,$file);
  • Méthode 3

La méthode 3 est relativement peu intéressante, sinon à titre pédagogique, ou dans le cas d'enregistrements de taille fixe (on peut dans ce cas ouvrir le fichier en lecture-écriture et modifier directement les enregistrements sans problème de décalage puisqu'ils ne changent jamais de taille, il faut alors savoir se servir de seek() et tell()). Je ne couvrirai donc pas la méthode 3 avec un exemple, n'hésitez pas si vous avez envie d'en apporter un.

  • Méthode 4

Voici donc un exemple utilisant la méthode 4, avec Tie::File, le faire manuellement est assez inutile. L'effet sur le fichier est toujours le même que dans les exemples précédents : rajouter ", et Bob était là." à la fin de la troisième ligne.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
#!/usr/bin/perl 
use strict; 
use warnings; 
  
use Tie::File; 
  
my $filename = shift; 
  
# @lines représente maintenant les lignes du fichier 
# $object est l'objet de classe Tie::File sous-jacent 
# sur lequel on peut appeler les méthodes de Tie::File 
my $object = tie my (@lines), 'Tie::File', $filename 
  or die "We couldn't tie $filename to an array in readwrite mode : $!\n"; 
  
$lines[2] .= ', et Bob était là.'; 
  
# ces deux lignes (undef et untie) sont l'équivalent d'un close() 
# dans notre cas 
undef $object; 
# cette ligne suffit si on n'a pas récupéré $object (par exemple 
# dans ce script on aurait pu s'en passer) 
untie @lines; 
  
__END__
Version courte débarrassée des bouts inutiles :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
#!/usr/bin/perl 
use strict; 
use warnings; 
  
use Tie::File; 
  
my $filename = shift; 
  
tie my (@lines), 'Tie::File', $filename 
  or die "We couldn't tie $filename to an array in readwrite mode : $!\n"; 
$lines[2] .= ', et Bob était là.'; 
__END__
Comme vous le voyez c'est assez élégant. Comme en plus c'est très efficace (si vous l'utilisez correctement), c'est une solution intéressante. Tie::File est distribué en standard avec Perl depuis la 5.8 mais le module en lui-même est compatible jusqu'à la 5.4.

Mis à jour le 27 juillet 2007 djibril Jedai

  • Pour vous éviter quelques petits soucis!!

Vous travaillez sous MAC OS X, vous développez, je peux donc supposer que vous utilisez le Terminal, qui est un système Unix!
Voilà donc un des petits soucis que j'ai rencontré, et que je voudrai vous épargner.

Remarque : Sachez que ces soucis de caractères ^M peuvent intervenir lorsque vous passez d'un système Windows à Linux.

Je parsais un fichier ".txt" généré à partir d'Excel Microsoft (pour ne pas le nommer) avec un script Perl. Seulement voilà,
le système ne reconnaissait pas les lignes : le retour chariot était remplacé par un caractère ^M. Autant vous dire que mon petit script était alors totalement inefficace!! Et pourquoi?
Parce que le codage de fin de ligne diffère selon le système utilisé! Les éditeurs de texte qui ne supportent pas les retours chariots affichent ce ^M superflu!
Voilà une petite méthode pour s'en débarrasser! Ajouter cette procédure à tous vos scripts, et vous n'aurez plus de problème d'incompatibilité de fichiers Unix/Windows!

  • Procédure en question!!

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
#!/usr/bin/perl 
use warnings; 
use strict; 
use Carp; 
  
# declaration des fichiers 
# mon fichier à traiter 
my $fichier_initial = "mon_fichier.txt"; 
# le fichier modifie que je cree 
my $fichier_modifie = "fichier_modifie.txt"; 
  
# appel de la procedure: - en entree: mon fichier à traiter 
#- en sortie: mon fichier modifie 
traite_fichier($fichier_initial, $fichier_modifie); 
  
# procedure qui permet de rendre les fichiers compatibles unix/windows 
sub traite_fichier { 
  # passage des parametres $fichier <- $fichier_initial 
  #$fichier_modif <- $fichier_modifie 
  my ($fichier, $fichier_modif) = @_; 
  
  # lecture du fichier initial 
  open ( my $FhLecture, '<', $fichier) || die ("pb d'ouverture du fichier $fichier $! ");  
  # ecriture du fichier modifie 
  open ( my $FhEcriture, '>', $fichier_modif) || die ("pb d'ecriture dans le fichier $fichier_modif $! "); 
  while (my $ligne = <$FhLecture>){ 
    # remplacement des retours chariots! 
    $ligne =~ s/\r\n?/\n/g; 
    print {$FhEcriture} $case; 
  } 
  close ($FhLecture); 
  close ($FhEcriture); 
}
  • Idem en une seule ligne de commande

Il est possible de résoudre ce problème de compatibilité en une seule ligne de commande.

Code perl : Sélectionner tout
perl -pi.bak -e "s/\r\n/\n/" toto.txt
Cette ligne de commande supprimera les ^M d'un fichier et de plus, le fait d'écrire -pi.bak créera une sauvegarde du fichier en toto.bak. vous aurez donc toto.txt modifié et toto.bak équivalement à l'ancien toto.txt.

Pour ne pas faire de sauvegarde, il faudra écrire

Code perl : Sélectionner tout
perl -pi -e "s/\r\n/\n/" toto.txt

Mis à jour le 6 décembre 2008 djibril stoyak

Si vous souhaitez transposer un fichier tabulé, c'est à dire que les lignes de votre fichier deviennent des colonnes, voici une procédure qui peut vous aider.

Entete1 Entete2 Entete3
L1Col1 L1Col2 L1Col3
L2Col1 L2Col2 L2Col3
L3Col1 L3Col2 L3Col3
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
#!/usr/bin/perl 
use strict; 
use warnings; 
  
TransposerFichier('tabule.txt','transpose.txt'); 
  
#============================================ 
# TransposerFichier 
# Transposer un fichier tabule 
#============================================ 
sub TransposerFichier { 
  my ( $FichierTabuleOriginal, $FichierTranspose ) = @_; 
  
  my %HashTranspose; 
  
  # Lecture du fichier tabule 
  open( my $FH, '<', $FichierTabuleOriginal )  
    or die("Impossible de lire le fichier $FichierTabuleOriginal\n"); 
  
  while ( my $Line = <$FH> ) { 
    chomp $Line; 
    my @data = split( /\t/, $Line ); 
    for ( my $i = 0; $i < scalar(@data); $i++ ) { 
      $HashTranspose{$i} .= $data[$i] . "\t"; 
    } 
  } 
  close($FH); 
  
  # Création du fichier transpose 
  open( my $FHTranpose, '>', $FichierTranspose )  
    or die("Impossible de creer le fichier $FichierTranspose\n"); 
  
  foreach ( sort { $a <=> $b } keys %HashTranspose ) { 
    $HashTranspose{$_} =~ s{\t$}{}; 
    print {$FHTranpose} "$HashTranspose{$_}\n"; 
  } 
  close($FHTranpose); 
  
  return $FichierTranspose; 
}
Entete1 L1Col1 L2Col1 L3Col1
Entete2 L1Col2 L2Col2 L3Col2
Entete3 L1Col3 L2Col3 L3Col3

Mis à jour le 15 juin 2009 djibril

Le code ci-dessous permet de convertir un fichier excel 2007 (ou antérieur) en fichier txt, csv ou autre fichier plat.

Le choix du séparateur est laissé à l'utilisateur.
Si l'on on précise un répertoire, le fichier convertit sera créé dans ce dernier, sinon, il sera créé dans le même répertoire que le fichier excel.
On peut choisir de convertir toutes les feuilles ou non du fichier excel en mettant -feuilles à 1 => tout sera convertit, ou à 0 et dans ce cas, à chaque feuille une confirmation sera demandée.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
#!/usr/bin/perl 
use warnings; 
use strict; 
  
my %Arguments = ( 
  -fichier    => "/chemin/vers/fichier.xls",    # notre fichier excel 
  -type       => "csv",                         # ou txt, ou autre 
  -separateur => ";",                           # ou "\t" , "|", ... au choix 
  -repertoire => "/autre/repertoire",           # par defaut, repertoire fichier.xls 
  -feuilles   => 1,                             # ou 0 => demande confirmation 
); 
my $fichier = ExcelToCsvTxt( \%Arguments ); 
  
#============================================================================ 
# But       : Convertit un fichier excel en txt, csv ou autre fichier plat 
# Arguement : Une référence de hash 
# Retourne  : fichier txt ou csv 
# Necessite : Spreadsheet::ParseExcel, Spreadsheet::XLSX et File::Basename 
#============================================================================ 
sub ExcelToCsvTxt { 
  my $RefArgument = shift; 
  
  my $FichierXls = $RefArgument->{-fichier}; 
  my $Type       = $RefArgument->{-type}; 
  my $Repertoire = $RefArgument->{-repertoire}; 
  my $Separateur = $RefArgument->{-separateur}; 
  my $feuilles   = $RefArgument->{-feuilles}; 
  $feuilles = 1 unless defined $feuilles; 
  
  # vérification du fichier 
  unless ( defined $FichierXls and $FichierXls =~ /\.xlsx?$/i ) { 
    die <<'USAGE'; 
        my %Arguments = ( 
          -fichier    => "/chemin/vers/fichier.xls",    # notre fichier excel 
          -type       => "csv",                         # ou txt, ou autre 
          -separateur => ";",                           # ou "\t" , "|", ... au choix 
          -repertoire => "/autre/repertoire",           # par defaut, repertoire fichier.xls 
          -feuilles   => 1,                             # ou 0 => demande confirmation 
        ); 
        my $fichier = ExcelToCsvTxt( \%Arguments ); 
  
USAGE 
  } 
  
  # vérification du type de conversion voulu 
  unless ( defined $Type and $Type =~ m{^csv|txt$}i ) { 
    $Type = 'txt'; 
  } 
  
  require File::Basename; 
  
  # vérification du type de conversion voulu 
  unless ( defined $Repertoire and -d $Repertoire ) { 
    $Repertoire = File::Basename::dirname($FichierXls); 
  } 
  
  # Nouveau fichier 
  my (@FileParse) = File::Basename::fileparse( $FichierXls, qr/\.[^.]*/ ); 
  my $FichierTxtCsv = $Repertoire . '/' . $FileParse[0] . ".$Type"; 
  
  # On verifie si c'est un fichier excel version 2007 ou plus ancien 
  my $ExcelObj; 
  if ( $FichierXls =~ m{\.xls$}i ) { 
    require Spreadsheet::ParseExcel; 
    $ExcelObj = Spreadsheet::ParseExcel::Workbook->Parse($FichierXls) 
      or die("Impossible de lire le fichier $FichierXls\n"); 
  } 
  else { 
    require Spreadsheet::XLSX; 
    $ExcelObj = Spreadsheet::XLSX->new($FichierXls) 
      or die("Impossible de lire le fichier $FichierXls\n"); 
  } 
  
  # Nombre de feuilles dans le fichier excel 
  my $NbrFeuilles = scalar @{ $ExcelObj->{Worksheet} }; 
  
  # Création du fichier final 
  open( my $fh, '>', $FichierTxtCsv ) 
    or die "impossible de ceer le fichier $FichierTxtCsv\n"; 
  
  my ( $iR, $iC, $ObjetFeuille, $oWkC ); 
  
  foreach my $ObjetFeuille ( @{ $ExcelObj->{Worksheet} } ) { 
  
    if ( $NbrFeuilles > 1 and $feuilles != 1 ) { 
      print "Voulez vous convertir l'onglet '$ObjetFeuille->{Name}' [Y/n] : "; 
      chomp( my $Reponse = <STDIN> ); 
      print "\n"; 
      next if ( defined $Reponse and uc($Reponse) eq 'N' ); 
    } 
  
    # Parcours des lignes 
    for ( 
      my $iR = $ObjetFeuille->{MinRow}; 
      defined $ObjetFeuille->{MaxRow} && $iR <= $ObjetFeuille->{MaxRow}; 
      $iR++ 
      ) 
    { 
  
      # Parcours des colonnes 
      for ( 
        my $iC = $ObjetFeuille->{MinCol}; 
        defined $ObjetFeuille->{MaxCol} && $iC <= $ObjetFeuille->{MaxCol}; 
        $iC++ 
        ) 
      { 
        $oWkC = $ObjetFeuille->{Cells}[$iR][$iC]; 
        if ( defined $oWkC ) { 
          print {$fh} $oWkC->Value, $Separateur; 
        } 
        else { 
          print {$fh} $Separateur; 
        } 
      } 
      print {$fh} "\n"; 
    } 
  } 
  close($fh); 
  
  return $FichierTxtCsv; 
}
Nous avons utilisé ici la méthode Value pour récupérer la valeur de la case

Code perl : Sélectionner tout
print {$fh} $oWkC->Value, $Separateur;
Mais cette méthode peut nous générer des erreurs inattendues :

Code : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
value() 
 
The value() method returns the formatted value of the cell. 
 
    my $value = $cell->value(); 
 
Formatted in this sense refers to the numeric format of the cell value.  
For example a number such as 40177 might be formatted as 40,117, 40117.000 or even as the date 2009/12/30. 
 
If the cell doesn't contain a numeric format then the formatted and unformatted  
cell values are the same, see the unformatted() method below. 
 
For a defined $cell the value() method will always return a value. 
 
In the case of a cell with formatting but no numeric or string contents  
the method will return the empty string ''.
Pour éviter tout souci, utilisez plutôt la méthode unformatted.

Code perl : Sélectionner tout
print {$fh} $oWkC->unformatted, $Separateur;

Mis à jour le 15 juin 2009 djibril

Ce code vous permettra de fusionner plusieurs classeur Excel (xls, xlsx) en un unique fichier Excel (xls). Il copie toutes les feuilles des différents classeurs dans un seul fichier. Le seul inconvénient est qu'il ne garde pas les noms des feuilles mais en génère automatiquement (feuille1, 2, 3, ...) et les formats des cellules ne sont pas conservés.

Vous aurez besoin d'installer les modules


Les modules Getopt::Long et Pod::Usage sont dans le core de Perl.

Pour savoir comment lancer le programme, faites

Code : Sélectionner tout
perl nom_programme.pl -help
ou

Code : Sélectionner tout
perl nom_programme.pl -man
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
#!/usr/bin/perl 
#=============================================================================== 
# Author :  djibril 
# Date   :  23/02/2011 10:24:10 
# Main   :  Fusionner plusieurs classeurs Excel d'un répertoire en un unique fichier 
#=============================================================================== 
use Carp; 
use strict; 
use warnings; 
  
use Spreadsheet::ParseExcel; 
use Spreadsheet::XLSX; 
use Spreadsheet::WriteExcel; 
use Getopt::Long; 
use Pod::Usage; 
  
my ( $repertoire_excel, $fichier_excel_fusionne ) = (); 
my ( $man, $help ) = ( 0, 0 ); 
  
GetOptions( 
  'repertoire|d=s' => \$repertoire_excel, 
  'output|o=s'     => \$fichier_excel_fusionne, 
  'help|?'         => \$help, 
  'man'            => \$man 
) or pod2usage(2); 
  
pod2usage( -exitstatus => 0, -verbose => 2 ) if ( $man || $help ); 
if ( ( !defined $repertoire_excel or !defined $fichier_excel_fusionne ) ) { 
  pod2usage( { -verbose => 1, -output => \*STDERR } ); 
} 
  
# Lister les fichiers excel d'un répertoire et de ses sous répertoires 
my @fichiers_excel = lister_fichiers($repertoire_excel); 
  
fusionner_fichiers_excel( \@fichiers_excel, $fichier_excel_fusionne ); 
  
# Procédure de fusion excel 
sub fusionner_fichiers_excel { 
  my ( $ref_fichiers_excel, $fichier_excel_final ) = @_; 
  
  print "Creation de $fichier_excel_fusionne\n"; 
  
  # Liste des fichiers excel à fusionner 
  my @les_fichiers_excel = @{$ref_fichiers_excel}; 
  
  # Creation du classeur Excel 
  my $workbook_final = Spreadsheet::WriteExcel->new($fichier_excel_final); 
  
  foreach my $fichier_excel (@les_fichiers_excel) { 
    next unless ( $fichier_excel =~ m{\.xlsx?$}i ); 
  
    # Lecture du fichier Excel 
    print "Lecture du fichier $fichier_excel\n"; 
    my $workbook; 
    if ( $fichier_excel =~ m{\.xls$} ) { 
      my $parser = Spreadsheet::ParseExcel->new(); 
      $workbook = $parser->parse($fichier_excel); 
    } 
    else { 
      $workbook = Spreadsheet::XLSX->new($fichier_excel); 
    } 
  
    if ( !defined $workbook ) { die "Erreur de lecture du fichier $fichier_excel : "; } 
  
    for my $worksheet ( $workbook->worksheets() ) { 
      my ( $row_min, $row_max ) = $worksheet->row_range(); 
      my ( $col_min, $col_max ) = $worksheet->col_range(); 
      next if ( $row_max == 0 and $col_max == 0 ); 
  
      # Création de la feuille 
      my $worksheet_final = $workbook_final->add_worksheet(); 
  
      for my $row ( $row_min .. $row_max ) { 
        for my $col ( $col_min .. $col_max ) { 
  
          my $cell = $worksheet->get_cell( $row, $col ); 
          next unless $cell; 
          $worksheet_final->write( $row, $col, $cell->unformatted() ); 
        } 
      } 
    } 
    print "\n"; 
  
  } 
  $workbook_final->close(); 
  
  return; 
} 
  
#====================================================== 
# Nombre d'arguments : 1 
# Argument(s)        : un répertoire ($repertoire) 
# Retourne           : Tableau de fichier (@fichiers) 
#====================================================== 
sub lister_fichiers { 
  my ($repertoire) = @_; 
  my @fichiers; 
  
  # Ouverture d'un répertoire 
  opendir( my $fh_rep, $repertoire ) 
    or die "impossible d'ouvrir le répertoire $repertoire\n"; 
  
  # Liste fichiers et répertoire sauf (. et ..) 
  my @Contenu = grep { !/^\.\.?$/ } readdir($fh_rep); 
  
  # Fermeture du répertoire 
  closedir($fh_rep); 
  
  # On récupère tous les fichiers 
  foreach my $nom (@Contenu) { 
  
    # Fichiers 
    if ( -f "$repertoire/$nom" ) { 
      push( @fichiers, "$repertoire/$nom" ); 
    } 
  
    # Repertoires 
    elsif ( -d "$repertoire/$nom" ) { 
  
      # recursivité 
      push( @fichiers, lister_fichiers("$repertoire/$nom") ); 
    } 
  } 
  
  return @fichiers; 
} 
  
__END__ 
  
=head1 NAME 
  
    Ce programme permet de fusionner plusieurs classeurs excel (xls et xslx) d'un repertoire en un fichier Excel (xlsx) 
  
    Il copie toutes les feuilles des differents classeurs dans un seul fichier. Le seul inconvenient est qu'il ne garde  
    pas les noms des feuilles mais en genere automatiquement (feuille1, 2, 3, ...) et les formats des cellules ne sont  
    pas conserves, uniquement le contenu des cellules. 
  
=head1 SYNOPSIS 
  
  perl programme_perl.pl -d "C:/REPERTOIRE/EXCEL" -o "fichier_excel_fusionne.xls"

Mis à jour le 23 février 2011 djibril

Voici un script permettant de lister des fichiers textes dans un répertoire et de comparer leur dernière date de modification. Si les dates sont vieilles au minimum d'un mois, les fichiers sont supprimés.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#! /usr/bin/perl 
use strict; 
use warnings; 
use POSIX 'strftime'; 
use DateTime; 
  
my ( @infos, %hash, $date, @monthoffile ); 
  
## Affiche la date du jour au format YYYY-MM-DDJHH-MM-SS 
my $mydate = DateTime->now(); 
my @month = split( '-', $mydate ); 
  
##### Liste les fichiers ayant l'extension .txt 
my @list = glob("/dossier/sousdossier/*.txt"); 
  
### recupere le nombre de fichier 
my $numberoffile = scalar(@list); 
  
for ( my $v = 0; $v < $numberoffile; $v++ ) { 
  @infos = stat( $list[$v] );                              ### recupere les informations du fichier en seconde 
  $date = strftime( "%Y-%m-%d", localtime( $infos[9] ) );  #### format l'information du fichier 
  @monthoffile = split( '-', $date );                      #### recupere le mois de la date 
  if ( $month[1] != $monthoffile[1] ) { 
    ### verifie si le mois de creation du fichier est different de celui en cours 
    print $list[$v] . "\n fichier supprime\n"; 
    unlink $list[$v];                                      ### supprime le fichier 
  } 
}

Mis à jour le 5 juin 2014 grab76

Vous souhaitez lancer un programme qui vous supprime les fichiers d'un ou plusieurs répertoires. Vos critères de suppression sont la date des fichiers, notamment les fichiers vieux de plus de X jours. Le programme ci-dessous vous permettra de supprimer dans les répertoires de votre choix tous les fichiers vieux de plus de X jours. Vous avez la possibilité de donner une regex pour cibler vos fichiers.

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
#! /usr/bin/perl  
#=============================================================================== 
# Auteur : djibril 
# But    : Supprimer les fichiers en fonction de certains critères 
# - fichiers vieux de plus de X jours 
# - dans certains répertoires à donner en arguments 
# - vous pouvez donner une regex pour cibler les fichiers 
#=============================================================================== 
use strict; 
use warnings; 
use English '-no_match_vars'; 
use Getopt::Long; 
  
my $USAGE = <<"USAGE"; 
  perl $PROGRAM_NAME -d '/chemin/vers/repertoire1' -d '/chemin/vers/repertoire2' -j X   
    -d : permet de spécifier un répertoire ou plusieurs répertoires.  
    -j : donner le nombre de jours à partir duquel les fichiers sont supprimés  
    -p : expression régulière (utile pour matcher des extensions)  
    -r : récursivité  
USAGE 
  
# Récupération des arguments 
my ( @repertoires, $nombre_jours, $regex, $recursivite ) = (); 
GetOptions( 
	'd=s' => \@repertoires, 
	'j=i' => \$nombre_jours, 
	'p=s' => \$regex, 
	'r'   => \$recursivite, 
); 
  
my $time            = time; 
my $seconde_journee = 24 * 3600; 
if ( not defined $nombre_jours or scalar(@repertoires) == 0 ) { 
	print "Options manquantes\n\n$USAGE"; 
	exit; 
} 
if ( not defined $regex ) { $regex = '.'; } 
  
print "Suppression fichiers de plus de $nombre_jours jours\n"; 
foreach my $fichier ( map { lister_fichiers( $_, $recursivite ) } @repertoires ) { 
	my $mtime = ( stat($fichier) )[9]; 
	my $differences_jours = int( ( time - $mtime ) / $seconde_journee ); 
	if ( ( $differences_jours > $nombre_jours ) and ( $fichier =~ m/$regex/ ) ) { 
		print "- $fichier [$differences_jours jours]\n"; 
		unlink $fichier or print "Impossible de supprimer $fichier : $!\n"; 
	} 
} 
  
sub lister_fichiers { 
	my ( $repertoire, $recursivite ) = @_; 
  
	require Cwd; 
	require File::Spec; 
  
	my $cwd = Cwd::getcwd(); 
  
	# Recherche dans les sous répertoire ou non 
	if ( ( not defined $recursivite ) || ( $recursivite != 1 ) ) { $recursivite = 0; } 
  
	# Verification répertoire 
	if ( not defined $repertoire ) { die "Aucun repertoire de specifie\n"; } 
  
	# Ouverture d'un répertoire 
	opendir my $fh_rep, $repertoire or die "impossible d'ouvrir le répertoire $repertoire\n"; 
  
	# Liste fichiers et répertoire sauf (. et ..) 
	my @fic_rep = grep { !/^\.\.?$/ } readdir $fh_rep; 
  
	# Fermeture du répertoire 
	closedir $fh_rep or die "Impossible de fermer le répertoire $repertoire\n"; 
  
	chdir $repertoire; 
	$repertoire = Cwd::getcwd(); 
  
	# On récupère tous les fichiers 
	my @fichiers; 
	foreach my $nom (@fic_rep) { 
		my $notre_ficrephier = File::Spec->catfile( $repertoire, $nom ); 
  
		if ( -f $notre_ficrephier ) { 
			push( @fichiers, $notre_ficrephier ); 
		} 
		elsif ( -d $notre_ficrephier and $recursivite == 1 ) { 
			push( @fichiers, lister_fichiers( $notre_ficrephier, $recursivite ) );    # recursivité 
		} 
	} 
  
	chdir $cwd; 
  
	return @fichiers; 
}
Pour lancer ce programme, voici la commande :

Code : Sélectionner tout
1
2
3
4
5
  perl $PROGRAM_NAME -d '/chemin/vers/repertoire1' -d '/chemin/vers/repertoire2' -j X   
    -d : permet de spécifier un répertoire ou plusieurs répertoires.  
    -j : donner le nombre de jours à partir duquel les fichiers sont supprimés  
    -p : expression régulière (utile pour matcher des extensions)  
    -r : récursivité
Pour supprimer des répertoires C:\logs et C:\data\logs tous les fichiers .txt vieux de plus de 2 mois, on lancera le programme de la sorte :

Code : Sélectionner tout
perl test.pl -d "C:\logs" -d "C:\data\logs" -j 60 -p "\.txt$"
L'expression régulière de l'option permet de dire au programme que le nom des fichiers doivent se terminer par ".txt". L'utilisation de cette option -p est facultative.

Mis à jour le 20 février 2015 djibril

Sous Windows, lorsque nous travaillons sur des fichiers, nous avons souvent besoin de lister, créer des fichiers dont des fichiers raccourcis « .lnk ». Ce sont des raccourcis Windows.

Comme à son habitude, Perl dispose à travers la multitude de modules d'une solution toute faite simple à utiliser pour lire un raccourci (trouver le fichier cible) ou en créer.

Le module Win32::Shortcut réalise ces tâches sans difficulté. Voici deux exemples :

Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
#!/usr/bin/perl 
use strict; 
use warnings; 
use Win32::Shortcut; 
  
# Trouvons le fichier cible de notre raccourci .lnk 
my $fichier_raccourci = 'C:\Users\Public\Desktop\CCleaner.lnk'; 
my $lien_win32        = Win32::Shortcut->new(); 
$lien_win32->Load($fichier_raccourci); 
print "Raccourci : $fichier_raccourci\n"; 
print "Cible : ", $lien_win32->{'Path'}, "\n"; 
$lien_win32->Close();
Code perl : Sélectionner tout
1
2
3
4
5
6
7
8
9
10
11
12
13
#!/usr/bin/perl 
use strict; 
use warnings; 
use Win32::Shortcut; 
  
# Création d'un raccourci .lnk à partir d'un fichier quelconque 
my $fichier    = 'C:\DVP\Article_Dvp\script\Perl\zippage.pl'; 
my $lien_win32 = Win32::Shortcut->new(); 
$lien_win32->{'Path'}             = $fichier; 
$lien_win32->{'Description'}      = 'Mon programme Perl'; 
$lien_win32->{'WorkingDirectory'} = 'C:\Users\Public\Desktop'; 
$lien_win32->Save('RaccourciPerl.lnk'); 
$lien_win32->Close();
Pas besoin de plus d'explications, pour plus d'informations sur le module, lisez la documentation de ce dernier.

Mis à jour le 19 février 2013 djibril

Proposer une nouvelle réponse sur la FAQ

Ce n'est pas l'endroit pour poser des questions, allez plutôt sur le forum de la rubrique pour ça


Réponse à la question

Liens sous la question
précédent sommaire suivant
 

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2017 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.

 
Responsable bénévole de la rubrique Perl : djibril -