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

**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.

**vil-farfadet** · 21/01/2011, 11h20

Bonjour à tous,

Puisque l'on m'a fait l'honneur de mettre ma petite fonction dans les sources perl

, la moindre des choses c'est que je vous propose une version améliorée quand j'en ai une...

Cette nouvelle mouture ajoute une option qui permet de ne pas tronquer les mots :

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
 
sub rabot
{
	my $texte = $_[0];
	my $taille = $_[1];
	my $coupe = $_[2]; # booléen
	$coupe = 0 unless($coupe);
 
	if (length($texte) > $taille) {
		my ($suspension, $ajustement);
		$suspension = '...'; # peut être remplacer par &hellep; pour du HTML
		$ajustement = length($suspension);
		# Option pour des longueurs faibles si on souhaite privilégier les mots au points de suspension (ex. "Personnalisation de la prise en charge" avec longueur = 30) :
		# $ajustement = 0 if ($coupe && substr($texte, $taille-$ajustement, $ajustement) =~ / /);
		$texte = substr($texte, 0, $taille-$ajustement);
		$texte =~ s/([^ ,;:\.!\?\(\)])[ ,;:\.!\?\(\)]+[^ ]*$/$1/ if($coupe);
		$texte = $texte.$suspension if($ajustement);
	}
 
	return $texte;
}

Vos remarques et questions sont les bienvenues... même si ma présence sur le forum ne soit pas franchement régulière.

**djibril** · 21/01/2011, 11h29

Il faut être plus clair et donner un code propre et complet comme dans les sources :

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
#!/usr/bin/perl
use strict;
use warnings;
 
=for rabot
La fonction rabot() rabote une chaîne de caractère à une longueur donnée si la longueur initiale est supérieure.
Entrées obligatoires : Chaîne de caractères et Longueur
Sortie               : Chaîne de caractères résultante
 
=cut
print rabot("Ceci est un exemple de phrase.", 12);
sub rabot {
	my ($texte, $taille) = @_;
 
	$texte = substr($texte, 0, ($taille-3))."..." if(length($texte) > $taille);
 
	return $texte;
}

Puis je corrigerais le code pour le rendre plus propre

**Dimitry.e** · 01/02/2011, 14h49

Voici un script permettant de récupérer le contenu d'une page Web.
J'ai ajouté la possibilité de spécifier un proxy HTTP. Ainsi qu'un login pour les connexion HTTP (autorisation de base).

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
 
use warnings;  
use strict;
use Getopt::Long;
use LWP::Simple;
require LWP::UserAgent;
use MIME::Base64;
 
=begin COMM
 
Script permettant de recuperer le contenu du page web en HTTP avec utilisation d'un proxy et d'un login si besoin.
 
Arguments obligatoires :
  --url=URL
    Precise  la page a recuperer
 
Arguments Optionnels :   
  --login=USER:PASSWD
    Specifie le login a utiliser
  --proxy=PROXY
    Indiquer un proxy HTTP
 
=end COMM
=cut
 
my ($url, $login, $proxy) = (undef);
 
GetOptions("url=s" => \$url, "login=s" => \$login, "proxy=s" => \$proxy); # Recuperation et stockage des options dans leurs variables respectives
 
die ("Usage : ".$0." --url=URL\n") if (!defined($url)); # Le script a besoin d'au moins une URL pour fonctionner
die ("Usage : ".$0." --url=URL --login=USER:PASSWD\n") if (defined($login) and $login !~ /.+:.+/); # Le login doit etre forme du nom et du mot de passe separes par deux points 
 
my $ua = LWP::UserAgent->new; # Creation du User Agent. Il se charge de traiter la requete HTTP, comme un navigateur le ferait. 
$ua->timeout(20); # Le timeout permet de savoir a partir de quand on considere qu'un requete n'aboutira pas
 
my $req = HTTP::Request->new( GET => $url ); # On crée la requete HTTP correspondant a l'url
 
if (defined($proxy)) {
  $ua->env_proxy; # Indique a l'user agent qu'il va devoir utiliser un proxy
  $ua->proxy(['http'], $proxy); # Indique a l'user agent quel proxy utiliser
}
 
if (defined($login)) {
  my $token = encode_base64($login); # Encodage en base 64 comme le demande HTTP
  $req->header( Authorization => "Basic ".$token ); # Ajout de l'option 'Authorization Basic' et du login dans la requete. (cf RFC de HTTP)
}
 
my $content = $ua->request($req); # Envoi de la requete et reception de la reponse dans $content
 
if ($content->is_success) {
  print $content->decoded_content; # Si la requete a abouti, afficher le contenu de la page web
} else {
  die $content->status_line; # Afficher la raison de l'erreur
}

**djibril** · 01/02/2011, 14h58

Merci pour le code. Je vais changer la disposition de tes commentaires afin d'indenter ton code proprement. De plus, une réécriture plus strict s'impose

.

**djibril** · 01/02/2011, 15h40

Nouvelle question rajoutée : Comment récupérer une page Web ?

**vil-farfadet** · 15/02/2011, 18h15

Envoyé par djibril

Il faut être plus clair et donner un code propre et complet comme dans les sources

Puis je corrigerais le code pour le rendre plus propre

Ok, pas d'souci...

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
 
#!/usr/bin/perl
use strict;
use warnings;
 
=for rabot
La fonction rabot() rabote une chaîne de caractère à une longueur donnée si la longueur initiale est supérieure.
Entrées obligatoires : Chaîne de caractères et Longueur
Entrée optionnelle   : Booléen (ne coupe pas les mots si vrai)
Sortie               : Chaîne de caractères résultante
=cut
print rabot("Ceci est un premier exemple de phrase.", 20)."\n";
print rabot("Ceci est un second exemple de phrase.", 20, 1)."\n";
sub rabot
{
	my $texte = $_[0];
	my $taille = $_[1];
	my $coupe = $_[2];
	$coupe = 0 unless($coupe);
 
	if (length($texte) > $taille) {
		my ($suspension, $ajustement);
		$suspension = '...'; # Variante HTML : $suspension = '&hellep;';
		$ajustement = length($suspension);
		$texte = substr($texte, 0, $taille-$ajustement);
		$texte =~ s/([^ ,;:\.!\?\(\)])[ ,;:\.!\?\(\)]+[^ ]*$/$1/ if($coupe);
		$texte = $texte.$suspension if($ajustement);
	}
 
	return $texte;
}

Code :

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

1
2
3
 
Ceci est un premi...
Ceci est un...

**djibril** · 23/02/2011, 20h39

Nouvelle question : Comment fusionner plusieurs classeurs Excel d'un répertoire en un unique fichier ?
Plus une nouvelle section pour du code perl uniligne.

**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.

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

Langage Perl

Discussions similaires

Partager

Partager