Scripts ou codes gratuits et disponibles pour tous en Perl [Sources]

[djibril]

Bonjour à vous tous

Grâce à la suggestion et à l'initiative de 2Eurocents, j'ouvre ce post-it sur les snippets. Que sont les snippets ? Des petits morceaux de code bien astucieux qu'on utilise souvent dans nos programmes. Un exemple ? Lister dans un tableau les fichiers pl d'un répertoire :

Code :

1
2
3
4
5
6
7
8
9
10
11
 
my($repertoire) = "/path/de/mon/repertoire";
my(%mtime);
my(@ficpl);
opendir (DIR, "$repertoire") || die ("can't open $repertoire");
@ficpl = grep { 
	/\.(pl)$/i && ($mtime{$_} = (stat ("$repertoire\\$_"))[9]);
} 
readdir (DIR);
closedir DIR;
my(@ordered_pl_names) = @ficpl;

Donc, si vous désirez poster un morceau de code que vous utilisez souvent et dont vous pensez qu'il sera utile pour la communauté, n'hésitez pas !

Les meilleurs bouts de codes seront mis à la disposition de tout le monde sur la page source de la rubrique Perl.

N'hésitez pas à y contribuer ou faire des remarques.

Merci

[GLDavid]

Obtenir un chemin relatif à partir d'un chemin absolu :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
sub Relative_path_Unix {
        #@_ = "/home/toto/tata";
	my($name) = @_;
	my($i) = rindex($name, '/');
	my($nom) = substr($name, $i+1);
        #retourne "Tata"
	return $nom;
}
 
sub Relative_path_DOS {
        #@_ = "C:\\Toto\\Tata";
	my($name) = @_;
	my($i) = rindex($name, '\\');
	my($nom) = substr($name, $i+1);
        #retourne "Tata"
	return $nom;
}

@ ++

[GLDavid]

Effectuer une connexion FTP :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
use Net::FTP;
 
sub ftp_call {
	#download à partir d'un répertoire FTP
	my($file);
	my($ftp) = Net::FTP -> new (
 		"xxx.xxx.xxx.xxx",
  		Passive =>1,
  		Timeout => 30
  	) or die "Unreachable host !\n";
	$ftp->login("toto","toto") or die "Connexion impossible";
	$ftp->binary; 
	$ftp->cwd("MonRepertoire");
	foreach $file (@_) {
		$file = $file.".pl";
		$ftp->get($file) or die "Impossible d'obtenir $file !";
#Pour l'upload ?
#$ftp->put($file) or die "Impossible d'envoyer $file !";
	}
}

[2Eurocents]

Bonjour à tous,

Puisque l'on parle de moi, je rajoute mon petit bout de code ...

Il s'agit du balayage d'un fichier dont les champs sont séparés par des virgules. On veut ce fichier dans une table de hachage, mais la clef est la quatrième colonne du fichier. En plus (spécif. idiote des structures de données ), on veut récupérer les autres colonnes dans une liste, référencée dans la fameuse table de hachage ... Mais peut être que le code est plus explicite :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
#! /usr/bin/perl -w
my @fichier;
my %liste;
 
open ( FICHIER , "< ./data.txt" ) or  die "Fichier Introuvable";
chomp ( @fichier = <FICHIER> );
close ( FICHIER ) ;
 
%liste=map ( { my @ligne=split(/,/,$_); 
             ($ligne[3], [ @ligne[0..(@ligne-2)] ]) } @fichier);
 
foreach $key (keys (%liste)) {
  print $key." = ".$liste{$key}[0]."/".$liste{$key}[1]."/".$liste{$key}[2]."\n" ;
}

La cle de tout ce code est dans les lignes 9 et 10 (%liste = map ...) où l'on a un traitement systématique (map), un usage de référence anonyme ( [] autour du 2e élément que l'on met dans la liste de sortie), usage de tranches de tableau (sur laquelle on fait la référence anonyme), affectation d'une liste correctement formatée à une table de hachage ...

J'espère que l'idée qui a sous-tendu ce code servira à d'autres ...

[Arioch]

Voici une vieille fonction qui retourne la date du jour selon différents formats en fonction du format passé en paramètre.

Liste des formats disponibles :

"JJMMAA" pour obtenir JJ/MM/AA exemple "10/11/04"
"JJMMAAAA" pour JJ/MM/AAAA exemple "10/11/2004"
"JJMMMAAAA" exemple "10 nov 2004"
"JJMMMMAAAA" exemple "10 novembre 2004"
"AAAAMMJJ" exemple "20041110"

Code :

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
sub DonneDate
{
	my $Format;
	$Format = ($_[0] ? $_[0] : "AAAAMMJJ");
	my ($Sec,$Min,$Heure,$Mjour,$Mois,$Annee,$Sjour,$Ajour,$Isdst) = localtime(time);
	$Annee += 1900;
	$Mois += 1;
	$Mois = 1 if ($Mois == 13);
	if ($Format eq "JJMMMAAAA")
	{
		my @MoisCourt = qw(jan fév mar avr mai juin juil août sept oct nov déc);
		return $Mjour . ' ' . $MoisCourt[$Mois-1] . ' ' . $Annee;
	}
	elsif ($Format eq "JJMMMMAAAA")
	{
		my @MoisLong = qw(janvier février mars avril mai juin juillet août septembre octobre novembre décembre);
		return $Mjour . ' ' . $MoisLong[$Mois-1] . ' ' . $Annee;
	}
	else	# on ne traite que du format numérique ici
	{
		$Mois = '0' . $Mois if ($Mois < 10);
		$Mjour = '0' . $Mjour if ($Mjour < 10);
		if ($Format eq "JJMMAA")
		{
			if ($Annee =~ /(\d{2})(\d{2})/)
			{
				return $Mjour . '/' . $Mois . '/' . $2;
			}
			else
			{
				return $Mjour . '/' . $Mois . '/' . $Annee;
			}
		}
		elsif ($Format eq "JJMMAAAA")
		{
			return $Mjour . '/' . $Mois . '/' . $Annee;
		}
		else
		{
			return "$Annee$Mois$Mjour";
		}
	}
}

Fonctionne sous Linux et Windows.

[Arioch]

Autre vieille fonction qui retourne l'heure cette fois.

2 formats au choix en paramètres à la fonction :
"HHMM" retourne par ex. "10:30"
"HHMMSS" retourne par ex. "10:30:07"

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
sub DonneHeure
{
	my $Format;
	$Format = ($_[0] ? $_[0] : "HHMMSS");
	my ($Sec,$Min,$Heure,$Mjour,$Mois,$Annee,$Sjour,$Ajour,$Isdst) = localtime(time);
	$Sec = '0' . $Sec if ($Sec < 10);
	$Min = '0' . $Min if ($Min < 10);
	$Heure = '0' . $Heure if ($Heure < 10);
	if ($Format eq "HHMM")
	{
		return "$Heure:$Min";
	}
	else
	{
		return "$Heure:$Min:$Sec";
	}
}

Idem que fonction précédente, fonctionne sous Linux comme Windows.

[2Eurocents]

Pour le formatage de date et heures, je m'étais forgé ça :

Code :

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
sub fdate
{
  my $chaine = shift;
  my $date;
  if ( @_ ) { $date = shift } else { $date = time }
  my ($sec,$min,$heure,$jourmois,$mois,$annee,$joursem,$jourannee,$dst) = localtime($date);
  $annee+=1900;
  my $anneecourte = join ('', (split('',$annee))[2,3]);
  map ( { $_ = sprintf ("%02d", $_) } ($sec,$min,$heure,$jourmois,$mois,$anneecourte) );
 
  my $nommois = qw (Janvier Février Mars Avril Mai Juin Juillet Août Septembre Octobre Novembre Décembre)[$mois];
  my $moiscourt = qw (Jan Fev Mar Avr Mai Jun Jui Aou Sep Oct Nov Déc)[$mois];
  my $nomjour = qw (Dimanche Lundi Mardi Mercredi Jeudi Vendredi Samedi Dimanche)[$joursem];
  my $nomjourcourt = join ('', (split('',$nomjour))[0..2]);
 
  $chaine =~ s/\#SS\#/$sec/g ;
  $chaine =~ s/\#MN\#/$min/g ;
  $chaine =~ s/\#HH\#/$heure/g ;
  $chaine =~ s/\#JJ\#/$jourmois/g ;
  $chaine =~ s/\#MM\#/$mois/g ;
  $chaine =~ s/\#NM\#/$nommois/g ;
  $chaine =~ s/\#MC\#/$moiscourt/g ;
  $chaine =~ s/\#AAAA\#/$annee/g ;
  $chaine =~ s/\#AA\#/$anneecourte/g ;
  $chaine =~ s/\#JS\#/$joursem/g ;
  $chaine =~ s/\#NJ\#/$nomjour/g ;
  $chaine =~ s/\#JC\#/$nomjourcourt/g ;
  $chaine =~ s/\#JA\#/$jourannee/g ;
  $chaine =~ s/\#DS\#/$dst/g ;
 
  return ($chaine) ;
}

... qui marche bien aussi, comme ça :

Code :

1
2
3
4
5
6
7
8
 
#Demonstration ...
my $instant = time ;
print fdate ("Il est #HH#:#MN#")."\n" ;
print fdate ("Nous sommes en #AA# ou #AAAA#")."\n" ;
sleep (5) ;
print fdate ("Nous sommes le #JC# #JJ#.#MM#.#AA# (#JA# jour de l'annee) et il est #HH#:#MN#:#SS# (DST=#DS#)")."\n" ;
print fdate ("Nous étions le #NJ# #JJ# #NM# #AAAA# (#JA# jour de l'annee) et il est #HH#:#MN#:#SS# (DST=#DS#)", $instant)."\n" ;

Mais j'avoue, je viens de rajouter le traitement des noms courts de jour et de mois, parce qu'à l'époque du codage, je n'y avait pas pensé ...

[GLDavid]

Un truc tout simple car j'ai encore vu un post à ce sujet : comment écrire dans un fichier :

Code :

1
2
3
4
 
open FILE, '>truc.txt' or die "truc.txt : $!\n";
print FILE "Bla bla bla !!!!";
close FILE;

Les redirections dans la close open sont identiques à celles d'Unix :
> je crée un fichier s'il n'existe pas sinon j'écrase le précédent s'il existe
>> je crée un fichier s'il n'existe pas sinon j'écris à la suite du précédent.
Ajout de 2Eurocent toujours utile : EN AUCUN CAS mettre de virgule entre le FILE et la chaine dans l'instruction print !

@ ++

[2Eurocents]

Tiens, un bout de code qui ne sert à rien ...

Non, j'exagère. Il peut servir :
1) Aux informaticiens de l'état civil
2) Aux profs en manque d'idées de TP d'informatique, niveau débutant

Il s'agit de deux fonctions destinées à convertir les nombres écrits en chiffres arabes vers des chiffres romains, et inversement.

C'est vrai que ça fait quand même plus classieux d'écrire :
22 Novembre MMIV que 22 Novembre 2004

Et puis une date de naissance en MDMLXX, par exemple, ça vous pose tout de suite quelqu'un

Code :

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
 
