Le but de ce TP est d'étudier la manipulation des fichiers en Perl.

L'élève curieux pourra également se reporter au TP analogue proposé en 2007 par Antoine Miné.

Aide

On rappelle qu'un script script Perl est un fichier texte d'extension .pl, tel toto.pl, qui commence par une ligne précisant l'interpréteur:

#!/usr/bin/perl -W

et qui est rendu exécutable par la commande chmod +x toto.pl. Dans cet exemple, on a forcé l'option -W qui active tous les avertissements paranoïaques de Perl (voir perlrun(1)).

Liens utiles:

top

Exercice 1 - ls -l en Perl

  1. Écrire un script Perl qui affiche le contenu détaillé d'un répertoire passé en argument (i.e. simulant la fonction ls -l) en utilisant la fonction stat.

  2. #!/usr/bin/perl -W
    use File::stat;
    
    sub affiche_info($$)
    {
        ($nom_rep, $nom_fichier) = @_;
    
        $info = stat("$nom_rep/$nom_fichier")
            or warn "Erreur $nom_fichier: $!\n" and return;
    
        $mode   = $info->mode;   
        $perms  = sprintf("%04o", $mode & 07777);
        $util   = $info->uid;    
        $taille = $info->size;
        $groupe = $info->gid;    
        $acces  = localtime($info->atime);  
        $nom    = $nom_fichier;
    
        print "$perms\t$util\t$groupe\t$taille\t$acces\t$nom\t\n";
    }
    
    
    # -------------------------------------------------
    
    
    $nom_rep = scalar(@ARGV) >= 1 ? $ARGV[0]: ".";
    # le repertoire est passe en argument ou 
    # le repertoire courant si il n'y en a pas
    
    opendir(DIR, $nom_rep) or die "Erreur $nom_rep: \n$!";
    print "Droits\tUtil.\tGroupe\tTaille\tDate d'acces\t\t\tNom\n";
    print "-"x100;
    print "\n";
    while (defined($nom_fichier = readdir(DIR)))
    {
        next if $nom_fichier =~ /^\..*/;
        affiche_info($nom_rep, $nom_fichier);
    }
    closedir(DIR);
    
    exit;
    

  3. Modifier votre script pour qu'il affiche les listes de fichiers comme un unique fichier (i.e. les trois fichiers fichier1.txt, fichier2.txt et fichier3.txt devront apparaître comme fichier[1-3].txt).


    (On demande uniquement la liste des fichiers pas les informations supplémentaires - i.e. fonction ls simple).

#!/usr/bin/perl -W

sub formate(@)
{
    my (@nombres) = @_;

    my @inters = ();
    my $bas = undef;
    my $precedent = undef;
    my $inter = undef;
    foreach my $n (sort {$a <=> $b} @nombres)
    {
        if (!defined($precedent) or $n != ($precedent + 1))
        {
            push(@inters, $inter) if defined($inter);
            $bas = $n;
            $inter = "$n";
        }
        else
        {
            $inter = "[$bas-$n]";
        }
        $precedent = $n;
    }

    push(@inters, $inter) if defined($inter);
    return @inters;
}



sub affiche(%)
{
    my (%groupes) = @_;

    foreach my $cle (sort keys %groupes)
    {
        my $groupe = $groupes{$cle};
        my $debut = $groupe->{debut};
        my $fin = $groupe->{fin};
        my $nombres_ref = $groupe->{nombres};

        if ($groupe->{vide})
        {
            print "$debut$fin\n";
        }

        if (defined($nombres_ref))
        {
            my @inters = formate(@$nombres_ref);
            foreach my $inter (@inters)
            {
                print "$debut$inter$fin\n";
            }
        }
    }
}


#################################################
#################################################

my $nom_rep = scalar(@ARGV) >= 1 ? $ARGV[0]: ".";
# le repertoire est passe en argument ou 
# le repertoire courant si il n'y en a pas

my @liste_fichiers = ();
opendir(DIR, $nom_rep) or die "Erreur $nom_rep: $!\n";
while (defined(my $nom_fichier = readdir(DIR)))
{
    next if $nom_fichier =~ /^\.\.?$/;   
    push(@liste_fichiers, $nom_fichier);
}
closedir(DIR);   

# ecrit tous les noms de fichiers de $nom_rep dans
# le tableau liste_fichiers

my %groupes = ();
# une table de hachage avec pour cles les
# noms de fichiers sans les nombres


foreach my $nom (@liste_fichiers)
{
    my ($debut, $fin, $nombre);
    if ($nom =~ /^(.*\D)(\d+)(\D*)$/)
    {
	$debut = $1;
	$nombre = $2;
	$fin = $3;
    }
    else 
    {
	$debut = $nom;
	$fin = "";
    }
    # parse le $nom en debut,nombre,fin
    # fichier1.txt -> debut="fichier", nombre="1", fin=".txt"
    
    my $key = "$debut $fin";
    my $groupe = $groupes{$key};

    
    unless ($groupe)
    {
	my @nombres = ();
	$groupe =
	{
	    debut    => $debut,
	    fin      => $fin,
	    nombres  => \@nombres,
	    vide     => 0,
	};
	$groupes{$key} = $groupe;
    }
    
    if (defined($nombre))
    {
	my $nombres_ref = $groupe->{nombres};
	push(@$nombres_ref, $nombre);
    }
    else
    {
	$groupe->{vide}++;
    }
}


affiche(%groupes);

exit;
top

Exercice 2 - Renommer les fichiers

Écrire un script Perl qui renomme les fichiers d'un répertoire de manière à éviter les collisions dans un système de fichiers qui ne distingue pas les majuscules et les minuscules (comme HFS+ sur OS X).

sub formate($)
{
    my ($nom_fichier) = @_;
    my ($nom, $rep, $ext) = fileparse($nom_fichier, '\..*?');
    $rep = "" if $rep eq "./";
    return ($nom, $rep, $ext);
}

sub propose_nouveau_nom($)
{
    my ($nom_fichier) = @_;

    my ($nom, $rep, $ext) = formate($nom_fichier);
    my $nom_minus = lc($nom);
    my $ext_minus = lc($ext);
    
    my $cpt = "000";
    do
    {
        ++$cpt;
        $nom_prop = "$rep$nom_minus" . "_$cpt" . $ext_minus;
    }
    while (-e $nom_prop);

    return $nom_prop;
}

sub renomme_fichier($)
{
    my ($nom_orig) = @_;

    my $nom_nouv = propose_nouveau_nom($nom_orig);
    die "Erreur \"$nom_nouv\" existe deja\n" if -e $nom_nouv;

    print "Pret à renommer \"$nom_orig\" en \"$nom_nouv\"\n";
    rename($nom_orig, $nom_nouv)
       or die "Erreur \"$nom_orig\" -> \"$nom_nouv\": $!\n";
}


################################################
################################################

my $nom_rep = scalar(@ARGV) >= 1 ? $ARGV[0]: ".";
opendir(DIR, $nom_rep) or die "Erreur $nom_rep: $!";

# le repertoire est passe en argument ou 
# le repertoire courant si il n'y en a pas


my %coll; 

while (defined(my $nom_fichier = readdir(DIR)))
{
    my ($nom, $rep, $ext) = formate($nom_fichier);
    my $nom_minus = lc($nom);
    my $ext_minus = lc($ext);
    
    push(@{$coll{"$rep$nom_minus$ext_minus"}}, $nom_fichier);
}

foreach my $key (keys %coll)
{
    my @nom_fichiers = @{$coll{$key}}; 
    next unless scalar(@nom_fichiers) > 1;
    
    foreach my $nom_fichier (@nom_fichiers)
    {
	renomme_fichier($nom_fichier);
    }
}

exit;
top

Exercice 3 - Effacement de gros fichiers

Écrire un script Perl qui recherche à partir d'un répertoire donné en argument les gros fichiers auxquels nul n'a accédé récemment. Un fichier de configuration contiendra, pour certaines extensions de nom de fichier, des règles spécifiques : ne pas tenir compte de la date de dernier accès, ne pas tenir compte de la taille du fichier, afin d'affiner la recherche des fichiers qu'il faut comprimer. Voici un exemple de fichier de configuration.

#
# regles pour la liste %ext :
#   1: affiche si le fichier est gros
#   2: affiche si le fichier est vieux
#   3: n'affiche jamais
#

%ext = (
  ".tar" => 1 ,
  ".dvi" => 2 ,
  ".aux" => 2 ,
  ".log" => 2 ,
  ".ps"  => 2 ,
  ".tif" => 3 ,
  ".tgz" => 3 ,
  ".gz"  => 3 ,
  ".zip" => 3 ,
  ".lzh" => 3 ,
);
#! /usr/bin/perl

# Valeurs par defaut
$bavard = 0;
$grande_taille = 1048576;
$jadis = time() - 604800;

# Table des extensions de fichiers avec traitement special
%ext = ();

# Table des inodes visites
%visited_inode = ( "dummy_inode" => 0 );


#
# Recherche recursive sur le chemin passe en argument
#
# avec les regles suivantes :
#   ne pas explorer ..
#   ajouter chaque inode visite dans la table %visited_inode
#   et ne pas visiter chaque inode 2 fois
#   s'arreter si le chemin n'existe pas
#   continuer si il y a un lien symbolique
#

