Forum |  HardWare.fr | News | Articles | PC | S'identifier | S'inscrire | Shop Recherche
1247 connectés 

  FORUM HardWare.fr
  Programmation
  Perl

  Suppression d'ancien fichier en PERL

 


 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

Suppression d'ancien fichier en PERL

n°1940821
Sethenssen
Posté le 14-11-2009 à 20:26:05  profilanswer
 

Bonjour,
 
Cette commande shell:
find $TMP_DIR -mtime +7 -exec rm -f {} \;
 
Permet de supprimer tous les fichiers dont la date de créa/modif est supérieur à 7 jours.
 
Je voudrais simplement savoir si une personne peut me dire quel est son équivalence/traduction en langage PERL.
 
Merci d'avance,
++

Message cité 1 fois
Message édité par Sethenssen le 15-11-2009 à 20:38:16
mood
Publicité
Posté le 14-11-2009 à 20:26:05  profilanswer
 

n°1940827
ccp6128
Syntax error
Posté le 14-11-2009 à 22:12:32  profilanswer
 

Salut,
 
Pour réaliser la même chose que cette commande en perl, deux choix :
 
Lister les fichiers d'un répertoire, faire un stat pour récupérer leurs propriétés (dont la date de création modif), comparer leur date avec la date courante, puis unlinker le fichier s'il correspond aux critères.
 
Plus simplement tu peux aussi utiliser un module dédié genre File::Find ou File::Find::Rule.

n°1940849
gilou
Modérateur
Modzilla
Posté le 15-11-2009 à 11:17:13  profilanswer
 

Sethenssen a écrit :

Bonjour,
 
Cette commande shell:
find $TMP_DIR -mtime +7 -exec rm -f {} \;
 
Permet de supprimer tous les fichiers dont la date de créa/modif est supérieur à 7 jours.
 
Je voudrais simplement savoir si une personne peut me dire quel est son équivalence/traduction en langage PERL.
 
Merci d'avance,
++


Le truc rapide quand on veut faire executer une commande shell et en récupérer le résultat:
my $cmd = "find $TMP_DIR -mtime +7";  (ou bien, my $cmd = "find $TMP_DIR -mtime +7 -print"; si la précédente ne suffit pas)
my @files = qx{$cmd};  
unlink @files;
 
ca peut probablement se faire en une ligne ainsi:
unlink qx{"find $TMP_DIR -mtime +7"};  
mais c'est a tester.
 
Le seul désavantage, c'est qu'on execute un shell externe au lieu de tout faire depuis perl, et que ça va impacter légèrement sur les performances.
 
Le plus propre, c'est d'utiliser le module File::Find, et l'utilitaire find2perl ( http://search.cpan.org/~dapm/perl- [...] nd2perl.PL ) qui transforme une commande find en une procédure perl appellée comme premier argument du find de File::Find
 