sub romain
{
  my $nombre=shift;
  my $chaine="";
 
  while ($nombre >= 1000) { $chaine.="M"; $nombre-=1000; }
  if ($nombre >= 900) { $chaine.="CM"; $nombre-=900; }
  while ($nombre >= 500) { $chaine.="D"; $nombre-=500; }
  if ($nombre >= 400) { $chaine.="CD"; $nombre-=400; }
  while ($nombre >= 100) { $chaine.="C"; $nombre-=100; }
  if ($nombre >= 90) { $chaine.="XC"; $nombre-=90; }
  while ($nombre >= 50) { $chaine.="L"; $nombre-=50; }
  if ($nombre >= 40) { $chaine.="XL"; $nombre-=40; }
  while ($nombre >= 10) { $chaine.="X"; $nombre-=10; }
  if ($nombre >= 9) { $chaine.="IX"; $nombre-=9; }
  while ($nombre >= 5) { $chaine.="V"; $nombre-=5; }
  if ($nombre >= 4) { $chaine.="IV"; $nombre-=4; }
  while ($nombre > 0) { $chaine.="I"; $nombre--; }
 
  return $chaine;
}
 
 
sub arabe
{
  my $chaine=shift;
  my @elements=reverse (split (//,$chaine));
  my $nombre=0;
  my %valeurs = ( "M" => 1000, "D" => 500, "C" => 100, "L" => 50, "X" => 10, "V" => 5, "I" => 1 );
  my $dernier=1;
 
  foreach (@elements) {
    if ($valeurs{$_} < $dernier) { $nombre-=$valeurs{$_}; }
    else { $nombre+=$valeurs{$_}; }
    $dernier=$valeurs{$_};
  }
 
  return $nombre;
}

Et une petite démonstration vite faite :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
 
print "1994 = ".romain(1994)."\n";
print "2948 = ".romain(2948)."\n";
print "1398 = ".romain(1398)."\n";
print "1835 = ".romain(1835)."\n";
print "1970 = ".romain(1970)."\n";
print "-----------------------------------\n";
print "MCMXCIV = ".arabe("MCMXCIV")."\n";
print "MMCMXLVIII = ".arabe("MMCMXLVIII")."\n";
print "MCCCXCVIII = ".arabe("MCCCXCVIII")."\n";
print "MDCCCXXXV = ".arabe("MDCCCXXXV")."\n";
print "MCMLXX = ".arabe("MCMLXX")."\n";

Nota bene : Avec les chiffres romains, il n'est pas prévu de dépasser 4998 (?). Le comportement de ces fonctions est alors assez indéfini ...

[Jedai]

Un idiome pratique pour ignorer des valeurs dans une affectation :

Code :

1
2
 
my (undef, $seconde_valeur, undef, $quatrieme_valeur) = @tableau ;

--
Jedaï

[Jeh]

Lister le contenu d'un répertoire et ses sous-répertoires :
VERSION UNIX :

Code :

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
#!/usr/bin/perl
 
use strict;
my $nb_arg = @ARGV;
if (($nb_arg > 1) or ($nb_arg <1)) {
    print "\nNombre d'arguments incorrect.";
    exit(1);
}
 
my $dir = $ARGV[0];
 
ListRep($dir);
 
sub ListRep {
    my ($dir) = @_;
    if (! -e $dir ) {
      print "Répertoire inconnu ($dir).";
      return undef;
     }
 
     if (! -d $dir ) {
      print "$dir n'est pas un répertoire.";
      return undef;
     }
 
     if (! opendir( DIR, $dir) ) {
      print "Impossible d'ouvrir le répertoire $dir : $!.";
      return undef;
     }
 
     my @files = grep !/(?:^\.$)|(?:^\.\.$)/, readdir DIR;
     closedir DIR;
     print "\nFICHIERS CONTENUS:\n";
     foreach(@files) {
        print $_."\n";
     }
     foreach(@files) {       
        if (-d $dir."/".$_) {
            print "\n\nREPERTOIRE : ".$_."\n";
            ListRep($dir."/".$_);
        }
     } 
 
}
 
1;

VERSION WINDOWS: changer le dernier 'foreach' par celui-ci.

Code :

1
2
3
4
5
6
7
 
     foreach(@files) {       
        if (-d $dir."\\".$_) {
            print "\n\nREPERTOIRE : ".$_."\n";
            ListRep($dir."\\".$_);
        }
     }

[djibril]

ma petite contribution!
voici un script permettant de passer d'un fichier csv ou txt à un fichier excel.

Code :

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
 
#!/usr/bin/perl -w
 
#######################################################################
#Ce script permet de transformer un fichier txt ou csv en fichier excel.
# - Si c'est un fichier csv donner en argumant le fichier csv
# Ex script.pl fichier.csv
#
# - Si c'est un fichier txt donner en argument le fichier txt et
# preciser le separateur dans le script ligne 29 ou modifier la ligne 54
# Ex: script.pl fichier.txt 
######################################################################
use strict;
use Carp;
use Spreadsheet::WriteExcel;	#module pour creer des fichiers excel
 
my $nbr_argument = @ARGV;	#recupere le nombre fichiers entres en argument
unless( $nbr_argument == 1) {print "trop de fichiers donnes en argument\n"; exit; }
my $separateur;			#le separateur
my $fichier_a_transformer = $ARGV[0];
 
my $fichier_excel = $fichier_a_transformer;
    #si c'est un fichier csv
    if ($fichier_a_transformer =~ /\.csv$/i){
      $fichier_excel =~ s/(.+)\.csv$/$1\.xls/gi;
      $separateur = ",";		#le separateur est une virgule
    } 
    else {
      #si c'est un fichier txt	
      $fichier_excel =~ s/(.+)\.txt$/$1\.xls/gi;
      $separateur = ",";		#le separateur est à préciser      
     }
 
    # Creer une page excel ayant pour le même nom que le fichier txt
    my $workbook = Spreadsheet::WriteExcel->new($fichier_excel) || die "impossible de creer $fichier_excel ou fichier ouvert";
 
    # nom de la feuille
    my $worksheet = $workbook->add_worksheet("feuille1");
 
    #  Definition d'un format d'ecriture
    my $format = $workbook->add_format();  #creation du format
    $format->set_bold();		#caractere en gras
    $format->set_align('center');	#caracteres centres
 
    # recuperer les donnees du fichier txt et mise dans le fichier excel
    my $colonne_excel = 0;
    my $ligne_excel = 0;
    my $ligne;
    my @tab_ligne;
    my $last_case;
 
    open (FILE, "$fichier_a_transformer") || die ("impossible de d'ouvrir $fichier_a_transformer $!");
    while ($ligne = <FILE>) {
      chomp($ligne);			#suppression des retour à la ligne
      @tab_ligne = split ($separateur, $ligne);
      $last_case = $#tab_ligne;		#dernier index du tableau
      for ($colonne_excel = 0; $colonne_excel<= $last_case; $colonne_excel++) {
      	#remplissage du fichier excel
        $worksheet->write($ligne_excel, $colonne_excel, $tab_ligne[$colonne_excel], $format);	
      } 
      $colonne_excel = 0;		#reinitialise la colonne à 0      
      $ligne_excel++;			#on passe a la ligne suivante dans le fichier excel
    }
    close (FILE);

voilà

[siaoly]

Voici un script permettant entre autre de coder de latin1 a utf-8

Code :

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
#!/usr/local/bin/perl
 
use strict;
use Unicode::String qw(latin1 utf8);	# conversion latin1 <-> utf8
use MIME::Base64;
 
 
{
  my ($ligne, $CN, @table, $Parametre, $Retour, $Oid, $Pos);
  die "Erreur de syntaxe. Il faut passer le nom de fichier LDIF em parametre." if ($#ARGV != 0);
  die "Impossible d'ouvrir le fichier $ARGV[0]" if (!open (FICLDIF, "<$ARGV[0]"));
  while ($ligne = <FICLDIF>)
  {
    chomp($ligne);
    $Pos = index($ligne, ": ");
    if ($Pos)
    {
      $Oid = substr($ligne, 0, $Pos);
      $Parametre = substr($ligne, $Pos + 2);
      $Retour = $Parametre;
 
      if (&EncodeUTF8_64($Retour))     # c'est encode
      {
        $ligne = $Oid . ":: " . $Retour;
      }
    }
    print "$ligne\n";
  }
}
 
# **************************************************************************************
# fonction EncodeUTF8-64
# encode en utf8 puis MIME 64 l'argument passé en paramètre si celui-ci n'est pas
#     ASCII pur
# retourne 1 si encodage, 0 sinon
# **************************************************************************************
sub EncodeUTF8_64
{
  my $temp;
  $temp = latin1($_[0])->utf8;
  return 0 if ($temp eq $_[0]);     # y a pas de modif
  $_[0] = encode_base64($temp, "");
#  chomp $_[0];
  return 1;
}
 
# **************************************************************************************
# fonction EncodeUTF8
# encode en utf8 l'argument passé en paramètre si celui-ci n'est pas ASCII pur
# retourne 1 si encodage, 0 sinon
# **************************************************************************************
sub EncodeUTF8
{
  my $temp;
  $temp = latin1($_[0])->utf8;
  return 0 if ($temp =~ /$_[0]/);     # y a pas de modif
  $_[0] = $temp;
  return 1;
}
 
;

[cryptorchild]

Moi je suis nouveau sur le forum voici ma petite participation pour le moment !

Ce programme sert a retourner la date du jour au format JJ/MM/AA

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
                 sub afficher_date
                 {
                 (@date);
                              ($an,$jour,$mois)=('','','');
                              @date=gmtime(time());
                              if (length($date[5]) == 2) {if ($date[5]>70) {$an='19';}  else{$an='20';}
                               }
                              if (length($date[5]) == 3) {$date[5]=$date[5]+1900; }
                              if (length($date[5]) == 4) { }
                              $an.=$date[5];
                              $jour=$date[3];
                              if (length($jour) == 1) {$jour='0'.$jour}
                              $mois=$date[4];
                              $mois++;
                              if (length($mois) == 1) {$mois='0'.$mois}
                               return ("$jour/$mois/$an");
                        }

[djibril]

encore plus simple pour date (jour/mois/annee, hh:min:sec)

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
#!/usr/bin/perl 
use strict;
use Carp;
&date_h_j();
sub date_h_j{
my @tab_date =localtime(time);
my $jour = $tab_date[3];
my $mois = ($tab_date[4]+1);
my $annee =  ($tab_date[5]+1900);
my $heure = $tab_date[2];
my $minute = $tab_date[1];
my $sec= $tab_date[0];
 
print "$jour/$mois/$annee, $heure:$minute:$sec\n";
}

[Mr6]

Plus long, mais assez pratique, tjrs dans les dates
Les 4 lignes repérées par #A supprimer pour faire un package peuvent être dégagées si on veut mettre la fonction ds un package, perso, c comme ca ke je l'utilise.

Code :

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
 
#!/usr/bin/perl 
use strict;
 
#package mon_package; # Enlever le commentaire pour déclarer le package
 
my @WEEK_DAYS = ('Dimanche', 'Lundi', 'Mardi', 'Mercredi', 'Jeudi', 'Vendredi', 'Samedi');
my @MONTHS    = ('Janvier','Février','Mars','Avril','Mai','Juin','Juillet','Août','Septembre','Octobre','Novembre','Décembre');
 
my $time = time; #optionel                                       #A supprimer pour faire un package
my $sql_date = conv_date($time, '%sql');                  #A supprimer pour faire un package
my $date_normale = conv_date($time, '%d %B %Y'); #A supprimer pour faire un package
my $heure = conv_date($time, '%X');                        #A supprimer pour faire un package
 
 
sub conv_date {
	my($time, $format) = @_;
	if (! $time)   { $time = time; }
	if (! $format) { $format = '%D' }
	my($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime($time);
	my $full_en_text_date = localtime($time);
	$mon++;
	my $yearl = $year + 1900;
	if ($year > 99) { $year -= 100; }
	my $short_mon  = substr($MONTHS[$mon - 1],  0, 3);
	my $short_wday = substr($WEEK_DAYS[$wday], 0, 3);
	my $mdayl = sprintf('%02d', $mday);
	my $monl  = sprintf('%02d', $mon);
	$sec   = sprintf('%02d', $sec);
	$min   = sprintf('%02d', $min);
	$hour  = sprintf('%02d', $hour);
	$year  = sprintf('%02d', $year);
 
	$_ = $format;
	s/%%/%/g;
	s/%sql/$yearl-$monl-$mdayl/g;
	s/%a/$short_wday/g;
	s/%A/$WEEK_DAYS[$wday]/g;
	s/%b|%h/$short_mon/g;
	s/%B/$MONTHS[$mon-1]/g;
	s/%c/$full_en_text_date/g;
	s/%d/$mdayl/g;
	s/%D|%x/$monl\/$mday\/$year/g;
	s/%e/$mday/g;
	s/%m/$monl/g;
	s/%H/$hour/g;
	s/%j/$yday/g;
	s/%M/$min/g;
	s/%S/$sec/g;
	s/%n/\n/g;
	s/%t/\t/g;
	s/%X|%T/$hour:$min:$sec/g;
	s/%y/$year/g;
	s/%Y/$yearl/g;
	return $_;
}

@+
Mr6

[nematoad]

Envoyé par GLDavid

(...)

Lister dans un tableau les fichiers pl d'un répertoire :

Code :

Le truc avec $mtime, ça n'a pas l'air de grande chose. D'ailleurs, si un snippet est censé être court, on peut remplacer tout ça par :

Code :

1
2
 
    @ficpl = glob( "$repertoire/*.pl" );

De nos jours, glob marche tout à fait bien sous Windows et ailleurs. Ça ne génère plus de sous-processes inefficaces.

[djibril]

rajout sur le parcour recursif de repertoire.
Ce script donne l'adresse complet d'un fichier ou repertoire cherché.
Vous lui précisé un repertoire racine, et il parcours le repertoire et tous les sous repertoires, tres pratique.
exemple :

Code :

1
2
3
4
5
 
toto.pl gene
                 =>C:/Documents and Settings/perl/gene.tgz
                 =>C:/Documents and Settings/perl/files/gene.xml
                 =>repertoire : C:/Documents and Settings/gene

voilà le script, faut juste mettre le chemin d'un repertoire dans son script
dans $mon_dir

Code :

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
 
#!/usr/bin/perl -w 
 
#---------------------------------------------- 
# 
# ce script permet de parcourir un repertoire
# et affiche le chemin du fichier cherché. ou
# repertoire: nom du repertoire s'il en trouve
# -----------------------------------------------
 
 
use strict; 
use Carp; 
 
my $file = $ARGV[0];		#donne un bout de nom
my $mon_dir = "C:/Documents and Settings/Propriétaire/Mes documents/apprendre_progammation/perl";
&premier_repertoire($mon_dir, $file);
 
 
sub premier_repertoire {
	my $mon_rep = shift;
	my $file = shift;
	opendir (REP,$mon_rep) or die "Impossible d'ouvrir $mon_rep";
	my @dots = grep { /^\w+/ } readdir(REP);
	foreach  my $nom (@dots) {
	  &verification($nom, $mon_rep, $file); #recursivité et parcours du repertoire trouvé
	}
	closedir (REP);
}
sub verification { 
    my $dir = shift;
    my $mon_rep = shift;
    my $file = shift;
    my $repertoire = "$mon_rep/$dir";
     if ( -d $repertoire && $repertoire !~ /^\.*$/) {
       if ( $repertoire =~ /$file/i) { 
	 print "repertoire : $repertoire\n";
       }
       &premier_repertoire($repertoire, $file);
     }
     if ( -e "$mon_rep/$dir" && -f "$mon_rep/$dir") { 
      	my $nom_fichier = $dir;
	if ($nom_fichier =~ /$file/i) {
  	  print "$mon_rep/$dir"."\n";    	#on peut recuperer le fichier pour autre traitement
     	}
     }  
}

[Jedai]

Notez bien que les snippets sont censés être utiles, pas de simples exercices de programmation : le code ci-dessus n'a donc pas vraiment sa place ici car find ou le module correspondant fait la même chose en mieux et plus rapide... Bien que le code en lui-même soit intéressant pour sa valeur pédagogique.

--
Jedaï

[GLDavid]

Pour la conversion de fichiers ASCII ISO-8859-1 vers UTF-8 :

Code :

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
 
#!/usr/bin/perl -w
 
use strict; 
use Unicode::String;
 
###########################################
#
#	2UTF8.pl
#	________
#
#Pour la conversion de fichiers ISO-8859-1
#vers UTF-8
#INPUT : un fichier ASCII ISO-8859-1
#OUTPUT : un fichier ASCII UTF-8
###########################################
 
Unicode::String->stringify_as('utf8');
my($file) = $ARGV[0];
my($file_dest) = $file.".new";
open FILE, "< $file" or die "$!\n";
open FILE2, "> $file_dest" or die "$!\n";
while(<FILE>){
	$_ = Unicode::String::latin1($_);
	print FILE2 $_;
}
close FILE and close FILE2;
unlink $file;
rename($file_dest, $file);
unlink $file_dest;

Particulièrement utile quand vous importez un fichier d'un OS ISO-8859-1 vers un OS UTF-8 (ex : WinXP -> Ubuntu Hoary) .

@++