Publicité
Discussion fermée
Page 6 sur 6 PremièrePremière ... 23456
Affichage des résultats 101 à 113 sur 113
  1. #101
    Membre chevronné
    Avatar de hornetbzz
    Homme Profil pro
    Directeur commercial
    Inscrit en
    octobre 2009
    Messages
    481
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France

    Informations professionnelles :
    Activité : Directeur commercial

    Informations forums :
    Inscription : octobre 2009
    Messages : 481
    Points : 739
    Points
    739

    Par défaut DBI mysql - tout avec des hashes (tableaux associatifs)

    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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 :
    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);
      0  0

  2. #102
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

    sur DBI, as tu lu cette doc?

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

  3. #103
    Membre chevronné
    Avatar de hornetbzz
    Homme Profil pro
    Directeur commercial
    Inscrit en
    octobre 2009
    Messages
    481
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 47
    Localisation : France

    Informations professionnelles :
    Activité : Directeur commercial

    Informations forums :
    Inscription : octobre 2009
    Messages : 481
    Points : 739
    Points
    739

    Par défaut

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

  4. #104
    Membre du Club

    Profil pro
    Inscrit en
    avril 2009
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : avril 2009
    Messages : 19
    Points : 45
    Points
    45

    Par défaut Fonction rabot améliorée

    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 :
    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.
      0  0

  5. #105
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

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

    Code :
    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


    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      1  0

  6. #106
    Membre éclairé
    Avatar de Dimitry.e
    Profil pro Dimitry Ernot
    Inscrit en
    janvier 2011
    Messages
    184
    Détails du profil
    Informations personnelles :
    Nom : Dimitry Ernot
    Âge : 28

    Informations professionnelles :
    Secteur : High Tech - Matériel informatique

    Informations forums :
    Inscription : janvier 2011
    Messages : 184
    Points : 318
    Points
    318

    Par défaut Récupération d'une page Web

    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 :
    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
    }
      0  0

  7. #107
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

    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 .

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

  8. #108
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

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

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

  9. #109
    Membre du Club

    Profil pro
    Inscrit en
    avril 2009
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : avril 2009
    Messages : 19
    Points : 45
    Points
    45

    Par défaut

    Citation Envoyé par djibril Voir le message
    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 :
    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 :
    1
    2
    3
     
    Ceci est un premi...
    Ceci est un...
      0  0

  10. #110
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

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

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

  11. #111
    Invité de passage
    Inscrit en
    décembre 2010
    Messages
    17
    Détails du profil
    Informations forums :
    Inscription : décembre 2010
    Messages : 17
    Points : 1
    Points
    1

    Par défaut Insertion des données à partir d'un fichier

    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 :
    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";
      0  0

  12. #112
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

    Citation Envoyé par Achir Voir le message
    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 :
    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é.

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

  13. #113
    Responsable Perl et Outils

    Avatar de djibril
    Homme Profil pro
    Inscrit en
    avril 2004
    Messages
    16 658
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : avril 2004
    Messages : 16 658
    Points : 490 378
    Points
    490 378

    Par défaut

    tout se passe maintenant ici.

    Pas de questions technique par messagerie privée (lisez les règles du forum Perl) et pour les nouveaux !
      0  0

Liens sociaux

Règles de messages

  • Vous ne pouvez pas créer de nouvelles discussions
  • Vous ne pouvez pas envoyer des réponses
  • Vous ne pouvez pas envoyer des pièces jointes
  • Vous ne pouvez pas modifier vos messages
  •