si je fais (sur mon pc, sous windows, d'ou le C:\Perl\bin\perl.exe -w)  
find2perl $TMP_DIR -mtime +7 -exec rm -f {} \;
ça me génère le script perl correspondant:
 

Code :
  1. #! C:\Perl\bin\perl.exe -w
  2.    eval 'exec C:\Perl\bin\perl.exe -S $0 ${1+"$@"}'
  3.        if 0; #$running_under_some_shell
  4.  
  5. use strict;
  6. use File::Find ();
  7.  
  8. # Set the variable $File::Find::dont_use_nlink if you're using AFS,
  9. # since AFS cheats.
  10.  
  11. # for the convenience of &wanted calls, including -eval statements:
  12. use vars qw/*name *dir *prune/;
  13. *name   = *File::Find::name;
  14. *dir    = *File::Find::dir;
  15. *prune  = *File::Find::prune;
  16.  
  17. sub wanted;
  18. sub doexec ($@);
  19.  
  20.  
  21. use Cwd ();
  22. my $cwd = Cwd::cwd();
  23.  
  24.  
  25. # Traverse desired filesystems
  26. File::Find::find({wanted => \&wanted}, '$TMP_DIR');
  27.  
  28.  
  29. sub wanted {
  30.    my ($dev,$ino,$mode,$nlink,$uid,$gid);
  31.  
  32.    (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  33.    (int(-M _) > 7) &&
  34.    doexec(0, 'rm','-f','{}','\;');
  35. }
  36.  
  37.  
  38. sub doexec ($@) {
  39.    my $ok = shift;
  40.    my @command = @_; # copy so we don't try to s/// aliases to constants
  41.    for my $word (@command)
  42.        { $word =~ s#{}#$name#g }
  43.    if ($ok) {
  44.        my $old = select(STDOUT);
  45.        $| = 1;
  46.        print "@command";
  47.        select($old);
  48.        return 0 unless <STDIN> =~ /^y/;
  49.    }
  50.    chdir $cwd; #sigh
  51.    system @command;
  52.    chdir $File::Find::dir;
  53.    return !$?;
  54. }


 
Bon après, on peut adapter, afin d'intégrer ça a son propre code.
Typiquement, je virerais l'exec avant le use strict, et les alias avec des globales *name, *dir et *prune à priori.
 
En plus, le code de find2perl est assez ancien, je ne suis pas sur qu'il marche encore bien (File::Find::find n'accepte pas '$TMP_DIR' avec ma version, il faut le mettre dans un array ($TMP_DIR)).
 
Bon en élaguant, on voit que grosso modo, le script peut se réduire à:
 

Code :
  1. #!/usr/bin/perl -w
  2. use strict;
  3. use warnings;
  4.  
  5. use File::Find;
  6.  
  7. # Traverse desired filesystems
  8. my $TMP_DIR = 'C:\Downloads';  #a remplacer par la valeur voulue dans son script
  9. File::Find::find(\&wanted, ($TMP_DIR));
  10.  
  11. sub wanted {
  12.    unlink $_ if (-f && (int(-M _) > 7));
  13. }


 
Ce qui veut dire que si on veut intégrer ça dans un script, il suffit d'ajouter
use File::Find;
en tête de script avec les autres use, et ($TMP_DIR étant alors défini)
File::Find::find(\&deleteOldFiles, ($TMP_DIR));
La ou on veut que l' action soit effectuée dans son script,  
ainsi que la subroutine
sub deleteOldFiles {
    unlink $_ if (-f && (int(-M _) > 7));
}
la ou on ajoute les subroutines (en fin de script, après le corps principal du script chez moi, mais ça pourrait être aussi en tête de script, avant le corps principal du script, c'est une question de style)
Bref :

Code :
  1. .....................
  2. use File::Find;
  3. .....................
  4. File::Find::find(\&deleteOldFiles, ($TMP_DIR));
  5. .....................
  6. sub deleteOldFiles {
  7.    unlink $_ if (-f && (int(-M _) > 7));
  8. }
  9. .....................


Note pédagogique:
if (-f && (int(-M _) > 7));  
c'est un idiome perl pour noter
if (-f $_ && (int(-M $_) > 7));  
le premier $_ est omis car c'est la valeur par défaut,  
et le _ devant le -M indique qu'on reprend le même argument que pour l'opérateur précédent de test de fichier (le -f ici).
 
Ca marche aussi probablement (j'ai pas testé) en virant le $_ devant le unlink, car c'est la valeur par défaut, mais c'est à réserver à ceux qui aiment vivre dangereusement.
 
Bon, une dernière réduction, utilisant les subroutines anonymes:

Code :
  1. .....................
  2. use File::Find;
  3. .....................
  4. File::Find::find({wanted => sub {unlink $_ if (-f && (int(-M _) > 7))}}, ($TMP_DIR));
  5. .....................


A+,


Message édité par gilou le 15-11-2009 à 12:38:02

---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°1940928
Sethenssen
Posté le 15-11-2009 à 20:20:07  profilanswer
 

Excellent !
Merci beaucoup Gilou ça marche impec.
 
Ô Capitaine, mon capitaine  :jap:

n°1940953
gilou
Modérateur
Modzilla
Posté le 15-11-2009 à 21:29:57  profilanswer
 

Notes que je lui ai fait supprimer que les fichiers [le test if (-f ], pas les répertoires. Si tu as besoin de supprimer les répertoires, le mieux a mon avis est de faire d'abord la suppression des fichiers, puis de faire celle des répertoires, lorsqu'ils sont devenus vide et ont plus de 7 jours (ou tout autre critère te convenant)
A+,


---------------
There's more than what can be linked! --    Iyashikei Anime Forever!    --  AngularJS c'est un framework d'engulé!  --
n°2024446
the Z
Posté le 22-09-2010 à 12:13:08  profilanswer
 

Bonjour
 
 Merci Gilou
 Correspond à ce que je recherchais.  


Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  Perl

  Suppression d'ancien fichier en PERL

 

Sujets relatifs
[résolu][PHP/XML] lecture de fichier XML en PHPImporter des données d'un fichier HTML dans Excel
Copie, déplacement, renommage de fichier, etcJAAS & sécuriser fichier de données
Transfert Fichier Texte dans ACCESS depuis vba Excelbatch sftp pour recuperer fichier et envoi mail
sauver fichier complet du presse-papiers sur le disque dur[SQL Server 2000] : fichier de sortie "horodaté" (travail)
[PERL] aide script pour alimenter SGBD MySQLsuppression doublons dans fichier texte
Plus de sujets relatifs à : Suppression d'ancien fichier en PERL


Copyright © 1997-2022 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR