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

**nematoad** · 15/03/2005, 14h21

Envoyé par GLDavid

(...)

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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;

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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** · 23/03/2005, 00h59

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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** · 24/03/2005, 21h32

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** · 16/04/2005, 13h29

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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)

.

@++

**hornetbzz** · 07/01/2011, 00h03

Un petit bout de code pour les fonctions simuli de PHP (diff, union, instersect) sur les tableaux (listes). Dsl, je fais tout en anglais.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
#!/usr/bin/perl -w
use strict;
use warnings;
use Data::Dumper;
 
sub array_diff {
	# arrays @a and @b to be compared
        # listes a et b à comparer
	my (@a, @b) = @_;
 
	my @isect;
	my @union;
	my @diff;
	my $e;
	my %count;
	my %hash_of_arrays;
 
	# check entries
        # vérifier le type des listes en entrées qui doivent être de type "ARRAY"
	if ( (ref (\@a) ne "ARRAY") || (ref (\@b) ne "ARRAY") ) {
		print "entries shall be ARRAY";
		exit 0;
	}
 
	# store all keys into an hash $count
        # stocker les clés dans un hash
	foreach $e (@a, @b) { $count{$e}++ }
 
	# browse the hash $count
        # balayer le hash
	foreach $e (keys %count) {
		# union is simple
		push(@union, $e);
 
		# intersection
		if ($count{$e} == 2) {
			push @isect, $e;
		# difference
		} else {
			push @diff, $e;
		}
	}
 
	# store resulting arrays into an hash of arrays
        # stocker les résultats dans un hash
	$hash_of_arrays{diff} = \@diff;
	$hash_of_arrays{union} = \@union;
	$hash_of_arrays{isect} = \@isect;
 
	return %hash_of_arrays ;
}
 
# Testing the function
my @arr1 = ( "foo", "bar", "truc", "bidule", 1 , 2, 3);
my @arr2 = ( "foo", "car", "truc", "bidule", 1 , 2, 4);
my %result;
 
# global hash result
%result = &array_diff(@arr1, @arr2);
print Dumper(\%result);
 
# diff only
my $diff = $result{diff};
print Dumper($diff);
 
# Diff Output:	'3', 'car',  'bar', '4'
# Union Output :	'truc', '3', 'car',   '2',  'bar',   '1',  '4',  'foo', 'bidule'
# Intersection Ouput :	'truc', '2',  '1',  'foo', 'bidule'

**hornetbzz** · 07/01/2011, 00h30

Toujours au chapitre des petites fonctions de type PHP, celle-ci vérifie si une chaine est incluse dans une liste. Rien de transcendant c'est certain. Mais utile.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
#!/usr/bin/perl -w
# chemin vers interpreteur perl à adapter selon votre config
# un simple "which perl" devrait pouvoir vous renseigner
 
use strict;
use warnings;
use constant true => 1; # bah oui sinon je suis perdu :-)
use constant TRUE => 1;
use constant false => 0;
use constant FALSE => 0;
 
sub in_array {
# appel : &in_array(@array, $needle);
	my ($arr, $needle) = @_;
	if (grep {$needle eq $_} @$arr) {
		return true;
	} else {
		return false;
	}
}

**hornetbzz** · 10/01/2011, 17h07

Bon, dans la série "je réinvente la roue", mais si je l'ai réinventée, c'est que je n'ai trouvé que des bribes du "carrosse" dans la FAQ et auprès de mon ami, donc voilà quelques fonctions utiles sur la base de l'utilisation du module DBI et des tableaux associatifs :

Testé sur Perl V5.10 / Debian Lenny

Entête commune :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
#!/usr/bin/perl -w
 
	use strict;
	use warnings;
	use DBI;
	use DBD::mysql; # hum, redondant avec DBI?
 
	use constant true => 1;
	use constant TRUE => 1;
	use constant false => 0;
	use constant FALSE => 0;
	use constant DEBUG => true;

CONNEXION/DECONNEXION

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
sub db_connect {
 
	# local params
	my ($db_name, $host, $db_user, $db_pwd) = @_ ;
 
	# Connect
	my $dbh = DBI->connect("dbi:mysql:dbname=$db_name;host=$host;mysql_server_prepare=1;",$db_user, $db_pwd)
or die "err " . $dbh->err;
 
	# mysql setup
	$dbh->{mysql_bind_type_guessing} = TRUE;
	$dbh->{ChopBlanks} = TRUE; 
	$dbh->{RaiseError} = TRUE if DEBUG;
 
	return $dbh;
}

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
sub db_disconnect{
	my ($local_dbh) = @_ ;
	if ($local_dbh->disconnect) {
		return TRUE;
	} else {
		return FALSE;
	}
}

INSERT

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
sub db_insert_hash {
    my ($dbh, $table, $field_values) = @_;
    my @fields = sort keys %$field_values;
    my @values = @{$field_values}{@fields};
    my $sql = sprintf "INSERT INTO %s (%s) VALUES (%s)", $table, join(",", @fields), join(",", ("?") x @fields);
#				   ^^  ^^	   ^^
#				table   columns     binded values
    my $sth = $dbh->prepare($sql);
    return $sth->execute(@values);
}

UPDATE

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
sub db_update_hash {
 
	# INIT	
	my ($dbh, $table, $field_values, $sql_condition) = @_;
 
	# CORE QUERY
	my @fields = sort keys %$field_values;
	my @values = @{$field_values}{@fields};
	my $query = sprintf "UPDATE %s SET %s " , $table,  join ( ", ", map { "$_=?" } @fields ) ;
 
	# WHERE CONDITION
	my @condition_fields = sort keys %$sql_condition;
	my @condition_values = @{$sql_condition}{@condition_fields};
	my $qualifier = "";
	$qualifier = "WHERE " . join(" AND ", map { "$_=?" } @condition_fields) if @condition_fields;
 
	# FINAL QUERY
	$query .= $qualifier ;
 
	# PREPARE
	my $sth = $dbh->prepare($query);
 
	# BIND ARRAY: merge both data arrays (values and conditions)
	push @values, @condition_values;
 
	# EXECUTE
	return $sth->execute(@values);
}

SEARCH

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
sub db_search_hash {
	my ($dbh, $table, $field_values) = @_;
 
	# INIT: split input datas hash into 2 arrays
	my @fields = sort keys %$field_values;
	my @values = @{$field_values}{@fields};
 
	# WHERE CONDITION
	my $qualifier = "";
	$qualifier = "WHERE ".join(" and ", map { "$_=?" } @fields) if @fields;
 
	# CORE QUERY
	my $query = "SELECT * FROM $table $qualifier" ;
 
	# PREPARE
	my $sth = $dbh->prepare($query);
 
	# EXECUTE
	return $dbh->selectall_hashref($sth, \@fields, {}, @values);
}

HASH RECURSIVE KEY SEARCH, en complément à db_search_hash qui renvoie un hash dans lequel on devra farfouiller

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
sub hash_recursive_key_search {
	my ( $needle_key, %hash ) = @_ ;
	my $found ;
 
	while ( my ($key, $value) = each %hash ) {
		$found = ( $key eq $needle_key) ? "(*)" : ""; 
		print "key: $key => value: $value $found\n" if ( ref $value ne 'HASH' and DEBUG);
		push @$tmp, $key, $value if ( $key eq $needle_key) ; 
		&hash_recursive_key_search( $needle_key, %$value ) if ( ref $value eq 'HASH') ;
	}
}

Exemple d'utilisation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
# CONNEXION
my $db_handle = &connect_db ($db_name, $host, $db_user, $db_pwd); # à vous de renseigner
 
# DATAS
my $table = "foo" ;
my $client_id = "12345" ;
my $pn ="AB1234";
my $hash = {'id_client' => $client_id , 'serial_number' => $pn , status => 1} ;
 
# INSERT
my $db_insert = &db_insert_hash ($db_handle, $table, $hash ) ;
 
#UPDATE
my $sql_condition = {"id_client" => $client_id, "serial_number" => $pn} ;
my $field_values = { status => 2 }; 
my $update = &db_update_hash ($dbh, $table, $field_values, $sql_condition) ;
 
# SEARCH
my $result = &db_search_hash ($dbh, $table, $sql_condition) ;
my $tmp = [] ;
my $needle_key = "id";
&hash_recursive_key_search( $needle_key , %$result ) ;
my $id_key = @$tmp[0] ;
my $id_value =  @$tmp[1]  ;
 
#DECONNEXION
&db_disconnect($db_handle);

**djibril** · 10/01/2011, 17h14

sur DBI, as tu lu cette doc?

**hornetbzz** · 10/01/2011, 17h24

Euh oui au début, il y a qq semaines. Mais je ne regrette pas cependant ma proposition qui me parait plus "universelle" avec un petit jeu de subroutines toutes faites, courtes et homogenes les unes avec les autres, pour traiter des hashes. Quelle que soient les données de la dB mysql.

**Achir** · 23/02/2011, 22h15

Bonjour,
Voila, je vous mets ici un code permettant de remplir une table de données à partir d'un fichier texte. Le SGBDR utilisé est Mysql server.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
# Insertion des données
    my $file_database = "fichier.txt";
    my $RequeteSQL = <<"SQL";
    LOAD DATA LOCAL INFILE '$file_database'
    REPLACE
    INTO TABLE [Nom_table]
    FIELDS
    TERMINATED BY '\t'  #Les données sont séparées par des tabulations.
	         LINES
		     TERMINATED BY '\n'  #Chaque ligne se termine par \n.
SQL
                 $dbh->do($RequeteSQL) or die "Echec Requete $RequeteSQL : $DBI::errstr";

**djibril** · 24/02/2011, 07h42

Envoyé par Achir

Bonjour,
Voila, je vous mets ici un code permettant de remplir une table de données à partir d'un fichier texte. Le SGBDR utilisé est Mysql server.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
# Insertion des données
    my $file_database = "fichier.txt";
    my $RequeteSQL = <<"SQL";
    LOAD DATA LOCAL INFILE '$file_database'
    REPLACE
    INTO TABLE [Nom_table]
    FIELDS
    TERMINATED BY '\t'  #Les données sont séparées par des tabulations.
	         LINES
		     TERMINATED BY '\n'  #Chaque ligne se termine par \n.
SQL
                 $dbh->do($RequeteSQL) or die "Echec Requete $RequeteSQL : $DBI::errstr";

Merci de poster un code indenté, complet et fonctionnel via un simple copié/collé.

**djibril** · 30/06/2011, 11h54

tout se passe maintenant ici.

**nematoad** · 28/04/2005, 12h39

Si on sait avant de la lancer le programme, on peut le coder en dur et utiliser l'opérateur tr/// de transliteration, qui est simple et très efficace :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
my $nr_a = ($str =~ tr/a/a/);

Comment ça marche ? tr/// remplace un caractère par un autre (on peut aussi faire tr/aeiou/uieao/ pour changer plusieurs différents caractères). Donc on va se contenter de remplacer le caractère qu'on cherche 'a', par la même chose (pour ne pas bousiller la chaîne). Ensuite, à la fin de l'opération, tr// renvoie le nombre de transliterations qu'il a fait. Et voila comment on compte les caractères.

Par contre, si on ne sait pas quelle caractère on veut compter au départ, on ne pas le stocker dans une variable :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
$car = 'x';
my $nr_a = ($str =~ tr/$car/$car/); # ne marche pas