sub listerec {
  my( $path ) = @_; # read the argument

  my ($inode,$size, $atime) = (stat($path))[1,7,8];
  unless( defined $inode ) 
  {
      die "$0: $path n'existe pas\n" unless -l $path;
      return;
  }
  return if exists $visited_inode{$inode};
 
  $visited_inode{$inode} = $path;
  if( -d $path ) 
  {
      print "$path\n" if $bavard;
      opendir( ROOT , $path ) || die "$0: cannot open directory $path: $!\n";
      my @dir = sort( readdir( ROOT ));
      closedir( ROOT );
      foreach $file (@dir) 
      {
	  listerec( "$path/$file" ) unless $file eq "..";
      }
  } 
  else 
  {
      $extension = $path;
      $extension =~ s/.*\./\./;
      if (defined ($control = $ext{$extension})) 
      {
	  return if $control == 1 and $size < $grande_taille;
	  return if $control == 2 and $atime > $jadis;
	  return if $control == 3;
      }
      return if $size < $grande_taille or $atime > $jadis;
      $prtsize = $size."B";
      if( $size > 10240 ) 
      {
	  $prtsize = int( $size/1024 )."KB";
	  if( $size > 10485760 ) 
	  {
	      $prtsize = int( $size/1048576 )."MB";
	      if( $size > 10737418240 ) 
	      {
		  $prtsize = int( $size/1073741824 )."GB";
	      }
	  }
      }
      $prttime = localtime( $atime );
      print "${prtsize}\t$prttime\t$path\n";
  }
}


##################################################
##################################################



# execute le fichier .grosfichiersconfig file comme
# un script perl si il existe
$_ = $ENV{"HOME"}."/.grosfichierconfig";
do $_ if -r $_;

# Les options
while( $ARGV[0] =~ /-/ ) {
  ($bavard = 1 , shift) if $ARGV[0] eq "-b";
  $grande_taille = substr( shift , 2 ) if $ARGV[0] =~ /-t\d+/;
  $jadis = time() - substr( shift , 2 ) if $ARGV[0] =~ /-d\d+/;
}

die "Usage: $0 [-b] [-t] [-d]  [ [ fixe la taille en octers (par defaut 1Mo)
  -d fixe la duree sans acces au fichier (par defaut 1 semaine)
" unless( @ARGV );

while( @ARGV ) {
  listerec( shift );
}

exit 0;
top

Exercice 4 - Nettoyage

LaTeX, créé par Leslie Lamport, est un système logiciel de composition de documents. À partir d'un fichier source fichier.tex, un fichier fichier.dvi est créé en exécutant latex fichier.tex.

Si dans un répertoire donné un fichier .dvi est antérieur au fichier .tex correspondant, il est vraissemblable que le premier ne pourra pas être reconstruit à partir du second.

Écrire un script Perl qui supprime (dans un répertoire passé en argument) les fichiers .dvi, .log et .aux uniquement si le fichier .dvi est antérieur au fichier .tex correspondant.

#!/usr/bin/perl
# solution de Jacques Beigbeider

require "stat.pl";

open(LS,"ls *.pdf *.dvi *.log *.ps *.aux *.box 2> /dev/null|")
	|| die "Unable to ls!\n";

@rm = ();
$cmd = "ls -l";
while ($filename = ) 
{
    chop $filename;
    $file = $filename;
    if ($file eq "texput.log" || $file eq "missfont.log") {
	push(@rm,$file);
	system("ls -l ".$file);
	next;
    }
    if ($filename =~ /\.aux$/ ) {$filename =~ s/\.aux$/.tex/; }
    elsif ($filename =~ /\.log$/ ) {$filename =~ s/\.log$/.tex/; }
    elsif ($filename =~ /\.ps$/ ) {$filename =~ s/\.ps$/.tex/; }
    elsif ($filename =~ /\.dvi$/ ) {$filename =~ s/\.dvi$/.tex/; }
    elsif ($filename =~ /\.pdf$/ ) {$filename =~ s/\.pdf$/.tex/; }
    elsif ($filename =~ /\.box$/ ) {$filename =~ s/\.box$//; }
    (@f = stat($file)) || next;
    (@g = stat($filename)) || next;
    if (@f[$ST_MTIME] > @g[$ST_MTIME]) {
	$cmd .= " $file";
	push(@rm,$file);
    }
}


if (scalar(@rm) == 0) 
{
    print "Nothing to do!\n";
    exit 1;
}
system($cmd);
print "Ok to remove all of this ? ";
$answer = ;
if ($answer =~ /^[yYoO]/) 
{
    unlink @rm;
    print "Removed...\n";
    exit 0;
}
exit 2;
top