L'explication est que tr ne fait pas de l'interpolation des chaînes. Surtout, ne soyez pas tenté de faire eval "\$str =~ tr/$car/$car/" (je ne mets pas les balises code pour ne pas attirer l'attention dessus...) C'est trop dangereux.

Aussi, tr ne marchera pas si ce qu'on veut compter est plus long qu'un caractère. Pour s'en sortir, on utilise un match en contexte de liste:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
my $ch = 'n';
my $nr = () = ($str =~ m/$ch/g);

Comment ça marche ? Quand on ajoute /g à un match, cela indique au moteur de regexps de repartir faire la recherche là où ça a terminé la dernière fois (au lieu de commencer au début de la chaine). On le voit plus souvent comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
while( $_ =~ /truc/g ) {
    print "encore un truc\n";
}

Mais rien n'empeche de choper toutes les matches d'un seul coup, et les stocker dans un array :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
my @truc = ($_ =~ /truc/g); # tous les trucs

Ensuite, ce qu'il faut savoir, c'est que lorsqu'on on essaie d'interpreter un array en contexte scalaire, cela renvoie le nombre d'éléments de l'array (ce qui est fort, fort utile à bien des égards, et la raison principale qui explique l'absence d'un operateur du style my $nbre = length(@array), c'est tout bêtement trop simple à faire une fois qu'on a compris comment jouer avec le contexte). Par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
my $nr = @ARGV;
print "lancé avec $nr arguments\n";

Revenons à notre m/$ch/g. En fait, on se fiche un peu de stocker les éléments matché dans la chaîne, on veut juste leur nombre. Donc, on les capture mais on ne les garde pas avec () et on force le contexte scalaire derrière pour obtenir le fameux nombre. L'autre chose à retenir est qu'avec cette approche, rien ne limite $ch à un caractère : on peut mettre ce qu'on veut.

**2Eurocents** · 27/05/2005, 17h55

Suite au sujet "espace dans un nombre pour une meilleure lisibilité", je rajoute ce petit bout de code de formatage d'un nombre.

C'est un peu plus complet que ce qui est dans le sujet ...

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
my $separateur=" ";
my $groupage=3;
my $point_decimal=",";
 
my ($p_entiere, $p_decimale)=split (/\./, $nombre);
1 while ($p_entiere =~ s/(\d)(\d{$groupage}($|$separateur))/$1$separateur$2/);
1 while ($p_decimale =~ s/(\d{$groupage})(\d)/$1$separateur$2/);
$nombre = join ($point_decimal, $p_entiere, $p_decimale);

Il vous suffit donc de mettre la valeur à formater dans $nombre.

La valeur peut être positive ou négative. Elle doit être exprimée sous en notation décimale (la notation scientifique n'est pas supportée).

Elle peut être conditionnée au préalable pour ne conserver qu'une partie des décimales :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

$nombre = sprintf ("%0.2f", $nombre);

Le scalaire $separateur indique le caractère qui sera utilisé pour séparer les groupes de chiffres.

Le scalaire $groupage indique le nombre de chiffres par groupe.

Le scalaire $point_decimal indique le caractère utilisé pour représenter la virgule.

Avec les valeurs ci dessus, "-15648.15657" sera formatté en "-15 648,156 57" par exemple

Libre à vous d'en faire une fonction ou autre ...

**marsupilami** · 15/06/2005, 18h30

voicic un script qui permet de connaitre le nombre de lignes d un fichier texte
ainsi que le nombre de caractere par lignes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
 
#! C:\Perl\bin\perl -w
 
print " entrez le nom du fichier a evaluez ( marque l extention ) ? \n " ;
chomp ( $fichierabo = <stdin> ) ;
open ( FICHIER , $fichierabo ) ;
chomp ( @fichier = <FICHIER> ) ;
close ( FICHIER ) ;
 
$nbligne = $#fichier + 1 ;
print " ce fichier comporte $nbligne \n" ;
 
$ligne = 1 ;
foreach ( @fichier )
{
    @travail = split( // , $_ ) ;
    $caractere = $#travail + 1 ;
    print " la ligne $ligne comporte $caractere \n" ;
    @travail = () ;
    $ligne += 1 ;
}

**Jedai** · 15/06/2005, 21h34

S'il s'agit seulement de compter le nombre de lignes, il est préférable de slurper le fichier puis d'utiliser l'opérateur tr// pour compter le nombre de fin de ligne, c'est plus rapide parce que perl n'a pas besoin d'effectuer le découpage. On peut même utiliser sysread pour aller encore plus vite ou pour fragmenter la tâche sur de très gros fichier.
Bien sûr tout ceci n'est valable que si l'on a vraiment besoin de faire ça très souvent... Et qu'on a pas besoin de faire d'opération qui exige de découper le fichier en lignes.

--
Jedaï

**GLDavid** · 21/06/2005, 10h26

Et voici un script plus complet par rapport à mon précédent qui fait iso-8859-1 <-> utf-8 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
#!/usr/bin/perl -w
 
use strict;
use Locale::Recode;
 
sub to_iso {
	my($file) = $_[0];
	my($file_dest) = $file.".new";
	open FICHIER, "< $file" or die "$!\n";
	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
	while(<FICHIER>){
		my($cd) = Locale::Recode->new(from => 'UTF-8',
		to=>'ISO-8859-1');
		die $cd->getError if $cd->getError;
		$cd->recode($_) or die $cd->getError;
		print FICHIER_DEST;			
	}
	close FICHIER and close FICHIER_DEST;
	unlink $file and rename($file_dest, $file) and unlink $file_dest;
}
 
sub to_utf {
	my($file) = $_[0];
	my($file_dest) = $file.".new";
	open FICHIER, "< $file" or die "$!\n";
	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
	while(<FICHIER>){
		my($cd) = Locale::Recode->new(from => 'ISO-8859-1',
		to=>'UTF-8');
		die $cd->getError if $cd->getError;
		$cd->recode($_) or die $cd->getError;
		print FICHIER_DEST;			
	}
	close FICHIER and close FICHIER_DEST;
	unlink $file and rename($file_dest, $file) and unlink $file_dest;
}
 
sub recode_file {
	my($file) = $_[0];
	my($file_dest) = $file.".new";
	my($encode) = $_[1];
	if($encode eq "1"){
		&to_iso($file, $file_dest);
	}
	else {
		&to_utf($file, $file_dest);
	}
}
 
sub recode_repertory {
	my($repertory) = $_[0];
	my($pos) = rindex($repertory, '/');
	if($pos != (length($repertory)-1)){
		$repertory .= '/';
	}
	my($encode) = $_[1];
	chdir $repertory;
	my(@files) = `ls`;
	my($file);
	foreach $file (@files){
		$file = $repertory.$file;
		chomp $file;
		if( -f $file){
			&recode_file($file, $encode);
		}
		elsif ( -d $file){
			&recode_repertory($file, $encode);
		}
	}
}
 
 
###################MAIN######################
 
 
if ($#ARGV > -1){
	chomp $ARGV[0] and chomp $ARGV[1];
	if ($ARGV[0] =~ /[A-Za-z]+/){
		print "recode prend 2 arguments.\n";
		print "Le premier argument doit être un nombre :\n";
		print "1 : UTF-8 => ISO-8859-1\n";
		print "2 : ISO-8859-1 => UTF-8\n";
		print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
		exit 0;
	}
	if ($ARGV[0] > 2 or $ARGV[0] < 1){
		print "Le premier argument doit être un nombre valide :\n";
		print "1 : UTF-8 => ISO-8859-1\n";
		print "2 : ISO-8859-1 => UTF-8\n";
		exit 0;
	}
	if ( -f $ARGV[1]){
		&recode_file($ARGV[1], $ARGV[0]);	
	}
	elsif ( -d $ARGV[1]){
		&recode_repertory($ARGV[1], $ARGV[0]);
	}
} 
elsif ($#ARGV > 1) {
	print "recode prend 2 arguments.\n";
	print "Le premier argument doit être un nombre :\n";
	print "1 : UTF-8 => ISO-8859-1\n";
	print "2 : ISO-8859-1 => UTF-8\n";
	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
	exit 0;
}
elsif ($#ARGV == 0) {
	print "recode prend 2 arguments.\n";
	print "Le premier argument doit être un nombre :\n";
	print "1 : UTF-8 => ISO-8859-1\n";
	print "2 : ISO-8859-1 => UTF-8\n";
	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
	exit 0;
}
else {
	print "recode prend 2 arguments.\n";
	print "Le premier argument doit être un nombre :\n";
	print "1 : UTF-8 => ISO-8859-1\n";
	print "2 : ISO-8859-1 => UTF-8\n";
	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
	exit 0;
}

@++

**Jedai** · 21/06/2005, 14h22

Avec encodage de départ et d'arrivée paramétrables :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
#! /usr/bin/perl
use strict;
use warnings;
 
 
## Initialisations
 
use Encode;
use Getopt::Long;
use Pod::Usage;
$| = 1; # Autoflush on
 
sub from_to_file ($);
sub recode_dir ($);
 
Getopt::Long::Configure ("bundling", "ignore_case");
my ($verbose, $recursive, $all_files, $backup, $force, $from,        $to) = 
   (0,        0,          0,          2,       0,      "ISO-8859-1", "UTF-8");
 
GetOptions( "verbose|v" => \$verbose, "recursive|r" => \$recursive, 
  "backup|b!" => \$backup, "all-files|a" => \$all_files, 
  "force|F" => \$force, "from|f=s" => \$from, "to|t=s" => \$to )
    or pod2usage(-exitval => 2, -verbose => 1);;
unless( @ARGV ) { pod2usage(-exitval => 2, -verbose => 1) }
 
if( $backup == 2 ) {
  print "Do you want to backup your files ?(Y/n) ";
  if( <STDIN> =~ /^no?\s*/i ){
    $backup = 0;
  }
}
 
 
## Main
 
foreach my $file ( @ARGV ){
  if( -f $file ){
    from_to_file( $file );
  } elsif( -d $file ) {
    recode_dir( $file );
  }
}
 
 
## Fonctions
 
sub from_to_file ($) {
  my $file  = shift ;
  my $file_dest = $file.".new";
  my ($in, $out);
  while( -e $file_dest ) { $file_dest .= ".new" }
 
  open $in, "<:bytes", $file or die "$!\n";
  open $out, ">:bytes", $file_dest or die "$!\n";
 
  print "Encode $file from $from to $to.\n" if $verbose;
  while(<$in>){ 
    if ( $force ) {
 
      unless( defined Encode::from_to( $_, $from, $to, Encode::FB_PERLQQ ) ) {
        print "Error while encoding $file, are you sure that this file ",
          "is encoded in $from ?\n";
      }
 
    } else {
 
      eval { Encode::from_to( $_, $from, $to, 1 ) };
      if( $@ ){
        print "Error while encoding $file, are you sure that this file ",
          "is encoded in $from ?\nEncoding of $file aborted !\n";
        unlink $file_dest;
      }
 
    }
    print {$out} $_;
  }
 
  # backup if asked for
  if( $backup ){
    my $file_bak = $file.".bak";
    while( -e $file_bak ) { $file_bak .= ".bak" }
    rename( $file, $file_bak );
  }
 
  close $in and close $out;
  rename($file_dest, $file);
}
 
sub recode_dir ($) {
  my $dir = shift ;
  $dir .= "/" unless $dir =~ m</$>;
 
  opendir RECDIR, $dir or die "$!\n";
  my $file;
  while( defined ( $file = readdir RECDIR ) ) {
    unless( $file =~ /^\.{1,2}$/ ) {
      if( -d $dir.$file and $recursive ) {
        recode_dir( $dir.$file );
      } elsif (-f $dir.$file and ($file !~ /^\./ or $all_files) ){
        from_to_file( $dir.$file );
      }
    }
  }
}
 
__END__
 
=head1 NAME
 
Recode.pl
 
=head1 SYNOPSIS
 
Recode.pl [options] [file|directory ...]
 
 Options:
  -v or --verbose     Set the verbosity level of this program
  -f or --from        Encoding of the input files (default : ISO-8859-1)
  -t or --to          Target encoding (default : UTF-8)
  -r or --recursive   Process directories recursively
  -a or --all-files   Process hidden files too
  -b or --backup      Backup the files to *.bak
  --nob or --nobackup To avoid the backup of the files
  -F or --force       The program try to convert all parts of a file
                        that seems to have the good encoding
 
B<This program> will read the given input file(s) and/or directory(ies)
and encode them with the encoding specified by --to. Be careful since 
this program does B<not> check if the content of a file is really text !
 
=cut

Par exemple :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
./Recode.pl --from koi8-u --backup --recursive /MonRepertoireAvecLesFichiersEnKoi8-u
./Recode.pl -f koi8-u -rb /MonRepertoireAvecLesFichiersEnKoi8-u

TIMTOWDI

[ EDIT :
#1 Quelques corrections pour rendre le script plus robuste et plus fiable, les effets de ce script sont maintenant toujours inversibles car il annule le réencodage en cas de problème
#2 Introduction d'une option "--force" pour obliger le script à réencoder même lorsque des problèmes se présentent ]
--
Jedaï

**gorry** · 19/12/2005, 11h21

Envoyé par GLDavid

Et voici un script plus complet par rapport à mon précédent qui fait iso-8859-1 <-> utf-8 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
#!/usr/bin/perl -w
 
use strict;
use Locale::Recode;
 
sub to_iso {
	my($file) = $_[0];
	my($file_dest) = $file.".new";
	open FICHIER, "< $file" or die "$!\n";
	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
	while(<FICHIER>){
		my($cd) = Locale::Recode->new(from => 'UTF-8',
		to=>'ISO-8859-1');
		die $cd->getError if $cd->getError;
		$cd->recode($_) or die $cd->getError;
		print FICHIER_DEST;			
	}
	close FICHIER and close FICHIER_DEST;
	unlink $file and rename($file_dest, $file) and unlink $file_dest;
}
 
sub to_utf {
	my($file) = $_[0];
	my($file_dest) = $file.".new";
	open FICHIER, "< $file" or die "$!\n";
	open FICHIER_DEST, ">> $file_dest" or die "$!\n";
	while(<FICHIER>){
		my($cd) = Locale::Recode->new(from => 'ISO-8859-1',
		to=>'UTF-8');
		die $cd->getError if $cd->getError;
		$cd->recode($_) or die $cd->getError;
		print FICHIER_DEST;			
	}
	close FICHIER and close FICHIER_DEST;
	unlink $file and rename($file_dest, $file) and unlink $file_dest;
}
 
sub recode_file {
	my($file) = $_[0];
	my($file_dest) = $file.".new";
	my($encode) = $_[1];
	if($encode eq "1"){
		&to_iso($file, $file_dest);
	}
	else {
		&to_utf($file, $file_dest);
	}
}
 
sub recode_repertory {
	my($repertory) = $_[0];
	my($pos) = rindex($repertory, '/');
	if($pos != (length($repertory)-1)){
		$repertory .= '/';
	}
	my($encode) = $_[1];
	chdir $repertory;
	my(@files) = `ls`;
	my($file);
	foreach $file (@files){
		$file = $repertory.$file;
		chomp $file;
		if( -f $file){
			&recode_file($file, $encode);
		}
		elsif ( -d $file){
			&recode_repertory($file, $encode);
		}
	}
}
 
 
###################MAIN######################
 
 
if ($#ARGV > -1){
	chomp $ARGV[0] and chomp $ARGV[1];
	if ($ARGV[0] =~ /[A-Za-z]+/){
		print "recode prend 2 arguments.\n";
		print "Le premier argument doit être un nombre :\n";
		print "1 : UTF-8 => ISO-8859-1\n";
		print "2 : ISO-8859-1 => UTF-8\n";
		print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
		exit 0;
	}
	if ($ARGV[0] > 2 or $ARGV[0] < 1){
		print "Le premier argument doit être un nombre valide :\n";
		print "1 : UTF-8 => ISO-8859-1\n";
		print "2 : ISO-8859-1 => UTF-8\n";
		exit 0;
	}
	if ( -f $ARGV[1]){
		&recode_file($ARGV[1], $ARGV[0]);	
	}
	elsif ( -d $ARGV[1]){
		&recode_repertory($ARGV[1], $ARGV[0]);
	}
} 
elsif ($#ARGV > 1) {
	print "recode prend 2 arguments.\n";
	print "Le premier argument doit être un nombre :\n";
	print "1 : UTF-8 => ISO-8859-1\n";
	print "2 : ISO-8859-1 => UTF-8\n";
	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
	exit 0;
}
elsif ($#ARGV == 0) {
	print "recode prend 2 arguments.\n";
	print "Le premier argument doit être un nombre :\n";
	print "1 : UTF-8 => ISO-8859-1\n";
	print "2 : ISO-8859-1 => UTF-8\n";
	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
	exit 0;
}
else {
	print "recode prend 2 arguments.\n";
	print "Le premier argument doit être un nombre :\n";
	print "1 : UTF-8 => ISO-8859-1\n";
	print "2 : ISO-8859-1 => UTF-8\n";
	print "Le deuxième argument doit être le chemin absolu d'un fichier ou d'un répertoire.\n";
	exit 0;
}

@++

Merci pour ces informations, mais je suis devant un problème un peu différent :

Je travaille avec perl 5.8.7 et j'aimerais convertir un flux ISO-8859-1 en UTF-8 (et inversément) SANS passer par la création de fichiers, est-ce possible

:
Windows utilise pas défaut un flux UTF-16, est-il possible d'utilisé un autre format de flux ( ISO-8859-1,UTF-8...)? comment savoir le format du flux courant ? Y a-t-il des posibilité ? peux-tu m'aider ? Ou pis-je trouver l'information ou un exemple de code ?
D'avance merci.
A bientôt
Gorry

**spirit_epock** · 29/03/2006, 10h05

Voici un script pour envoyer un mail par Net::SMTP.

Il permet d'indiquer de renseigner l'expediteur, le destinataire,la date d'envoi (ce qui est pratique elle apparait bien dans les gestionnaires de mails), le sujet et le corp du message.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
#! C:\Perl\bin\perl -w 
 
use time::localtime;
use strict;
use Net::SMTP;
 
my $smtp;
my $date = localtime;
my $serveur_connexion = machin chose; #indiquer le serveur qui donne acces
 
	$smtp = Net::SMTP->new('$serveur_connexion', Debug =>1 , Timeout => 30) 
	or die "Connexion SMTP impossible\n : $!";
	$smtp->mail('toto@titi.net') or die "mail SMTP impossible\n : $!";
	$smtp->to('tata@tutu.net') or die "destinataire SMTP impossible\n : $!";
	$smtp->data() or die "data SMTP impossible\n : $!";
	$smtp->datasend("From: toto <toto\@titi.net\n");   	#destinataire
  $smtp->datasend("To: tata <tata\@tutu.net\n");   		#expeditaire
	$smtp->datasend("Date: $date\n");										#date
  $smtp->datasend("Subject  : Salut\n") or warn "Subject SMTP impossible\n : $!";	#sujet
  $smtp->datasend("\n");															# separateur
  $smtp->datasend("Tu mets.\n") or warn "Body SMTP impossible\n : $!";	# corps du message
  $smtp->datasend("ton texte.\n");	# corps du message
  $smtp->dataend() or die "Dataend SMTP impossible\n : $!";
	$smtp->quit or die "Quit SMTP impossible\n : $!";